parser.pm

ARM上的如果你对底层感兴趣

package XML::Parser;

use strict;
use vars qw($VERSION %Built_In_Styles);
use Carp;

BEGIN {
    require XML::Parser::Expat;
    $VERSION = '2.16';
    die "Parser.pm and Expat.pm versions don't match"
	unless $VERSION eq $XML::Parser::Expat::VERSION;
}

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;


    $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";

	    # I'm using the Built_In_Styles hash to define
	    # valid internal styles, since a style doesn't
	    # need to define any particular Handler to be valid.
	    # So I can't check for the existence of a particular sub.

	    croak "Undefined style: $style"
		unless defined($Built_In_Styles{$stylepkg});
	    $stylepkg = 'XML::Parser::' . $stylepkg;
	}

	my $htype;
	foreach $htype (keys %{$args{_HNDL_TYPES}}) {
	    # Handlers explicity 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;
		}
	    }
	}
    }

    $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);

    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");
	}
	$self->{Handlers}->{$type} = $handler;
    }
}  # End of setHandlers

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 = new XML::Parser::Expat(@expat_options, @_);
    my %handlers = %{$self->{Handlers}};
    my $init = delete $handlers{Init};
    my $final = delete $handlers{Final};

    $expat->setHandlers(%handlers);

    &$init($expat)
	if defined($init);

    my $result = $expat->parse($arg);

    if ($result and defined($final)) {
	$result = &$final($expat);
    }

    $result;
}  # End of parse

sub parsestring {
    my $self = shift;
    $self->parse(@_);
}  # End of parsestring

sub parsefile {
    my $self = shift;
    my $file = shift;
    local(*FILE);
    open(FILE, $file) or  croak "Couldn't open $file:\n$!";
    my $ret;

    eval {
	$ret = $self->parse(*FILE, @_);
    };
    my $err = $@;
    close(FILE);
    die $err if $err;

    $ret;
}  # End of parsefile

###################################################################

package XML::Parser::Debug;
$XML::Parser::Built_In_Styles{Debug} = 1;

sub Start {
    my $expat = shift;
    my $tag = shift;
    print STDERR "@{$expat->{Context}} \\\\ (@_)\n";
}

sub End {
    my $expat = shift;
    my $tag = shift;
    print STDERR "@{$expat->{Context}} //\n";
}

sub Char {
    my $expat = shift;
    my $text = shift;
    $text =~ s/([\x80-\xff])/sprintf "#x%X;", ord $1/eg;
    $text =~ s/([\t\n])/sprintf "#%d;", ord $1/eg;
    print STDERR "@{$expat->{Context}} || $text\n";
}

sub Proc {
    my $expat = shift;
    my $target = shift;
    my $text = shift;
    print $expat,"\n";
    print $expat->{Context}, "\n";
    my @foo = @{$expat->{Context}};
    print STDERR "@foo $target($text)\n";
}

###################################################################

package XML::Parser::Subs;
$XML::Parser::Built_In_Styles{Subs} = 1;

sub Start {
    no strict 'refs';
    my $expat = shift;
    my $tag = shift;
    my $sub = $expat->{Pkg} . "::$tag";
    eval { &$sub($expat, $tag, @_) };
}

sub End {
    no strict 'refs';
    my $expat = shift;
    my $tag = shift;
    my $sub = $expat->{Pkg} . "::${tag}_";
    eval { &$sub($expat, $tag) };
}

###################################################################

package XML::Parser::Tree;
$XML::Parser::Built_In_Styles{Tree} = 1;

sub Init {
    my $expat = shift;
    $expat->{Lists} = [];
    $expat->{Curlist} = $expat->{Tree} = [];
}

sub Start {
    my $expat = shift;
    my $tag = shift;
    my $newlist = [ { @_ } ];
    push @{ $expat->{Lists} }, $expat->{Curlist};
    push @{ $expat->{Curlist} }, $tag => $newlist;
    $expat->{Curlist} = $newlist;
}

