expat.xs

one of the linux gd libraries

/*****************************************************************
** Expat.xs
**
** Copyright 1998 Larry Wall and Clark Cooper
** All rights reserved.
**
** This program is free software; you can redistribute it and/or
** modify it under the same terms as Perl itself.
**
*/

#include <expat.h>

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#undef convert

#include "patchlevel.h"
#include "encoding.h"


/* Version 5.005_5x (Development version for 5.006) doesn't like sv_...
   anymore, but 5.004 doesn't know about PL_sv..
   Don't want to push up required version just for this. */

#if PATCHLEVEL < 5
#define PL_sv_undef	sv_undef
#define PL_sv_no	sv_no
#define PL_sv_yes	sv_yes
#define PL_na		na
#endif

#define BUFSIZE 32768

#define NSDELIM  '|'

/* Macro to update handler fields. Used in the various handler setting
   XSUBS */

#define XMLP_UPD(fld) \
  RETVAL = cbv->fld ? newSVsv(cbv->fld) : &PL_sv_undef;\
  if (cbv->fld) {\
    if (cbv->fld != fld)\
      sv_setsv(cbv->fld, fld);\
  }\
  else\
    cbv->fld = newSVsv(fld)

/* Macro to push old handler value onto return stack. This is done here
   to get around a bug in 5.004 sv_2mortal function. */

#define PUSHRET \
  ST(0) = RETVAL;\
  if (RETVAL != &PL_sv_undef && SvREFCNT(RETVAL)) sv_2mortal(RETVAL)

typedef struct {
  SV* self_sv;
  XML_Parser p;

  AV* context;
  AV* new_prefix_list;
  HV *nstab;
  AV *nslst;

  unsigned int st_serial;
  unsigned int st_serial_stackptr;
  unsigned int st_serial_stacksize;
  unsigned int * st_serial_stack;

  unsigned int skip_until;

  SV *recstring;
  char * delim;
  STRLEN delimlen;

  unsigned ns:1;
  unsigned no_expand:1;
  unsigned parseparam:1;

  /* Callback handlers */

  SV* start_sv;
  SV* end_sv;
  SV* char_sv;
  SV* proc_sv;
  SV* cmnt_sv;
  SV* dflt_sv;

  SV* entdcl_sv;
  SV* eledcl_sv;
  SV* attdcl_sv;
  SV* doctyp_sv;
  SV* doctypfin_sv;
  SV* xmldec_sv;

  SV* unprsd_sv;
  SV* notation_sv;

  SV* extent_sv;
  SV* extfin_sv;

  SV* startcd_sv;
  SV* endcd_sv;
} CallbackVector;


static HV* EncodingTable = NULL;

static XML_Char nsdelim[] = {NSDELIM, '\0'};

static char *QuantChar[] = {"", "?", "*", "+"};

/* Forward declarations */

static void suspend_callbacks(CallbackVector *);
static void resume_callbacks(CallbackVector *);

#if PATCHLEVEL < 5 && SUBVERSION < 5

/* ================================================================
** This is needed where the length is explicitly given. The expat
** library may sometimes give us zero-length strings. Perl's newSVpv
** interprets a zero length as a directive to do a strlen. This
** function is used when we want to force length to mean length, even
** if zero.
*/

static SV *
newSVpvn(char *s, STRLEN len)
{
  register SV *sv;

  sv = newSV(0);
  sv_setpvn(sv, s, len);
  return sv;
}  /* End newSVpvn */

#define ERRSV GvSV(errgv)
#endif

#ifdef SvUTF8_on

static SV *
newUTF8SVpv(char *s, STRLEN len) {
  register SV *sv;

  sv = newSVpv(s, len);
  SvUTF8_on(sv);
  return sv;
}  /* End new UTF8SVpv */

static SV *
newUTF8SVpvn(char *s, STRLEN len) {
  register SV *sv;

  sv = newSV(0);
  sv_setpvn(sv, s, len);
  SvUTF8_on(sv);
  return sv;
}

#else  /* SvUTF8_on not defined */

#define newUTF8SVpv newSVpv
#define newUTF8SVpvn newSVpvn

#endif

static void*
mymalloc(size_t size) {
#ifndef LEAKTEST
  return safemalloc(size);
#else
  return safexmalloc(328,size);
#endif
}

static void*
myrealloc(void *p, size_t s) {
#ifndef LEAKTEST
  return saferealloc(p, s);
#else
  return safexrealloc(p, s);
#endif
}

static void
myfree(void *p) {
  Safefree(p);
}

static XML_Memory_Handling_Suite ms = {mymalloc, myrealloc, myfree};

