home *** CD-ROM | disk | FTP | other *** search
/ Netrunner 2004 October / NETRUNNER0410.ISO / regular / ActivePerl-5.8.4.810-MSWin32-x86.msi / _3d0be83e8148ea903e731248db5798b1 < prev    next >
Text File  |  2004-06-01  |  7KB  |  203 lines
  1. # ======================================================================
  2. #
  3. # Copyright (C) 2000-2001 Paul Kulchenko (paulclinger@yahoo.com)
  4. # SOAP::Lite is free software; you can redistribute it
  5. # and/or modify it under the same terms as Perl itself.
  6. #
  7. # $Id: Lite.pm,v 1.4 2001/10/15 21:25:05 paulk Exp $
  8. #
  9. # ======================================================================
  10.  
  11. package XML::Parser::Lite;
  12.  
  13. use strict;
  14. use vars qw($VERSION);
  15. $VERSION = sprintf("%d.%s", map {s/_//g; $_} q$Name: release-0_55-public $ =~ /-(\d+)_([\d_]+)/);
  16.  
  17. sub new { 
  18.   my $self = shift;
  19.   my $class = ref($self) || $self;
  20.   return $self if ref $self;
  21.  
  22.   $self = bless {} => $class;
  23.   my %parameters = @_;
  24.   $self->setHandlers(); # clear first 
  25.   $self->setHandlers(%{$parameters{Handlers} || {}});
  26.   return $self;
  27. }
  28.  
  29. sub setHandlers {
  30.   my $self = shift; 
  31.   no strict 'refs'; local $^W;
  32.   # clear all handlers if called without parameters
  33.   unless (@_) { foreach (qw(Start End Char Final Init)) { *$_ = sub {} } }
  34.   while (@_) { my($name => $func) = splice(@_, 0, 2); *$name = defined $func ? $func : sub {} }
  35.   return $self;
  36. }
  37.  
  38. sub regexp {
  39.   my $patch = shift || '';
  40.   my $package = __PACKAGE__;
  41.  
  42.   # This parser is based on "shallow parser" http://www.cs.sfu.ca/~cameron/REX.html 
  43.  
  44.   # Robert D. Cameron "REX: XML Shallow Parsing with Regular Expressions",
  45.   # Technical Report TR 1998-17, School of Computing Science, Simon Fraser University, November, 1998.
  46.   # Copyright (c) 1998, Robert D. Cameron. 
  47.   # The following code may be freely used and distributed provided that
  48.   # this copyright and citation notice remains intact and that modifications
  49.   # or additions are clearly identified.
  50.  
  51.   my $TextSE = "[^<]+";
  52.   my $UntilHyphen = "[^-]*-";
  53.   my $Until2Hyphens = "$UntilHyphen(?:[^-]$UntilHyphen)*-";
  54.   my $CommentCE = "$Until2Hyphens>?";
  55.   my $UntilRSBs = "[^\\]]*](?:[^\\]]+])*]+";
  56.   my $CDATA_CE = "$UntilRSBs(?:[^\\]>]$UntilRSBs)*>";
  57.   my $S = "[ \\n\\t\\r]+";
  58.   my $NameStrt = "[A-Za-z_:]|[^\\x00-\\x7F]";
  59.   my $NameChar = "[A-Za-z0-9_:.-]|[^\\x00-\\x7F]";
  60.   my $Name = "(?:$NameStrt)(?:$NameChar)*";
  61.   my $QuoteSE = "\"[^\"]*\"|'[^']*'";
  62.   my $DT_IdentSE = "$S$Name(?:$S(?:$Name|$QuoteSE))*";
  63.   my $MarkupDeclCE = "(?:[^\\]\"'><]+|$QuoteSE)*>";
  64.   my $S1 = "[\\n\\r\\t ]";
  65.   my $UntilQMs = "[^?]*\\?+";
  66.   my $PI_Tail = "\\?>|$S1$UntilQMs(?:[^>?]$UntilQMs)*>";
  67.   my $DT_ItemSE = "<(?:!(?:--$Until2Hyphens>|[^-]$MarkupDeclCE)|\\?$Name(?:$PI_Tail))|%$Name;|$S";
  68.   my $DocTypeCE = "$DT_IdentSE(?:$S)?(?:\\[(?:$DT_ItemSE)*](?:$S)?)?>?";
  69.   my $DeclCE = "--(?:$CommentCE)?|\\[CDATA\\[(?:$CDATA_CE)?|DOCTYPE(?:$DocTypeCE)?";
  70.   my $PI_CE = "$Name(?:$PI_Tail)?";
  71.  
  72.   # these expressions were modified for backtracking and events
  73.   my $EndTagCE = "($Name)(?{${package}::end(\$2)})(?:$S)?>";
  74.   my $AttValSE = "\"([^<\"]*)\"|'([^<']*)'";
  75.   my $ElemTagCE = "($Name)(?:$S($Name)(?:$S)?=(?:$S)?(?:$AttValSE)(?{[\@{\$^R||[]},\$4=>defined\$5?\$5:\$6]}))*(?:$S)?(/)?>(?{${package}::start(\$3,\@{\$^R||[]})})(?{\${7} and ${package}::end(\$3)})";
  76.   my $MarkupSPE = "<(?:!(?:$DeclCE)?|\\?(?:$PI_CE)?|/(?:$EndTagCE)?|(?:$ElemTagCE)?)";
  77.  
  78.   # Next expression is under "black magic".
  79.   # Ideally it should be '($TextSE)(?{${package}::char(\$1)})|$MarkupSPE',
  80.   # but it doesn't work under Perl 5.005 and only magic with
  81.   # (?:....)?? solved the problem. 
  82.   # I would appreciate if someone let me know what is the right thing to do 
  83.   # and what's the reason for all this magic. 
  84.   # Seems like a problem related to (?:....)? rather than to ?{} feature.
  85.   # Tests are in t/31-xmlparserlite.t if you decide to play with it.
  86.   "(?:($TextSE)(?{${package}::char(\$1)}))$patch|$MarkupSPE";
  87. }
  88.  
  89. sub compile { local $^W; 
  90.   # try regexp as it should be, apply patch if doesn't work
  91.   foreach (regexp(), regexp('??')) {
  92.     eval qq{sub parse_re { use re "eval"; 1 while \$_[0] =~ m{$_}go }; 1} or die;
  93.     last if eval { parse_re('<foo>bar</foo>'); 1 }
  94.   };
  95.  
  96.   *compile = sub {};
  97. }
  98.  
  99. setHandlers();
  100. compile();
  101.  
  102. sub parse { 
  103.   init(); 
  104.   parse_re($_[1]);
  105.   final(); 
  106. }
  107.  
  108. my(@stack, $level);
  109.  
  110. sub init { 
  111.   @stack = (); $level = 0;
  112.   Init(__PACKAGE__, @_);  
  113. }
  114.  
  115. sub final { 
  116.   die "not properly closed tag '$stack[-1]'\n" if @stack;
  117.   die "no element found\n" unless $level;
  118.   Final(__PACKAGE__, @_) 
  119. } 
  120.  
  121. sub start { 
  122.   die "multiple roots, wrong element '$_[0]'\n" if $level++ && !@stack;
  123.   push(@stack, $_[0]);
  124.   Start(__PACKAGE__, @_); 
  125. }
  126.  
  127. sub char { 
  128.   Char(__PACKAGE__, $_[0]), return if @stack;
  129.  
  130.   # check for junk before or after element
  131.   # can't use split or regexp due to limitations in ?{} implementation, 
  132.   # will iterate with loop, but we'll do it no more than two times, so
  133.   # it shouldn't affect performance
  134.   for (my $i=0; $i < length $_[0]; $i++) {
  135.     die "junk '$_[0]' @{[$level ? 'after' : 'before']} XML element\n"
  136.       if index("\n\r\t ", substr($_[0],$i,1)) < 0; # or should '< $[' be there
  137.   }
  138. }
  139.  
  140. sub end { 
  141.   pop(@stack) eq $_[0] or die "mismatched tag '$_[0]'\n";
  142.   End(__PACKAGE__, $_[0]);
  143. }
  144.  
  145. # ======================================================================
  146.  
  147. 1;
  148.  
  149. __END__
  150.  
  151. =head1 NAME
  152.  
  153. XML::Parser::Lite - Lightweight regexp-based XML parser
  154.  
  155. =head1 SYNOPSIS
  156.  
  157.   use XML::Parser::Lite;
  158.   
  159.   $p1 = new XML::Parser::Lite;
  160.   $p1->setHandlers(
  161.     Start => sub { shift; print "start: @_\n" },
  162.     Char => sub { shift; print "char: @_\n" },
  163.     End => sub { shift; print "end: @_\n" },
  164.   );
  165.   $p1->parse('<foo id="me">Hello World!</foo>');
  166.  
  167.   $p2 = new XML::Parser::Lite
  168.     Handlers => {
  169.       Start => sub { shift; print "start: @_\n" },
  170.       Char => sub { shift; print "char: @_\n" },
  171.       End => sub { shift; print "end: @_\n" },
  172.     }
  173.   ;
  174.   $p2->parse('<foo id="me">Hello <bar>cruel</bar> World!</foo>');
  175.  
  176. =head1 DESCRIPTION
  177.  
  178. This Perl module gives you access to XML parser with interface similar to
  179. XML::Parser interface. Though only basic calls are supported (init, final,
  180. start, char, and end) you should be able to use it in the same way you use
  181. XML::Parser. Due to using experimantal regexp features it'll work only on
  182. Perl 5.6 and may behave differently on different platforms.
  183.  
  184. =head1 SEE ALSO
  185.  
  186.  XML::Parser
  187.  
  188. =head1 COPYRIGHT
  189.  
  190. Copyright (C) 2000-2001 Paul Kulchenko. All rights reserved.
  191.  
  192. This library is free software; you can redistribute it and/or modify
  193. it under the same terms as Perl itself.
  194.  
  195. This parser is based on "shallow parser" http://www.cs.sfu.ca/~cameron/REX.html
  196. Copyright (c) 1998, Robert D. Cameron.
  197.  
  198. =head1 AUTHOR
  199.  
  200. Paul Kulchenko (paulclinger@yahoo.com)
  201.  
  202. =cut
  203.