sub End {
    my $expat = shift;
    my $tag = shift;
    $expat->{Curlist} = pop @{ $expat->{Lists} };
}

sub Char {
    my $expat = shift;
    my $text = shift;
    my $clist = $expat->{Curlist};
    my $pos = $#$clist;

    if ($pos > 0 and $clist->[$pos - 1] eq '0') {
	$clist->[$pos] .= $text;
    }
    else {
	push @$clist, 0 => $text;
    }
}

sub Final {
    my $expat = shift;
    delete $expat->{Curlist};
    delete $expat->{Lists};
    $expat->{Tree};
}

###################################################################

package XML::Parser::Objects;
$XML::Parser::Built_In_Styles{Objects} = 1;

sub Init {
    my $expat = shift;
    $expat->{Lists} = [];
    $expat->{Curlist} = $expat->{Tree} = [];
}

sub Start {
    my $expat = shift;
    my $tag = shift;
    my $newlist = [ ];
    my $class = "${$expat}{Pkg}::$tag";
    my $newobj = bless { @_, Kids => $newlist }, $class;
    push @{ $expat->{Lists} }, $expat->{Curlist};
    push @{ $expat->{Curlist} }, $newobj;
    $expat->{Curlist} = $newlist;
}

sub End {
    my $expat = shift;
    my $tag = shift;
    $expat->{Curlist} = pop @{ $expat->{Lists} };
}

sub Char {
    my $expat = shift;
    my $text = shift;
    my $class = "${$expat}{Pkg}::Characters";
    my $clist = $expat->{Curlist};
    my $pos = $#$clist;

    if ($pos >= 0 and ref($clist->[$pos]) eq $class) {
	$clist->[$pos]->{Text} .= $text;
    }
    else {
	push @$clist, bless { Text => $text }, $class;
    }
}

sub Final {
    my $expat = shift;
    delete $expat->{Curlist};
    delete $expat->{Lists};
    $expat->{Tree};
}

################################################################

package XML::Parser::Stream;
$XML::Parser::Built_In_Styles{Stream} = 1;

# This style invented by Tim Bray <[e-mail]>

sub Init {
    no strict 'refs';
    my $expat = shift;
    $expat->{Text} = '';
    my $sub = $expat->{Pkg} ."::StartDocument";
    &$sub($expat)
	if defined(&$sub);
}

sub Start {
    no strict 'refs';
    my $expat = shift;
    my $type = shift;

    doText($expat);
    $_ = "<$type";

    %_ = @_;
    while (@_) {
	$_ .= ' ' . shift() . '="' . shift() . '"';
    }
    $_ .= '>';

    my $sub = $expat->{Pkg} . "::StartTag";
    if (defined(&$sub)) {
	&$sub($expat, $type);
    }
    else {
	print;
    }
}

sub End {
    no strict 'refs';
    my $expat = shift;
    my $type = shift;

    doText($expat);

    $_ = "</$type>";

    my $sub = $expat->{Pkg} . "::EndTag";
    if (defined(&$sub)) {
	&$sub($expat, $type);
    }
    else {
	print;
    }
}

sub Char {
    my $expat = shift;
    $expat->{Text} .= shift;
}

sub Proc {
    no strict 'refs';
    my $expat = shift;
    my $target = shift;
    my $text = shift;

    $_ = "<?$target $text?>";

    my $sub = $expat->{Pkg} . "::PI";
    if (defined(&$sub)) {
	&$sub($expat, $target, $text);
    }
    else {
	print;
    }
}

sub Final {
    no strict 'refs';
    my $expat = shift;
    my $sub = $expat->{Pkg} . "::EndDocument";
    &$sub($expat)
	if defined(&$sub);
}

sub doText {
    no strict 'refs';
    my $expat = shift;
    $_ = $expat->{Text};

    if ($_) {
	my $sub = $expat->{Pkg} . "::Text";
	if (defined(&$sub)) {
	    &$sub($expat);
	}
	else {
	    print;
	}