static void
append_error(XML_Parser parser, char * err)
{
  dSP;
  CallbackVector * cbv;
  SV ** errstr;

  cbv = (CallbackVector*) XML_GetUserData(parser);
  errstr = hv_fetch((HV*)SvRV(cbv->self_sv),
		    "ErrorMessage", 12, 0);

  if (errstr && SvPOK(*errstr)) {
    SV ** errctx = hv_fetch((HV*) SvRV(cbv->self_sv),
			    "ErrorContext", 12, 0);
    int dopos = !err && errctx && SvOK(*errctx);

    if (! err)
      err = (char *) XML_ErrorString(XML_GetErrorCode(parser));

    sv_catpvf(*errstr, "\n%s at line %d, column %d, byte %d%s",
	      err,
	      XML_GetCurrentLineNumber(parser),
	      XML_GetCurrentColumnNumber(parser),
	      XML_GetCurrentByteIndex(parser),
	      dopos ? ":\n" : "");

    if (dopos)
      {
	int count;

	ENTER ;
	SAVETMPS ;
	PUSHMARK(sp);
	XPUSHs(cbv->self_sv);
	XPUSHs(*errctx);
	PUTBACK ;

	count = perl_call_method("position_in_context", G_SCALAR);

	SPAGAIN ;

	if (count >= 1) {
	  sv_catsv(*errstr, POPs);
	}

	PUTBACK ;
	FREETMPS ;
	LEAVE ;
      }
  }
}  /* End append_error */

static SV *
generate_model(XML_Content *model) {
  HV * hash = newHV();
  SV * obj = newRV_noinc((SV *) hash);

  sv_bless(obj, gv_stashpv("XML::Parser::ContentModel", 1));

  hv_store(hash, "Type", 4, newSViv(model->type), 0);
  if (model->quant != XML_CQUANT_NONE) {
    hv_store(hash, "Quant", 5, newSVpv(QuantChar[model->quant], 1), 0);
  }

  switch(model->type) {
  case XML_CTYPE_NAME:
    hv_store(hash, "Tag", 3, newUTF8SVpv((char *)model->name, 0), 0);
    break;

  case XML_CTYPE_MIXED:
  case XML_CTYPE_CHOICE:
  case XML_CTYPE_SEQ:
    if (model->children && model->numchildren)
      {
	AV * children = newAV();
	int i;

	for (i = 0; i < model->numchildren; i++) {
	  av_push(children, generate_model(&model->children[i]));
	}

	hv_store(hash, "Children", 8, newRV_noinc((SV *) children), 0);
      }
    break;
  }

  return obj;
}  /* End generate_model */

static int
parse_stream(XML_Parser parser, SV * ioref)
{
  dSP;
  SV *		tbuff;
  SV *		tsiz;
  char *	linebuff;
  STRLEN	lblen;
  STRLEN	br = 0;
  int		buffsize;
  int		done = 0;
  int		ret = 1;
  char *	msg = NULL;
  CallbackVector * cbv;
  char		*buff = (char *) 0;

  cbv = (CallbackVector*) XML_GetUserData(parser);

  ENTER;
  SAVETMPS;

  if (cbv->delim) {
    int cnt;
    SV * tline;

    PUSHMARK(SP);
    XPUSHs(ioref);
    PUTBACK ;

    cnt = perl_call_method("getline", G_SCALAR);

    SPAGAIN;

    if (cnt != 1)
      croak("getline method call failed");

    tline = POPs;

    if (! SvOK(tline)) {
      lblen = 0;
    }
    else {
      char *	chk;
      linebuff = SvPV(tline, lblen);
      chk = &linebuff[lblen - cbv->delimlen - 1];

      if (lblen > cbv->delimlen + 1
	  && *chk == *cbv->delim
	  && chk[cbv->delimlen] == '\n'
	  && strnEQ(++chk, cbv->delim + 1, cbv->delimlen - 1))
	lblen -= cbv->delimlen + 1;
    }

    PUTBACK ;
    buffsize = lblen;
    done = lblen == 0;
  }
  else {
    tbuff = newSV(0);
    tsiz = newSViv(BUFSIZE);
    buffsize = BUFSIZE;
  }

  while (! done)
    {
      char *buffer = XML_GetBuffer(parser, buffsize);

      if (! buffer)
	croak("Ran out of memory for input buffer");

      SAVETMPS;

      if (cbv->delim) {
	Copy(linebuff, buffer, lblen, char);
	br = lblen;
	done = 1;
      }
      else {
	int cnt;
	SV * rdres;
	char * tb;

	PUSHMARK(SP);
	EXTEND(SP, 3);
	PUSHs(ioref);
	PUSHs(tbuff);
	PUSHs(tsiz);
	PUTBACK ;

	cnt = perl_call_method("read", G_SCALAR);

	SPAGAIN ;

	if (cnt != 1)
	  croak("read method call failed");

	rdres = POPs;

	if (! SvOK(rdres))
	  croak("read error");

	tb = SvPV(tbuff, br);
	if (br > 0)
	  Copy(tb, buffer, br, char);
	else
	  done = 1;

	PUTBACK ;
      }

      ret = XML_ParseBuffer(parser, br, done);

      SPAGAIN; /* resync local SP in case callbacks changed global stack */

      if (! ret)
	break;

      FREETMPS;
    }

  if (! ret)
    append_error(parser, msg);

  if (! cbv->delim) {
    SvREFCNT_dec(tsiz);
    SvREFCNT_dec(tbuff);
  }
      
  FREETMPS;
  LEAVE;

  return ret;
}  /* End parse_stream */

