Файловый менеджер - Редактировать - /home/lakoyani/lakoyani.com.fj/Parser.pm.tar
Назад
usr/local/lib64/perl5/XML/Parser.pm 0000444 00000066111 14711271527 0012662 0 ustar 00 # XML::Parser # # Copyright (c) 1998-2000 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. package XML::Parser; use strict; our ( $VERSION, $LWP_load_failed ); use Carp; BEGIN { require XML::Parser::Expat; $VERSION = '2.46'; die "Parser.pm and Expat.pm versions don't match" unless $VERSION eq $XML::Parser::Expat::VERSION; } $LWP_load_failed = 0; sub new { my ( $class, %args ) = @_; my $style = $args{Style}; my $nonexopt = $args{Non_Expat_Options} ||= {}; $nonexopt->{Style} = 1; $nonexopt->{Non_Expat_Options} = 1; $nonexopt->{Handlers} = 1; $nonexopt->{_HNDL_TYPES} = 1; $nonexopt->{NoLWP} = 1; $args{_HNDL_TYPES} = {%XML::Parser::Expat::Handler_Setters}; $args{_HNDL_TYPES}->{Init} = 1; $args{_HNDL_TYPES}->{Final} = 1; $args{Handlers} ||= {}; my $handlers = $args{Handlers}; if ( defined($style) ) { my $stylepkg = $style; if ( $stylepkg !~ /::/ ) { $stylepkg = "\u$style"; eval { my $fullpkg = "XML::Parser::Style::$stylepkg"; my $stylefile = $fullpkg; $stylefile =~ s/::/\//g; require "$stylefile.pm"; $stylepkg = $fullpkg; }; if ($@) { # fallback to old behaviour $stylepkg = "XML::Parser::$stylepkg"; } } foreach my $htype ( keys %{ $args{_HNDL_TYPES} } ) { # Handlers explicitly given override # handlers from the Style package unless ( defined( $handlers->{$htype} ) ) { # A handler in the style package must either have # exactly the right case as the type name or a # completely lower case version of it. my $hname = "${stylepkg}::$htype"; if ( defined(&$hname) ) { $handlers->{$htype} = \&$hname; next; } $hname = "${stylepkg}::\L$htype"; if ( defined(&$hname) ) { $handlers->{$htype} = \&$hname; next; } } } } unless ( defined( $handlers->{ExternEnt} ) or defined( $handlers->{ExternEntFin} ) ) { if ( $args{NoLWP} or $LWP_load_failed ) { $handlers->{ExternEnt} = \&file_ext_ent_handler; $handlers->{ExternEntFin} = \&file_ext_ent_cleanup; } else { # The following just bootstraps the real LWP external entity # handler $handlers->{ExternEnt} = \&initial_ext_ent_handler; # No cleanup function available until LWPExternEnt.pl loaded } } $args{Pkg} ||= caller; bless \%args, $class; } # End of new sub setHandlers { my ( $self, @handler_pairs ) = @_; croak('Uneven number of arguments to setHandlers method') if ( int(@handler_pairs) & 1 ); my @ret; while (@handler_pairs) { my $type = shift @handler_pairs; my $handler = shift @handler_pairs; unless ( defined( $self->{_HNDL_TYPES}->{$type} ) ) { my @types = sort keys %{ $self->{_HNDL_TYPES} }; croak("Unknown Parser handler type: $type\n Valid types: @types"); } push( @ret, $type, $self->{Handlers}->{$type} ); $self->{Handlers}->{$type} = $handler; } return @ret; } sub parse_start { my $self = shift; my @expat_options = (); my ( $key, $val ); while ( ( $key, $val ) = each %{$self} ) { push( @expat_options, $key, $val ) unless exists $self->{Non_Expat_Options}->{$key}; } my %handlers = %{ $self->{Handlers} }; my $init = delete $handlers{Init}; my $final = delete $handlers{Final}; my $expatnb = XML::Parser::ExpatNB->new( @expat_options, @_ ); $expatnb->setHandlers(%handlers); &$init($expatnb) if defined($init); $expatnb->{_State_} = 1; $expatnb->{FinalHandler} = $final if defined($final); return $expatnb; } sub parse { my $self = shift; my $arg = shift; my @expat_options = (); my ( $key, $val ); while ( ( $key, $val ) = each %{$self} ) { push( @expat_options, $key, $val ) unless exists $self->{Non_Expat_Options}->{$key}; } my $expat = XML::Parser::Expat->new( @expat_options, @_ ); my %handlers = %{ $self->{Handlers} }; my $init = delete $handlers{Init}; my $final = delete $handlers{Final}; $expat->setHandlers(%handlers); if ( $self->{Base} ) { $expat->base( $self->{Base} ); } &$init($expat) if defined($init); my @result = (); my $result; eval { $result = $expat->parse($arg); }; my $err = $@; if ($err) { $expat->release; die $err; } if ( $result and defined($final) ) { if (wantarray) { @result = &$final($expat); } else { $result = &$final($expat); } } $expat->release; return unless defined wantarray; return wantarray ? @result : $result; } sub parsestring { my $self = shift; $self->parse(@_); } sub parsefile { my $self = shift; my $file = shift; open( my $fh, '<', $file ) or croak "Couldn't open $file:\n$!"; binmode($fh); my @ret; my $ret; $self->{Base} = $file; if (wantarray) { eval { @ret = $self->parse( $fh, @_ ); }; } else { eval { $ret = $self->parse( $fh, @_ ); }; } my $err = $@; close($fh); die $err if $err; return unless defined wantarray; return wantarray ? @ret : $ret; } sub initial_ext_ent_handler { # This just bootstraps in the real lwp_ext_ent_handler which # also loads the URI and LWP modules. unless ($LWP_load_failed) { local ($^W) = 0; my $stat = eval { require('XML/Parser/LWPExternEnt.pl'); }; if ($stat) { $_[0]->setHandlers( ExternEnt => \&lwp_ext_ent_handler, ExternEntFin => \&lwp_ext_ent_cleanup ); goto &lwp_ext_ent_handler; } # Failed to load lwp handler, act as if NoLWP $LWP_load_failed = 1; my $cmsg = "Couldn't load LWP based external entity handler\n" . "Switching to file-based external entity handler\n" . " (To avoid this message, use NoLWP option to XML::Parser)\n"; warn($cmsg); } $_[0]->setHandlers( ExternEnt => \&file_ext_ent_handler, ExternEntFin => \&file_ext_ent_cleanup ); goto &file_ext_ent_handler; } sub file_ext_ent_handler { my ( $xp, $base, $path ) = @_; # Prepend base only for relative paths if ( defined($base) and not( $path =~ m!^(?:[\\/]|\w+:)! ) ) { my $newpath = $base; $newpath =~ s![^\\/:]*$!$path!; $path = $newpath; } if ( $path =~ /^\s*[|>+]/ or $path =~ /\|\s*$/ ) { $xp->{ErrorMessage} .= "System ID ($path) contains Perl IO control characters"; return undef; } require IO::File; my $fh = IO::File->new($path); unless ( defined $fh ) { $xp->{ErrorMessage} .= "Failed to open $path:\n$!"; return undef; } $xp->{_BaseStack} ||= []; $xp->{_FhStack} ||= []; push( @{ $xp->{_BaseStack} }, $base ); push( @{ $xp->{_FhStack} }, $fh ); $xp->base($path); return $fh; } sub file_ext_ent_cleanup { my ($xp) = @_; my $fh = pop( @{ $xp->{_FhStack} } ); $fh->close; my $base = pop( @{ $xp->{_BaseStack} } ); $xp->base($base); } 1; __END__ =head1 NAME XML::Parser - A perl module for parsing XML documents =head1 SYNOPSIS use XML::Parser; $p1 = XML::Parser->new(Style => 'Debug'); $p1->parsefile('REC-xml-19980210.xml'); $p1->parse('<foo id="me">Hello World</foo>'); # Alternative $p2 = XML::Parser->new(Handlers => {Start => \&handle_start, End => \&handle_end, Char => \&handle_char}); $p2->parse($socket); # Another alternative $p3 = XML::Parser->new(ErrorContext => 2); $p3->setHandlers(Char => \&text, Default => \&other); open(my $fh, 'xmlgenerator |'); $p3->parse($foo, ProtocolEncoding => 'ISO-8859-1'); close($foo); $p3->parsefile('junk.xml', ErrorContext => 3); =begin man .ds PI =end man =head1 DESCRIPTION This module provides ways to parse XML documents. It is built on top of L<XML::Parser::Expat>, which is a lower level interface to James Clark's expat library. Each call to one of the parsing methods creates a new instance of XML::Parser::Expat which is then used to parse the document. Expat options may be provided when the XML::Parser object is created. These options are then passed on to the Expat object on each parse call. They can also be given as extra arguments to the parse methods, in which case they override options given at XML::Parser creation time. The behavior of the parser is controlled either by C<L</STYLES>> and/or C<L</HANDLERS>> options, or by L</setHandlers> method. These all provide mechanisms for XML::Parser to set the handlers needed by XML::Parser::Expat. If neither C<Style> nor C<Handlers> are specified, then parsing just checks the document for being well-formed. When underlying handlers get called, they receive as their first parameter the I<Expat> object, not the Parser object. =head1 METHODS =over 4 =item new This is a class method, the constructor for XML::Parser. Options are passed as keyword value pairs. Recognized options are: =over 4 =item * Style This option provides an easy way to create a given style of parser. The built in styles are: L<"Debug">, L<"Subs">, L<"Tree">, L<"Objects">, and L<"Stream">. These are all defined in separate packages under C<XML::Parser::Style::*>, and you can find further documentation for each style both below, and in those packages. Custom styles can be provided by giving a full package name containing at least one '::'. This package should then have subs defined for each handler it wishes to have installed. See L<"STYLES"> below for a discussion of each built in style. =item * Handlers When provided, this option should be an anonymous hash containing as keys the type of handler and as values a sub reference to handle that type of event. All the handlers get passed as their 1st parameter the instance of expat that is parsing the document. Further details on handlers can be found in L<"HANDLERS">. Any handler set here overrides the corresponding handler set with the Style option. =item * Pkg Some styles will refer to subs defined in this package. If not provided, it defaults to the package which called the constructor. =item * ErrorContext This is an Expat option. When this option is defined, errors are reported in context. The value should be the number of lines to show on either side of the line in which the error occurred. =item * ProtocolEncoding This is an Expat option. This sets the protocol encoding name. It defaults to none. The built-in encodings are: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and C<US-ASCII>. Other encodings may be used if they have encoding maps in one of the directories in the @Encoding_Path list. Check L<"ENCODINGS"> for more information on encoding maps. Setting the protocol encoding overrides any encoding in the XML declaration. =item * Namespaces This is an Expat option. If this is set to a true value, then namespace processing is done during the parse. See L<XML::Parser::Expat/"Namespaces"> for further discussion of namespace processing. =item * NoExpand This is an Expat option. Normally, the parser will try to expand references to entities defined in the internal subset. If this option is set to a true value, and a default handler is also set, then the default handler will be called when an entity reference is seen in text. This has no effect if a default handler has not been registered, and it has no effect on the expansion of entity references inside attribute values. =item * Stream_Delimiter This is an Expat option. It takes a string value. When this string is found alone on a line while parsing from a stream, then the parse is ended as if it saw an end of file. The intended use is with a stream of xml documents in a MIME multipart format. The string should not contain a trailing newline. =item * ParseParamEnt This is an Expat option. Unless standalone is set to "yes" in the XML declaration, setting this to a true value allows the external DTD to be read, and parameter entities to be parsed and expanded. =item * NoLWP This option has no effect if the ExternEnt or ExternEntFin handlers are directly set. Otherwise, if true, it forces the use of a file based external entity handler. =item * Non_Expat_Options If provided, this should be an anonymous hash whose keys are options that shouldn't be passed to Expat. This should only be of concern to those subclassing XML::Parser. =back =item setHandlers(TYPE, HANDLER [, TYPE, HANDLER [...]]) This method registers handlers for various parser events. It overrides any previous handlers registered through the Style or Handler options or through earlier calls to setHandlers. By providing a false or undefined value as the handler, the existing handler can be unset. This method returns a list of type, handler pairs corresponding to the input. The handlers returned are the ones that were in effect prior to the call. See a description of the handler types in L<"HANDLERS">. =item parse(SOURCE [, OPT => OPT_VALUE [...]]) The SOURCE parameter should either be a string containing the whole XML document, or it should be an open IO::Handle. Constructor options to XML::Parser::Expat given as keyword-value pairs may follow the SOURCE parameter. These override, for this call, any options or attributes passed through from the XML::Parser instance. A die call is thrown if a parse error occurs. Otherwise it will return 1 or whatever is returned from the B<Final> handler, if one is installed. In other words, what parse may return depends on the style. =item parsestring This is just an alias for parse for backwards compatibility. =item parsefile(FILE [, OPT => OPT_VALUE [...]]) Open FILE for reading, then call parse with the open handle. The file is closed no matter how parse returns. Returns what parse returns. =item parse_start([ OPT => OPT_VALUE [...]]) Create and return a new instance of XML::Parser::ExpatNB. Constructor options may be provided. If an init handler has been provided, it is called before returning the ExpatNB object. Documents are parsed by making incremental calls to the parse_more method of this object, which takes a string. A single call to the parse_done method of this object, which takes no arguments, indicates that the document is finished. If there is a final handler installed, it is executed by the parse_done method before returning and the parse_done method returns whatever is returned by the final handler. =back =head1 HANDLERS Expat is an event based parser. As the parser recognizes parts of the document (say the start or end tag for an XML element), then any handlers registered for that type of an event are called with suitable parameters. All handlers receive an instance of XML::Parser::Expat as their first argument. See L<XML::Parser::Expat/"METHODS"> for a discussion of the methods that can be called on this object. =head2 Init (Expat) This is called just before the parsing of the document starts. =head2 Final (Expat) This is called just after parsing has finished, but only if no errors occurred during the parse. Parse returns what this returns. =head2 Start (Expat, Element [, Attr, Val [,...]]) This event is generated when an XML start tag is recognized. Element is the name of the XML element type that is opened with the start tag. The Attr & Val pairs are generated for each attribute in the start tag. =head2 End (Expat, Element) This event is generated when an XML end tag is recognized. Note that an XML empty tag (<foo/>) generates both a start and an end event. =head2 Char (Expat, String) This event is generated when non-markup is recognized. The non-markup sequence of characters is in String. A single non-markup sequence of characters may generate multiple calls to this handler. Whatever the encoding of the string in the original document, this is given to the handler in UTF-8. =head2 Proc (Expat, Target, Data) This event is generated when a processing instruction is recognized. =head2 Comment (Expat, Data) This event is generated when a comment is recognized. =head2 CdataStart (Expat) This is called at the start of a CDATA section. =head2 CdataEnd (Expat) This is called at the end of a CDATA section. =head2 Default (Expat, String) This is called for any characters that don't have a registered handler. This includes both characters that are part of markup for which no events are generated (markup declarations) and characters that could generate events, but for which no handler has been registered. Whatever the encoding in the original document, the string is returned to the handler in UTF-8. =head2 Unparsed (Expat, Entity, Base, Sysid, Pubid, Notation) This is called for a declaration of an unparsed entity. Entity is the name of the entity. Base is the base to be used for resolving a relative URI. Sysid is the system id. Pubid is the public id. Notation is the notation name. Base and Pubid may be undefined. =head2 Notation (Expat, Notation, Base, Sysid, Pubid) This is called for a declaration of notation. Notation is the notation name. Base is the base to be used for resolving a relative URI. Sysid is the system id. Pubid is the public id. Base, Sysid, and Pubid may all be undefined. =head2 ExternEnt (Expat, Base, Sysid, Pubid) This is called when an external entity is referenced. Base is the base to be used for resolving a relative URI. Sysid is the system id. Pubid is the public id. Base, and Pubid may be undefined. This handler should either return a string, which represents the contents of the external entity, or return an open filehandle that can be read to obtain the contents of the external entity, or return undef, which indicates the external entity couldn't be found and will generate a parse error. If an open filehandle is returned, it must be returned as either a glob (*FOO) or as a reference to a glob (e.g. an instance of IO::Handle). A default handler is installed for this event. The default handler is XML::Parser::lwp_ext_ent_handler unless the NoLWP option was provided with a true value, otherwise XML::Parser::file_ext_ent_handler is the default handler for external entities. Even without the NoLWP option, if the URI or LWP modules are missing, the file based handler ends up being used after giving a warning on the first external entity reference. The LWP external entity handler will use proxies defined in the environment (http_proxy, ftp_proxy, etc.). Please note that the LWP external entity handler reads the entire entity into a string and returns it, where as the file handler opens a filehandle. Also note that the file external entity handler will likely choke on absolute URIs or file names that don't fit the conventions of the local operating system. The expat base method can be used to set a basename for relative pathnames. If no basename is given, or if the basename is itself a relative name, then it is relative to the current working directory. =head2 ExternEntFin (Expat) This is called after parsing an external entity. It's not called unless an ExternEnt handler is also set. There is a default handler installed that pairs with the default ExternEnt handler. If you're going to install your own ExternEnt handler, then you should set (or unset) this handler too. =head2 Entity (Expat, Name, Val, Sysid, Pubid, Ndata, IsParam) This is called when an entity is declared. For internal entities, the Val parameter will contain the value and the remaining three parameters will be undefined. For external entities, the Val parameter will be undefined, the Sysid parameter will have the system id, the Pubid parameter will have the public id if it was provided (it will be undefined otherwise), the Ndata parameter will contain the notation for unparsed entities. If this is a parameter entity declaration, then the IsParam parameter is true. Note that this handler and the Unparsed handler above overlap. If both are set, then this handler will not be called for unparsed entities. =head2 Element (Expat, Name, Model) The element handler is called when an element declaration is found. Name is the element name, and Model is the content model as an XML::Parser::Content object. See L<XML::Parser::Expat/"XML::Parser::ContentModel Methods"> for methods available for this class. =head2 Attlist (Expat, Elname, Attname, Type, Default, Fixed) This handler is called for each attribute in an ATTLIST declaration. So an ATTLIST declaration that has multiple attributes will generate multiple calls to this handler. The Elname parameter is the name of the element with which the attribute is being associated. The Attname parameter is the name of the attribute. Type is the attribute type, given as a string. Default is the default value, which will either be "#REQUIRED", "#IMPLIED" or a quoted string (i.e. the returned string will begin and end with a quote character). If Fixed is true, then this is a fixed attribute. =head2 Doctype (Expat, Name, Sysid, Pubid, Internal) This handler is called for DOCTYPE declarations. Name is the document type name. Sysid is the system id of the document type, if it was provided, otherwise it's undefined. Pubid is the public id of the document type, which will be undefined if no public id was given. Internal is the internal subset, given as a string. If there was no internal subset, it will be undefined. Internal will contain all whitespace, comments, processing instructions, and declarations seen in the internal subset. The declarations will be there whether or not they have been processed by another handler (except for unparsed entities processed by the Unparsed handler). However, comments and processing instructions will not appear if they've been processed by their respective handlers. =head2 * DoctypeFin (Parser) This handler is called after parsing of the DOCTYPE declaration has finished, including any internal or external DTD declarations. =head2 XMLDecl (Expat, Version, Encoding, Standalone) This handler is called for xml declarations. Version is a string containing the version. Encoding is either undefined or contains an encoding string. Standalone will be either true, false, or undefined if the standalone attribute is yes, no, or not made respectively. =head1 STYLES =head2 Debug This just prints out the document in outline form. Nothing special is returned by parse. =head2 Subs Each time an element starts, a sub by that name in the package specified by the Pkg option is called with the same parameters that the Start handler gets called with. Each time an element ends, a sub with that name appended with an underscore ("_"), is called with the same parameters that the End handler gets called with. Nothing special is returned by parse. =head2 Tree Parse will return a parse tree for the document. Each node in the tree takes the form of a tag, content pair. Text nodes are represented with a pseudo-tag of "0" and the string that is their content. For elements, the content is an array reference. The first item in the array is a (possibly empty) hash reference containing attributes. The remainder of the array is a sequence of tag-content pairs representing the content of the element. So for example the result of parsing: <foo><head id="a">Hello <em>there</em></head><bar>Howdy<ref/></bar>do</foo> would be: Tag Content ================================================================== [foo, [{}, head, [{id => "a"}, 0, "Hello ", em, [{}, 0, "there"]], bar, [ {}, 0, "Howdy", ref, [{}]], 0, "do" ] ] The root document "foo", has 3 children: a "head" element, a "bar" element and the text "do". After the empty attribute hash, these are represented in it's contents by 3 tag-content pairs. =head2 Objects This is similar to the Tree style, except that a hash object is created for each element. The corresponding object will be in the class whose name is created by appending "::" and the element name to the package set with the Pkg option. Non-markup text will be in the ::Characters class. The contents of the corresponding object will be in an anonymous array that is the value of the Kids property for that object. =head2 Stream This style also uses the Pkg package. If none of the subs that this style looks for is there, then the effect of parsing with this style is to print a canonical copy of the document without comments or declarations. All the subs receive as their 1st parameter the Expat instance for the document they're parsing. It looks for the following routines: =over 4 =item * StartDocument Called at the start of the parse . =item * StartTag Called for every start tag with a second parameter of the element type. The $_ variable will contain a copy of the tag and the %_ variable will contain attribute values supplied for that element. =item * EndTag Called for every end tag with a second parameter of the element type. The $_ variable will contain a copy of the end tag. =item * Text Called just before start or end tags with accumulated non-markup text in the $_ variable. =item * PI Called for processing instructions. The $_ variable will contain a copy of the PI and the target and data are sent as 2nd and 3rd parameters respectively. =item * EndDocument Called at conclusion of the parse. =back =head1 ENCODINGS XML documents may be encoded in character sets other than Unicode as long as they may be mapped into the Unicode character set. Expat has further restrictions on encodings. Read the xmlparse.h header file in the expat distribution to see details on these restrictions. Expat has built-in encodings for: C<UTF-8>, C<ISO-8859-1>, C<UTF-16>, and C<US-ASCII>. Encodings are set either through the XML declaration encoding attribute or through the ProtocolEncoding option to XML::Parser or XML::Parser::Expat. For encodings other than the built-ins, expat calls the function load_encoding in the Expat package with the encoding name. This function looks for a file in the path list @XML::Parser::Expat::Encoding_Path, that matches the lower-cased name with a '.enc' extension. The first one it finds, it loads. If you wish to build your own encoding maps, check out the XML::Encoding module from CPAN. =head1 AUTHORS Larry Wall <F<larry@wall.org>> wrote version 1.0. Clark Cooper <F<coopercc@netheaven.com>> picked up support, changed the API for this version (2.x), provided documentation, and added some standard package features. Matt Sergeant <F<matt@sergeant.org>> is now maintaining XML::Parser =cut usr/local/lib64/perl5/Template/Parser.pm 0000444 00000117234 14711271737 0014003 0 ustar 00 #============================================================= -*-Perl-*- # # Template::Parser # # DESCRIPTION # This module implements a LALR(1) parser and associated support # methods to parse template documents into the appropriate "compiled" # format. Much of the parser DFA code (see _parse() method) is based # on Francois Desarmenien's Parse::Yapp module. Kudos to him. # # AUTHOR # Andy Wardley <abw@wardley.org> # # COPYRIGHT # Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. # # This module is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # # The following copyright notice appears in the Parse::Yapp # documentation. # # The Parse::Yapp module and its related modules and shell # scripts are copyright (c) 1998 Francois Desarmenien, # France. All rights reserved. # # You may use and distribute them under the terms of either # the GNU General Public License or the Artistic License, as # specified in the Perl README file. # #============================================================================ package Template::Parser; use strict; use warnings; use base 'Template::Base'; use Template::Constants qw( :status :chomp ); use Template::Directive; use Template::Grammar; # parser state constants use constant CONTINUE => 0; use constant ACCEPT => 1; use constant ERROR => 2; use constant ABORT => 3; our $VERSION = '3.100'; our $DEBUG = 0 unless defined $DEBUG; our $ERROR = ''; # The ANYCASE option can cause conflicts when reserved words are used as # variable names, hash keys, template names, plugin names, etc. The # # $ANYCASE_BEFORE regex identifies where such a word precedes an assignment, # either as a variable (C<wrapper = 'html'>) or hash key (C<{ wrapper => 'html' }). # In that case it is treated as a simple words rather than being the lower case # equivalent of the upper case keyword (e.g. WRAPPER). # # $ANYCASE_AFTER is used to identify when such a word follows a symbols that # suggests it can't be a keyword, e.g. after BLOCK INCLUDE WRAPPER, USE, etc. our $ANYCASE_BEFORE = qr/\G((?=\s*[=\.]))/; our $ANYCASE_AFTER = { map { $_ => 1 } qw( GET SET CALL DEFAULT INSERT INCLUDE PROCESS WRAPPER BLOCK USE PLUGIN FILTER MACRO IN TO STEP AND OR NOT DIV MOD DOT IF UNLESS ELSIF FOR WHILE SWITCH CASE META THROW CATCH VIEW CMPOP BINOP COMMA ), '(', '[', '{' # not sure about ASSIGN as it breaks C<header_html = include header> }; #======================================================================== # -- COMMON TAG STYLES -- #======================================================================== our $TAG_STYLE = { 'outline' => [ '\[%', '%\]', '%%' ], # NEW! Outline tag 'default' => [ '\[%', '%\]' ], 'template1' => [ '[\[%]%', '%[\]%]' ], 'metatext' => [ '%%', '%%' ], 'html' => [ '<!--', '-->' ], 'mason' => [ '<%', '>' ], 'asp' => [ '<%', '%>' ], 'php' => [ '<\?', '\?>' ], 'star' => [ '\[\*', '\*\]' ], }; $TAG_STYLE->{ template } = $TAG_STYLE->{ tt2 } = $TAG_STYLE->{ default }; our $DEFAULT_STYLE = { START_TAG => $TAG_STYLE->{ default }->[0], END_TAG => $TAG_STYLE->{ default }->[1], OUTLINE_TAG => $TAG_STYLE->{ default }->[2], # TAG_STYLE => 'default', ANYCASE => 0, INTERPOLATE => 0, PRE_CHOMP => 0, POST_CHOMP => 0, V1DOLLAR => 0, EVAL_PERL => 0, }; our $QUOTED_ESCAPES = { n => "\n", r => "\r", t => "\t", }; # note that '-' must come first so Perl doesn't think it denotes a range our $CHOMP_FLAGS = qr/[-=~+]/; #======================================================================== # ----- PUBLIC METHODS ----- #======================================================================== #------------------------------------------------------------------------ # new(\%config) # # Constructor method. #------------------------------------------------------------------------ sub new { my $class = shift; my $config = $_[0] && ref($_[0]) eq 'HASH' ? shift(@_) : { @_ }; my ($tagstyle, $debug, $start, $end, $defaults, $grammar, $hash, $key, $udef); my $self = bless { START_TAG => undef, END_TAG => undef, OUTLINE_TAG => undef, TAG_STYLE => 'default', ANYCASE => 0, INTERPOLATE => 0, PRE_CHOMP => 0, POST_CHOMP => 0, V1DOLLAR => 0, EVAL_PERL => 0, FILE_INFO => 1, GRAMMAR => undef, _ERROR => '', IN_BLOCK => [ ], TRACE_VARS => $config->{ TRACE_VARS }, FACTORY => $config->{ FACTORY } || 'Template::Directive', }, $class; # update self with any relevant keys in config foreach $key (keys %$self) { $self->{ $key } = $config->{ $key } if defined $config->{ $key }; } $self->{ FILEINFO } = [ ]; # DEBUG config item can be a bitmask if (defined ($debug = $config->{ DEBUG })) { $self->{ DEBUG } = $debug & ( Template::Constants::DEBUG_PARSER | Template::Constants::DEBUG_FLAGS ); $self->{ DEBUG_DIRS } = $debug & Template::Constants::DEBUG_DIRS; } # package variable can be set to 1 to support previous behaviour elsif ($DEBUG == 1) { $self->{ DEBUG } = Template::Constants::DEBUG_PARSER; $self->{ DEBUG_DIRS } = 0; } # otherwise let $DEBUG be a bitmask else { $self->{ DEBUG } = $DEBUG & ( Template::Constants::DEBUG_PARSER | Template::Constants::DEBUG_FLAGS ); $self->{ DEBUG_DIRS } = $DEBUG & Template::Constants::DEBUG_DIRS; } $grammar = $self->{ GRAMMAR } ||= do { require Template::Grammar; Template::Grammar->new(); }; # instantiate a FACTORY object unless (ref $self->{ FACTORY }) { my $fclass = $self->{ FACTORY }; $self->{ FACTORY } = $self->{ FACTORY }->new( NAMESPACE => $config->{ NAMESPACE } ) || return $class->error($self->{ FACTORY }->error()); } # load grammar rules, states and lex table @$self{ qw( LEXTABLE STATES RULES ) } = @$grammar{ qw( LEXTABLE STATES RULES ) }; $self->new_style($config) || return $class->error($self->error()); return $self; } #----------------------------------------------------------------------- # These methods are used to track nested IF and WHILE blocks. Each # generated if/while block is given a label indicating the directive # type and nesting depth, e.g. FOR0, WHILE1, FOR2, WHILE3, etc. The # NEXT and LAST directives use the innermost label, e.g. last WHILE3; #----------------------------------------------------------------------- sub enter_block { my ($self, $name) = @_; my $blocks = $self->{ IN_BLOCK }; push(@{ $self->{ IN_BLOCK } }, $name); } sub leave_block { my $self = shift; my $label = $self->block_label; pop(@{ $self->{ IN_BLOCK } }); return $label; } sub in_block { my ($self, $name) = @_; my $blocks = $self->{ IN_BLOCK }; return @$blocks && $blocks->[-1] eq $name; } sub block_label { my ($self, $prefix, $suffix) = @_; my $blocks = $self->{ IN_BLOCK }; my $name = @$blocks ? $blocks->[-1] . scalar @$blocks : undef; return join('', grep { defined $_ } $prefix, $name, $suffix); } #------------------------------------------------------------------------ # new_style(\%config) # # Install a new (stacked) parser style. This feature is currently # experimental but should mimic the previous behaviour with regard to # TAG_STYLE, START_TAG, END_TAG, etc. #------------------------------------------------------------------------ sub new_style { my ($self, $config) = @_; my $styles = $self->{ STYLE } ||= [ ]; my ($tagstyle, $tags, $start, $end, $out, $key); # clone new style from previous or default style my $style = { %{ $styles->[-1] || $DEFAULT_STYLE } }; # expand START_TAG and END_TAG from specified TAG_STYLE if ($tagstyle = $config->{ TAG_STYLE }) { return $self->error("Invalid tag style: $tagstyle") unless defined ($tags = $TAG_STYLE->{ $tagstyle }); ($start, $end, $out) = @$tags; $config->{ START_TAG } ||= $start; $config->{ END_TAG } ||= $end; $config->{ OUTLINE_TAG } ||= $out; } foreach $key (keys %$DEFAULT_STYLE) { $style->{ $key } = $config->{ $key } if defined $config->{ $key }; } $start = $style->{ START_TAG }; $end = $style->{ END_TAG }; $out = $style->{ OUTLINE_TAG }; $style->{ TEXT_SPLIT } = $self->text_splitter($start, $end, $out); push(@$styles, $style); return $style; } sub text_splitter { my ($self, $start, $end, $out) = @_; if (defined $out) { return qr/ \A(.*?) # $1 - start of line up to directive (?: (?: ^$out # outline tag at start of line (.*?) # $2 - content of that line (?:\n|$) # end of that line or file ) | (?: $start # start of tag (.*?) # $3 - tag contents $end # end of tag ) ) /msx; } else { return qr/ ^(.*?) # $1 - start of line up to directive (?: $start # start of tag (.*?) # $2 - tag contents $end # end of tag ) /sx; } } #------------------------------------------------------------------------ # old_style() # # Pop the current parser style and revert to the previous one. See # new_style(). ** experimental ** #------------------------------------------------------------------------ sub old_style { my $self = shift; my $styles = $self->{ STYLE }; return $self->error('only 1 parser style remaining') unless (@$styles > 1); pop @$styles; return $styles->[-1]; } #------------------------------------------------------------------------ # parse($text, $data) # # Parses the text string, $text and returns a hash array representing # the compiled template block(s) as Perl code, in the format expected # by Template::Document. #------------------------------------------------------------------------ sub parse { my ($self, $text, $info) = @_; my ($tokens, $block); $info->{ DEBUG } = $self->{ DEBUG_DIRS } unless defined $info->{ DEBUG }; # print "info: { ", join(', ', map { "$_ => $info->{ $_ }" } keys %$info), " }\n"; # store for blocks defined in the template (see define_block()) my $defblock = $self->{ DEFBLOCK } = { }; my $metadata = $self->{ METADATA } = [ ]; my $variables = $self->{ VARIABLES } = { }; $self->{ DEFBLOCKS } = [ ]; $self->{ _ERROR } = ''; # split file into TEXT/DIRECTIVE chunks $tokens = $self->split_text($text) || return undef; ## RETURN ## push(@{ $self->{ FILEINFO } }, $info); # parse chunks $block = $self->_parse($tokens, $info); pop(@{ $self->{ FILEINFO } }); return undef unless $block; ## RETURN ## $self->debug("compiled main template document block:\n$block") if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; return { BLOCK => $block, DEFBLOCKS => $defblock, VARIABLES => $variables, METADATA => { @$metadata }, }; } #------------------------------------------------------------------------ # split_text($text) # # Split input template text into directives and raw text chunks. #------------------------------------------------------------------------ sub split_text { my ($self, $text) = @_; my ($pre, $dir, $prelines, $dirlines, $postlines, $chomp, $tags, @tags); my $style = $self->{ STYLE }->[-1]; my ($start, $end, $out, $prechomp, $postchomp, $interp ) = @$style{ qw( START_TAG END_TAG OUTLINE_TAG PRE_CHOMP POST_CHOMP INTERPOLATE ) }; my $tags_dir = $self->{ANYCASE} ? qr<TAGS>i : qr<TAGS>; my $split = $style->{ TEXT_SPLIT }; my $has_out = defined $out; my @tokens = (); my $line = 1; return \@tokens ## RETURN ## unless defined $text && length $text; # extract all directives from the text while ($text =~ s/$split//) { $pre = $1; $dir = defined($2) ? $2 : $3; $pre = '' unless defined $pre; $dir = '' unless defined $dir; $prelines = ($pre =~ tr/\n//); # newlines in preceding text $dirlines = ($dir =~ tr/\n//); # newlines in directive tag $postlines = 0; # newlines chomped after tag for ($dir) { if (/^\#/) { # comment out entire directive except for any end chomp flag $dir = ($dir =~ /($CHOMP_FLAGS)$/o) ? $1 : ''; } else { if(s/^($CHOMP_FLAGS)?(\s*)//so && $2) { my $chomped = $2; my $linecount = ($chomped =~ tr/\n//); # newlines in chomped whitespace $linecount ||= 0; $prelines += $linecount; $dirlines -= $linecount; } # PRE_CHOMP: process whitespace before tag $chomp = $1 ? $1 : $prechomp; $chomp =~ tr/-=~+/1230/; if ($chomp && $pre) { # chomp off whitespace and newline preceding directive if ($chomp == CHOMP_ALL) { $pre =~ s{ (\r?\n|^) [^\S\n]* \z }{}mx; } elsif ($chomp == CHOMP_COLLAPSE) { $pre =~ s{ (\s+) \z }{ }x; } elsif ($chomp == CHOMP_GREEDY) { $pre =~ s{ (\s+) \z }{}x; } } } # POST_CHOMP: process whitespace after tag s/\s*($CHOMP_FLAGS)?\s*$//so; $chomp = $1 ? $1 : $postchomp; $chomp =~ tr/-=~+/1230/; if ($chomp) { if ($chomp == CHOMP_ALL) { $text =~ s{ ^ ([^\S\n]* \n) }{}x && $postlines++; } elsif ($chomp == CHOMP_COLLAPSE) { $text =~ s{ ^ (\s+) }{ }x && ($postlines += $1=~y/\n//); } # any trailing whitespace elsif ($chomp == CHOMP_GREEDY) { $text =~ s{ ^ (\s+) }{}x && ($postlines += $1=~y/\n//); } } } # any text preceding the directive can now be added if (length $pre) { push(@tokens, $interp ? [ $pre, $line, 'ITEXT' ] : ('TEXT', $pre) ); } $line += $prelines; # and now the directive, along with line number information if (length $dir) { # the TAGS directive is a compile-time switch if ($dir =~ /^$tags_dir\s+(.*)/) { my @tags = split(/\s+/, $1); if (scalar @tags > 1) { ($start, $end, $out) = map { quotemeta($_) } @tags; $split = $self->text_splitter($start, $end, $out); } elsif ($tags = $TAG_STYLE->{ $tags[0] }) { ($start, $end, $out) = @$tags; $split = $self->text_splitter($start, $end, $out); } else { warn "invalid TAGS style: $tags[0]\n"; } } else { # DIRECTIVE is pushed as: # [ $dirtext, $line_no(s), \@tokens ] push(@tokens, [ $dir, ($dirlines ? sprintf("%d-%d", $line, $line + $dirlines) : $line), $self->tokenise_directive($dir) ]); } } # update line counter to include directive lines and any extra # newline chomped off the start of the following text $line += $dirlines + $postlines; } # anything remaining in the string is plain text push(@tokens, $interp ? [ $text, $line, 'ITEXT' ] : ( 'TEXT', $text) ) if length $text; return \@tokens; ## RETURN ## } #------------------------------------------------------------------------ # interpolate_text($text, $line) # # Examines $text looking for any variable references embedded like # $this or like ${ this }. #------------------------------------------------------------------------ sub interpolate_text { my ($self, $text, $line) = @_; my @tokens = (); my ($pre, $var, $dir); while ($text =~ / ( (?: \\. | [^\$] ){1,3000} ) # escaped or non-'$' character [$1] | ( \$ (?: # embedded variable [$2] (?: \{ ([^\}]*) \} ) # ${ ... } [$3] | ([\w\.]+) # $word [$4] ) ) /gx) { ($pre, $var, $dir) = ($1, $3 || $4, $2); # preceding text if (defined($pre) && length($pre)) { $line += $pre =~ tr/\n//; $pre =~ s/\\\$/\$/g; push(@tokens, 'TEXT', $pre); } # $variable reference if ($var) { $line += $dir =~ tr/\n/ /; push(@tokens, [ $dir, $line, $self->tokenise_directive($var) ]); } # other '$' reference - treated as text elsif ($dir) { $line += $dir =~ tr/\n//; push(@tokens, 'TEXT', $dir); } } return \@tokens; } #------------------------------------------------------------------------ # tokenise_directive($text) # # Called by the private _parse() method when it encounters a DIRECTIVE # token in the list provided by the split_text() or interpolate_text() # methods. The directive text is passed by parameter. # # The method splits the directive into individual tokens as recognised # by the parser grammar (see Template::Grammar for details). It # constructs a list of tokens each represented by 2 elements, as per # split_text() et al. The first element contains the token type, the # second the token itself. # # The method tokenises the string using a complex (but fast) regex. # For a deeper understanding of the regex magic at work here, see # Jeffrey Friedl's excellent book "Mastering Regular Expressions", # from O'Reilly, ISBN 1-56592-257-3 # # Returns a reference to the list of chunks (each one being 2 elements) # identified in the directive text. On error, the internal _ERROR string # is set and undef is returned. #------------------------------------------------------------------------ sub tokenise_directive { my ($self, $text, $line) = @_; my ($token, $uctoken, $type, $lookup); my $lextable = $self->{ LEXTABLE }; my $style = $self->{ STYLE }->[-1]; my ($anycase, $start, $end) = @$style{ qw( ANYCASE START_TAG END_TAG ) }; my @tokens = ( ); while ($text =~ / # strip out any comments (\#[^\n]*) | # a quoted phrase matches in $3 (["']) # $2 - opening quote, ' or " ( # $3 - quoted text buffer (?: # repeat group (no backreference) \\\\ # an escaped backslash \\ | # ...or... \\\2 # an escaped quote \" or \' (match $1) | # ...or... . # any other character | \n )*? # non-greedy repeat ) # end of $3 \2 # match opening quote | # an unquoted number matches in $4 (-?\d+(?:\.\d+)?) # numbers | # filename matches in $5 ( \/?\w+(?:(?:\/|::?)\w*)+ | \/\w+) | # an identifier matches in $6 (\w+) # variable identifier | # an unquoted word or symbol matches in $7 ( [(){}\[\]:;,\/\\] # misc parenthesis and symbols # | \-> # arrow operator (for future?) | [+\-*] # math operations | \$\{? # dollar with option left brace | => # like '=' | [=!<>]?= | [!<>] # eqality tests | &&? | \|\|? # boolean ops | \.\.? # n..n sequence | \S+ # something unquoted ) # end of $7 /gmxo) { # ignore comments to EOL next if $1; # quoted string if (defined ($token = $3)) { # double-quoted string may include $variable references if ($2 eq '"') { if ($token =~ /[\$\\]/) { $type = 'QUOTED'; # unescape " and \ but leave \$ escaped so that # interpolate_text() doesn't incorrectly treat it # as a variable reference # $token =~ s/\\([\\"])/$1/g; for ($token) { s/\\([^\$nrt])/$1/g; s/\\([nrt])/$QUOTED_ESCAPES->{ $1 }/ge; } push(@tokens, ('"') x 2, @{ $self->interpolate_text($token) }, ('"') x 2); next; } else { $type = 'LITERAL'; $token =~ s['][\\']g; $token = "'$token'"; } } else { $type = 'LITERAL'; $token = "'$token'"; } } # number elsif (defined ($token = $4)) { $type = 'NUMBER'; } elsif (defined($token = $5)) { $type = 'FILENAME'; } elsif (defined($token = $6)) { # Fold potential keywords to UPPER CASE if the ANYCASE option is # set, unless (we've got some preceding tokens and) the previous # token is a DOT op. This prevents the 'last' in 'data.last' # from being interpreted as the LAST keyword. if ($anycase) { # if the token follows a dot or precedes an assignment then # it's not for folding, e.g. the 'wrapper' in this: # [% page = { wrapper='html' }; page.wrapper %] if ((@tokens && $ANYCASE_AFTER->{ $tokens[-2] }) || ($text =~ /$ANYCASE_BEFORE/gc)) { # keep the token unmodified $uctoken = $token; } else { $uctoken = uc $token; } } else { $uctoken = $token; } if (defined ($type = $lextable->{ $uctoken })) { $token = $uctoken; } else { $type = 'IDENT'; } } elsif (defined ($token = $7)) { # reserved words may be in lower case unless case sensitive $uctoken = $anycase ? uc $token : $token; unless (defined ($type = $lextable->{ $uctoken })) { $type = 'UNQUOTED'; } } push(@tokens, $type, $token); # print(STDERR " +[ $type, $token ]\n") # if $DEBUG; } # print STDERR "tokenise directive() returning:\n [ @tokens ]\n" # if $DEBUG; return \@tokens; ## RETURN ## } #------------------------------------------------------------------------ # define_block($name, $block) # # Called by the parser 'defblock' rule when a BLOCK definition is # encountered in the template. The name of the block is passed in the # first parameter and a reference to the compiled block is passed in # the second. This method stores the block in the $self->{ DEFBLOCK } # hash which has been initialised by parse() and will later be used # by the same method to call the store() method on the calling cache # to define the block "externally". #------------------------------------------------------------------------ sub define_block { my ($self, $name, $block) = @_; my $defblock = $self->{ DEFBLOCK } || return undef; $self->debug("compiled block '$name':\n$block") if $self->{ DEBUG } & Template::Constants::DEBUG_PARSER; warn "Block redefined: $name\n" if exists $defblock->{ $name }; $defblock->{ $name } = $block; return undef; } sub push_defblock { my $self = shift; my $stack = $self->{ DEFBLOCK_STACK } ||= []; push(@$stack, $self->{ DEFBLOCK } ); $self->{ DEFBLOCK } = { }; } sub pop_defblock { my $self = shift; my $defs = $self->{ DEFBLOCK }; my $stack = $self->{ DEFBLOCK_STACK } || return $defs; return $defs unless @$stack; $self->{ DEFBLOCK } = pop @$stack; return $defs; } #------------------------------------------------------------------------ # add_metadata(\@setlist) #------------------------------------------------------------------------ sub add_metadata { my ($self, $setlist) = @_; my $metadata = $self->{ METADATA } || return undef; push(@$metadata, @$setlist); return undef; } #------------------------------------------------------------------------ # location() # # Return Perl comment indicating current parser file and line #------------------------------------------------------------------------ sub location { my $self = shift; return "\n" unless $self->{ FILE_INFO }; my $line = ${ $self->{ LINE } }; my $info = $self->{ FILEINFO }->[-1]; my $file = $info->{ path } || $info->{ name } || '(unknown template)'; $line =~ s/\-.*$//; # might be 'n-n' $line ||= 1; return "#line $line \"$file\"\n"; } #======================================================================== # ----- PRIVATE METHODS ----- #======================================================================== #------------------------------------------------------------------------ # _parse(\@tokens, \@info) # # Parses the list of input tokens passed by reference and returns a # Template::Directive::Block object which contains the compiled # representation of the template. # # This is the main parser DFA loop. See embedded comments for # further details. # # On error, undef is returned and the internal _ERROR field is set to # indicate the error. This can be retrieved by calling the error() # method. #------------------------------------------------------------------------ sub _parse { my ($self, $tokens, $info) = @_; my ($token, $value, $text, $line, $inperl); my ($state, $stateno, $status, $action, $lookup, $coderet, @codevars); my ($lhs, $len, $code); # rule contents my $stack = [ [ 0, undef ] ]; # DFA stack # DEBUG # local $" = ', '; # retrieve internal rule and state tables my ($states, $rules) = @$self{ qw( STATES RULES ) }; # If we're tracing variable usage then we need to give the factory a # reference to our $self->{ VARIABLES } for it to fill in. This is a # bit of a hack to back-patch this functionality into TT2. $self->{ FACTORY }->trace_vars($self->{ VARIABLES }) if $self->{ TRACE_VARS }; # call the grammar set_factory method to install emitter factory $self->{ GRAMMAR }->install_factory($self->{ FACTORY }); $line = $inperl = 0; $self->{ LINE } = \$line; $self->{ FILE } = $info->{ name }; $self->{ INPERL } = \$inperl; $status = CONTINUE; my $in_string = 0; while(1) { # get state number and state $stateno = $stack->[-1]->[0]; $state = $states->[$stateno]; # see if any lookaheads exist for the current state if (exists $state->{'ACTIONS'}) { # get next token and expand any directives (i.e. token is an # array ref) onto the front of the token list while (! defined $token && @$tokens) { $token = shift(@$tokens); if (ref $token) { ($text, $line, $token) = @$token; if (ref $token) { if ($info->{ DEBUG } && ! $in_string) { # - - - - - - - - - - - - - - - - - - - - - - - - - # This is gnarly. Look away now if you're easily # frightened. We're pushing parse tokens onto the # pending list to simulate a DEBUG directive like so: # [% DEBUG msg line='20' text='INCLUDE foo' %] # - - - - - - - - - - - - - - - - - - - - - - - - - my $dtext = $text; $dtext =~ s[(['\\])][\\$1]g; unshift(@$tokens, DEBUG => 'DEBUG', IDENT => 'msg', IDENT => 'line', ASSIGN => '=', LITERAL => "'$line'", IDENT => 'text', ASSIGN => '=', LITERAL => "'$dtext'", IDENT => 'file', ASSIGN => '=', LITERAL => "'$info->{ name }'", (';') x 2, @$token, (';') x 2); } else { unshift(@$tokens, @$token, (';') x 2); } $token = undef; # force redo } elsif ($token eq 'ITEXT') { if ($inperl) { # don't perform interpolation in PERL blocks $token = 'TEXT'; $value = $text; } else { unshift(@$tokens, @{ $self->interpolate_text($text, $line) }); $token = undef; # force redo } } } else { # toggle string flag to indicate if we're crossing # a string boundary $in_string = ! $in_string if $token eq '"'; $value = shift(@$tokens); } }; # clear undefined token to avoid 'undefined variable blah blah' # warnings and let the parser logic pick it up in a minute $token = '' unless defined $token; # get the next state for the current lookahead token $action = defined ($lookup = $state->{'ACTIONS'}->{ $token }) ? $lookup : defined ($lookup = $state->{'DEFAULT'}) ? $lookup : undef; } else { # no lookahead actions $action = $state->{'DEFAULT'}; } # ERROR: no ACTION last unless defined $action; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - # shift (+ive ACTION) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - if ($action > 0) { push(@$stack, [ $action, $value ]); $token = $value = undef; redo; }; # - - - - - - - - - - - - - - - - - - - - - - - - - - - - # reduce (-ive ACTION) # - - - - - - - - - - - - - - - - - - - - - - - - - - - - ($lhs, $len, $code) = @{ $rules->[ -$action ] }; # no action imples ACCEPTance $action or $status = ACCEPT; # use dummy sub if code ref doesn't exist if ( !$code ) { $coderet = $len ? $stack->[ -$len ]->[1] : undef; } else { # $code = sub { $_[1] } # unless $code; @codevars = $len ? map { $_->[1] } @$stack[ -$len .. -1 ] : (); eval { $coderet = &$code( $self, @codevars ); }; if ($@) { my $err = $@; chomp $err; return $self->_parse_error($err); } } # reduce stack by $len splice(@$stack, -$len, $len); # ACCEPT return $coderet ## RETURN ## if $status == ACCEPT; # ABORT return undef ## RETURN ## if $status == ABORT; # ERROR last if $status == ERROR; } continue { push(@$stack, [ $states->[ $stack->[-1][0] ]->{'GOTOS'}->{ $lhs }, $coderet ]), } # ERROR ## RETURN ## return $self->_parse_error('unexpected end of input') unless defined $value; # munge text of last directive to make it readable # $text =~ s/\n/\\n/g; return $self->_parse_error("unexpected end of directive", $text) if $value eq ';'; # end of directive SEPARATOR return $self->_parse_error("unexpected token ($value)", $text); } #------------------------------------------------------------------------ # _parse_error($msg, $dirtext) # # Method used to handle errors encountered during the parse process # in the _parse() method. #------------------------------------------------------------------------ sub _parse_error { my ($self, $msg, $text) = @_; my $line = $self->{ LINE }; $line = ref($line) ? $$line : $line; $line = 'unknown' unless $line; $msg .= "\n [% $text %]" if defined $text; return $self->error("line $line: $msg"); } 1; __END__ =head1 NAME Template::Parser - LALR(1) parser for compiling template documents =head1 SYNOPSIS use Template::Parser; $parser = Template::Parser->new(\%config); $template = $parser->parse($text) || die $parser->error(), "\n"; =head1 DESCRIPTION The C<Template::Parser> module implements a LALR(1) parser and associated methods for parsing template documents into Perl code. =head1 PUBLIC METHODS =head2 new(\%params) The C<new()> constructor creates and returns a reference to a new C<Template::Parser> object. A reference to a hash may be supplied as a parameter to provide configuration values. See L<CONFIGURATION OPTIONS> below for a summary of these options and L<Template::Manual::Config> for full details. my $parser = Template::Parser->new({ START_TAG => quotemeta('<+'), END_TAG => quotemeta('+>'), }); =head2 parse($text) The C<parse()> method parses the text passed in the first parameter and returns a reference to a hash array of data defining the compiled representation of the template text, suitable for passing to the L<Template::Document> L<new()|Template::Document#new()> constructor method. On error, undef is returned. $data = $parser->parse($text) || die $parser->error(); The C<$data> hash reference returned contains a C<BLOCK> item containing the compiled Perl code for the template, a C<DEFBLOCKS> item containing a reference to a hash array of sub-template C<BLOCK>s defined within in the template, and a C<METADATA> item containing a reference to a hash array of metadata values defined in C<META> tags. =head1 CONFIGURATION OPTIONS The C<Template::Parser> module accepts the following configuration options. Please see L<Template::Manual::Config> for further details on each option. =head2 START_TAG, END_TAG The L<START_TAG|Template::Manual::Config#START_TAG_END_TAG> and L<END_TAG|Template::Manual::Config#START_TAG_END_TAG> options are used to specify character sequences or regular expressions that mark the start and end of a template directive. my $parser = Template::Parser->new({ START_TAG => quotemeta('<+'), END_TAG => quotemeta('+>'), }); =head2 TAG_STYLE The L<TAG_STYLE|Template::Manual::Config#TAG_STYLE> option can be used to set both L<START_TAG> and L<END_TAG> according to pre-defined tag styles. my $parser = Template::Parser->new({ TAG_STYLE => 'star', # [* ... *] }); =head2 PRE_CHOMP, POST_CHOMP The L<PRE_CHOMP|Template::Manual::Config#PRE_CHOMP_POST_CHOMP> and L<POST_CHOMP|Template::Manual::Config#PRE_CHOMP_POST_CHOMP> can be set to remove any whitespace before or after a directive tag, respectively. my $parser = Template::Parser-E<gt>new({ PRE_CHOMP => 1, POST_CHOMP => 1, }); =head2 INTERPOLATE The L<INTERPOLATE|Template::Manual::Config#INTERPOLATE> flag can be set to allow variables to be embedded in plain text blocks. my $parser = Template::Parser->new({ INTERPOLATE => 1, }); Variables should be prefixed by a C<$> to identify them, using curly braces to explicitly scope the variable name where necessary. Hello ${name}, The day today is ${day.today}. =head2 ANYCASE The L<ANYCASE|Template::Manual::Config#ANYCASE> option can be set to allow directive keywords to be specified in any case. # with ANYCASE set to 1 [% INCLUDE foobar %] # OK [% include foobar %] # OK [% include = 10 %] # ERROR, 'include' is a reserved word =head2 GRAMMAR The L<GRAMMAR|Template::Manual::Config#GRAMMAR> configuration item can be used to specify an alternate grammar for the parser. This allows a modified or entirely new template language to be constructed and used by the Template Toolkit. use MyOrg::Template::Grammar; my $parser = Template::Parser->new({ GRAMMAR = MyOrg::Template::Grammar->new(); }); By default, an instance of the default L<Template::Grammar> will be created and used automatically if a C<GRAMMAR> item isn't specified. =head2 DEBUG The L<DEBUG|Template::Manual::Config#DEBUG> option can be used to enable various debugging features of the C<Template::Parser> module. use Template::Constants qw( :debug ); my $template = Template->new({ DEBUG => DEBUG_PARSER | DEBUG_DIRS, }); =head1 AUTHOR Andy Wardley E<lt>abw@wardley.orgE<gt> L<http://wardley.org/> =head1 COPYRIGHT Copyright (C) 1996-2007 Andy Wardley. All Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. The main parsing loop of the C<Template::Parser> module was derived from a standalone parser generated by version 0.16 of the C<Parse::Yapp> module. The following copyright notice appears in the C<Parse::Yapp> documentation. The Parse::Yapp module and its related modules and shell scripts are copyright (c) 1998 Francois Desarmenien, France. All rights reserved. You may use and distribute them under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =head1 SEE ALSO L<Template>, L<Template::Grammar>, L<Template::Directive> usr/local/lib64/perl5/XML/LibXML/SAX/Parser.pm 0000444 00000017256 14711324630 0014404 0 ustar 00 # $Id$ # # This is free software, you may use it and distribute it under the same terms as # Perl itself. # # Copyright 2001-2003 AxKit.com Ltd., 2002-2006 Christian Glahn, 2006-2009 Petr Pajas # # package XML::LibXML::SAX::Parser; use strict; use warnings; use vars qw($VERSION @ISA); use XML::LibXML; use XML::LibXML::Common qw(:libxml); use XML::SAX::Base; use XML::SAX::DocumentLocator; $VERSION = "2.0210"; # VERSION TEMPLATE: DO NOT CHANGE @ISA = ('XML::SAX::Base'); sub CLONE_SKIP { return $XML::LibXML::__threads_shared ? 0 : 1; } sub _parse_characterstream { my ($self, $fh, $options) = @_; die "parsing a characterstream is not supported at this time"; } sub _parse_bytestream { my ($self, $fh, $options) = @_; my $parser = XML::LibXML->new(); my $doc = exists($options->{Source}{SystemId}) ? $parser->parse_fh($fh, $options->{Source}{SystemId}) : $parser->parse_fh($fh); $self->generate($doc); } sub _parse_string { my ($self, $str, $options) = @_; my $parser = XML::LibXML->new(); my $doc = exists($options->{Source}{SystemId}) ? $parser->parse_string($str, $options->{Source}{SystemId}) : $parser->parse_string($str); $self->generate($doc); } sub _parse_systemid { my ($self, $sysid, $options) = @_; my $parser = XML::LibXML->new(); my $doc = $parser->parse_file($sysid); $self->generate($doc); } sub generate { my $self = shift; my ($node) = @_; my $doc = $node->ownerDocument(); { # precompute some DocumentLocator values my %locator = ( PublicId => undef, SystemId => undef, Encoding => undef, XMLVersion => undef, ); my $dtd = defined $doc ? $doc->externalSubset() : undef; if (defined $dtd) { $locator{PublicId} = $dtd->publicId(); $locator{SystemId} = $dtd->systemId(); } if (defined $doc) { $locator{Encoding} = $doc->encoding(); $locator{XMLVersion} = $doc->version(); } $self->set_document_locator( XML::SAX::DocumentLocator->new( sub { $locator{PublicId} }, sub { $locator{SystemId} }, sub { defined($self->{current_node}) ? $self->{current_node}->line_number() : undef }, sub { 1 }, sub { $locator{Encoding} }, sub { $locator{XMLVersion} }, ), ); } if ( $node->nodeType() == XML_DOCUMENT_NODE || $node->nodeType == XML_HTML_DOCUMENT_NODE ) { $self->start_document({}); $self->xml_decl({Version => $node->getVersion, Encoding => $node->getEncoding}); $self->process_node($node); $self->end_document({}); } } sub process_node { my ($self, $node) = @_; local $self->{current_node} = $node; my $node_type = $node->nodeType(); if ($node_type == XML_COMMENT_NODE) { $self->comment( { Data => $node->getData } ); } elsif ($node_type == XML_TEXT_NODE || $node_type == XML_CDATA_SECTION_NODE) { # warn($node->getData . "\n"); $self->characters( { Data => $node->nodeValue } ); } elsif ($node_type == XML_ELEMENT_NODE) { # warn("<" . $node->getName . ">\n"); $self->process_element($node); # warn("</" . $node->getName . ">\n"); } elsif ($node_type == XML_ENTITY_REF_NODE) { foreach my $kid ($node->childNodes) { # warn("child of entity ref: " . $kid->getType() . " called: " . $kid->getName . "\n"); $self->process_node($kid); } } elsif ($node_type == XML_DOCUMENT_NODE || $node_type == XML_HTML_DOCUMENT_NODE || $node_type == XML_DOCUMENT_FRAG_NODE) { # sometimes it is just useful to generate SAX events from # a document fragment (very good with filters). foreach my $kid ($node->childNodes) { $self->process_node($kid); } } elsif ($node_type == XML_PI_NODE) { $self->processing_instruction( { Target => $node->getName, Data => $node->getData } ); } elsif ($node_type == XML_COMMENT_NODE) { $self->comment( { Data => $node->getData } ); } elsif ( $node_type == XML_XINCLUDE_START || $node_type == XML_XINCLUDE_END ) { # ignore! # i may want to handle this one day, dunno yet } elsif ($node_type == XML_DTD_NODE ) { # ignore! # i will support DTDs, but had no time yet. } else { # warn("unsupported node type: $node_type"); } } sub process_element { my ($self, $element) = @_; my $attribs = {}; my @ns_maps = $element->getNamespaces; foreach my $ns (@ns_maps) { $self->start_prefix_mapping( { NamespaceURI => $ns->href, Prefix => ( defined $ns->localname ? $ns->localname : ''), } ); } foreach my $attr ($element->attributes) { my $key; # warn("Attr: $attr -> ", $attr->getName, " = ", $attr->getData, "\n"); # this isa dump thing... if ($attr->isa('XML::LibXML::Namespace')) { # TODO This needs fixing modulo agreeing on what # is the right thing to do here. unless ( defined $attr->name ) { ## It's an atter like "xmlns='foo'" $attribs->{"{}xmlns"} = { Name => "xmlns", LocalName => "xmlns", Prefix => "", Value => $attr->href, NamespaceURI => "", }; } else { my $prefix = "xmlns"; my $localname = $attr->localname; my $key = "{http://www.w3.org/2000/xmlns/}"; my $name = "xmlns"; if ( defined $localname ) { $key .= $localname; $name.= ":".$localname; } $attribs->{$key} = { Name => $name, Value => $attr->href, NamespaceURI => "http://www.w3.org/2000/xmlns/", Prefix => $prefix, LocalName => $localname, }; } } else { my $ns = $attr->namespaceURI; $ns = '' unless defined $ns; $key = "{$ns}".$attr->localname; ## Not sure why, but $attr->name is coming through stripped ## of its prefix, so we need to hand-assemble a real name. my $name = $attr->name; $name = "" unless defined $name; my $prefix = $attr->prefix; $prefix = "" unless defined $prefix; $name = "$prefix:$name" if index( $name, ":" ) < 0 && length $prefix; $attribs->{$key} = { Name => $name, Value => $attr->value, NamespaceURI => $ns, Prefix => $prefix, LocalName => $attr->localname, }; } # use Data::Dumper; # warn("Attr made: ", Dumper($attribs->{$key}), "\n"); } my $node = { Name => $element->nodeName, Attributes => $attribs, NamespaceURI => $element->namespaceURI, Prefix => $element->prefix || "", LocalName => $element->localname, }; $self->start_element($node); foreach my $child ($element->childNodes) { $self->process_node($child); } my $end_node = { %$node }; delete $end_node->{Attributes}; $self->end_element($end_node); foreach my $ns (@ns_maps) { $self->end_prefix_mapping( { NamespaceURI => $ns->href, Prefix => ( defined $ns->localname ? $ns->localname : ''), } ); } } 1; __END__
| ver. 1.4 |
Github
|
.
| PHP 7.4.33 | Генерация страницы: 0 |
proxy
|
phpinfo
|
Настройка