static SV *
gen_ns_name(const char * name, HV * ns_table, AV * ns_list)
{
  char	*pos = strchr(name, NSDELIM);
  SV * ret;

  if (pos && pos > name)
    {
      SV ** name_ent = hv_fetch(ns_table, (char *) name,
				pos - name, TRUE);
      ret = newUTF8SVpv(&pos[1], 0);

      if (name_ent)
	{
	  int index;

	  if (SvOK(*name_ent))
	    {
	      index = SvIV(*name_ent);
	    }
	  else
	    {
	      av_push(ns_list,  newUTF8SVpv((char *) name, pos - name));
	      index = av_len(ns_list);
	      sv_setiv(*name_ent, (IV) index);
	    }

	  sv_setiv(ret, (IV) index);
	  SvPOK_on(ret);
	}
    }
  else
    ret = newUTF8SVpv((char *) name, 0);

  return ret;
}  /* End gen_ns_name */

static void
characterData(void *userData, const char *s, int len)
{
  dSP;
  CallbackVector* cbv = (CallbackVector*) userData;

  ENTER;
  SAVETMPS;

  PUSHMARK(sp);
  EXTEND(sp, 2);
  PUSHs(cbv->self_sv);
  PUSHs(sv_2mortal(newUTF8SVpvn((char*)s,len)));
  PUTBACK;
  perl_call_sv(cbv->char_sv, G_DISCARD);

  FREETMPS;
  LEAVE;
}  /* End characterData */

static void
startElement(void *userData, const char *name, const char **atts)
{
  dSP;
  CallbackVector* cbv = (CallbackVector*) userData;
  SV ** pcontext;
  unsigned   do_ns = cbv->ns;
  unsigned   skipping = 0;
  SV ** pnstab;
  SV ** pnslst;
  SV *  elname;

  cbv->st_serial++;

  if (cbv->skip_until) {
    skipping = cbv->st_serial < cbv->skip_until;
    if (! skipping) {
      resume_callbacks(cbv);
      cbv->skip_until = 0;
    }
  }

  if (cbv->st_serial_stackptr >= cbv->st_serial_stacksize) {
    unsigned int newsize = cbv->st_serial_stacksize + 512;

    Renew(cbv->st_serial_stack, newsize, unsigned int);
    cbv->st_serial_stacksize = newsize;
  }

  cbv->st_serial_stack[++cbv->st_serial_stackptr] =  cbv->st_serial;
  
  if (do_ns)
    elname = gen_ns_name(name, cbv->nstab, cbv->nslst);
  else
    elname = newUTF8SVpv((char *)name, 0);

  if (! skipping && SvTRUE(cbv->start_sv))
    {
      const char **attlim = atts;

      while (*attlim)
	attlim++;

      ENTER;
      SAVETMPS;

      PUSHMARK(sp);
      EXTEND(sp, attlim - atts + 2);
      PUSHs(cbv->self_sv);
      PUSHs(elname);
      while (*atts)
	{
	  SV * attname;

	  attname = (do_ns ? gen_ns_name(*atts, cbv->nstab, cbv->nslst)
		     : newUTF8SVpv((char *) *atts, 0));
	    
	  atts++;
	  PUSHs(sv_2mortal(attname));
	  if (*atts)
	    PUSHs(sv_2mortal(newUTF8SVpv((char*)*atts++,0)));
	}
      PUTBACK;
      perl_call_sv(cbv->start_sv, G_DISCARD);

      FREETMPS;
      LEAVE;
    }

  av_push(cbv->context, elname);

  if (cbv->ns) {
    av_clear(cbv->new_prefix_list);
  }
} /* End startElement */

static void
endElement(void *userData, const char *name)
{
  dSP;
  CallbackVector* cbv = (CallbackVector*) userData;
  SV *elname;

  elname = av_pop(cbv->context);
  
  if (! cbv->st_serial_stackptr) {
    croak("endElement: Start tag serial number stack underflow");
  }

  if (! cbv->skip_until && SvTRUE(cbv->end_sv))
    {
      ENTER;
      SAVETMPS;

      PUSHMARK(sp);
      EXTEND(sp, 2);
      PUSHs(cbv->self_sv);
      PUSHs(elname);
      PUTBACK;
      perl_call_sv(cbv->end_sv, G_DISCARD);

      FREETMPS;
      LEAVE;
    }

  cbv->st_serial_stackptr--;

  SvREFCNT_dec(elname);
}  /* End endElement */

static void
processingInstruction(void *userData, const char *target, const char *data)
{
  dSP;
  CallbackVector* cbv = (CallbackVector*) userData;

  ENTER;
  SAVETMPS;

  PUSHMARK(sp);
  EXTEND(sp, 3);
  PUSHs(cbv->self_sv);
  PUSHs(sv_2mortal(newUTF8SVpv((char*)target,0)));
  PUSHs(sv_2mortal(newUTF8SVpv((char*)data,0)));
  PUTBACK;
  perl_call_sv(cbv->proc_sv, G_DISCARD);

  FREETMPS;
  LEAVE;
}  /* End processingInstruction */

static void
commenthandle(void *userData, const char *string)
{
  dSP;
  CallbackVector * cbv = (CallbackVector*) userData;

  ENTER;
  SAVETMPS;

  PUSHMARK(sp);
  EXTEND(sp, 2);
  PUSHs(cbv->self_sv);
  PUSHs(sv_2mortal(newUTF8SVpv((char*) string, 0)));
  PUTBACK;
  perl_call_sv(cbv->cmnt_sv, G_DISCARD);

  FREETMPS;
  LEAVE;
}  /* End commenthandler */

static void
startCdata(void *userData)
{
  dSP;
  CallbackVector* cbv = (CallbackVector*) userData;

  if (cbv->startcd_sv) {
    ENTER;
    SAVETMPS;

    PUSHMARK(sp);
    XPUSHs(cbv->self_sv);
    PUTBACK;
    perl_call_sv(cbv->startcd_sv, G_DISCARD);

    FREETMPS;
    LEAVE;
  }
}  /* End startCdata */

static void
endCdata(void *userData)
{
  dSP;
  CallbackVector* cbv = (CallbackVector*) userData;

  if (cbv->endcd_sv) {
    ENTER;
    SAVETMPS;

    PUSHMARK(sp);
    XPUSHs(cbv->self_sv);
    PUTBACK;
    perl_call_sv(cbv->endcd_sv, G_DISCARD);

    FREETMPS;
    LEAVE;
  }
}  /* End endCdata */

static void
nsStart(void *userdata, const XML_Char *prefix, const XML_Char *uri){
  dSP;
  CallbackVector* cbv = (CallbackVector*) userdata;

  ENTER;
  SAVETMPS;

  PUSHMARK(sp);
  EXTEND(sp, 3);
  PUSHs(cbv->self_sv);
  PUSHs(prefix ? sv_2mortal(newUTF8SVpv((char *)prefix, 0)) : &PL_sv_undef);
  PUSHs(uri ? sv_2mortal(newUTF8SVpv((char *)uri, 0)) : &PL_sv_undef);
  PUTBACK;
  perl_call_method("NamespaceStart", G_DISCARD);

  FREETMPS;
  LEAVE;
}  /* End nsStart */

static void
nsEnd(void *userdata, const XML_Char *prefix) {
  dSP;
  CallbackVector* cbv = (CallbackVector*) userdata;

  ENTER;
  SAVETMPS;

  PUSHMARK(sp);
  EXTEND(sp, 2);
  PUSHs(cbv->self_sv);
  PUSHs(prefix ? sv_2mortal(newUTF8SVpv((char *)prefix, 0)) : &PL_sv_undef);
  PUTBACK;
  perl_call_method("NamespaceEnd", G_DISCARD);

  FREETMPS;
  LEAVE;
}  /* End nsEnd */

static void
defaulthandle(void *userData, const char *string, int len)
{
  dSP;
  CallbackVector* cbv = (CallbackVector*) userData;

  ENTER;
  SAVETMPS;

  PUSHMARK(sp);
  EXTEND(sp, 2);
  PUSHs(cbv->self_sv);
  PUSHs(sv_2mortal(newUTF8SVpvn((char*)string, len)));
  PUTBACK;
  perl_call_sv(cbv->dflt_sv, G_DISCARD);

  FREETMPS;
  LEAVE;
}  /* End defaulthandle */

static void
elementDecl(void *data,
	    const char *name,
	    XML_Content *model) {
  dSP;
  CallbackVector *cbv = (CallbackVector*) data;
  SV *cmod;

  ENTER;
  SAVETMPS;


  cmod = generate_model(model);