This is an automated email from the git hooks/post-receive script. js pushed a commit to tag PEVANS in repository libparser-mgc-perl.
commit f3360734c2469cb72076367227072a2288e134a2 Author: Paul Evans <leon...@leonerd.org.uk> Date: Tue Jun 12 13:32:33 2012 +0000 Import of PEVANS/Parser-MGC-0.11 from CPAN. gitpan-cpan-distribution: Parser-MGC gitpan-cpan-version: 0.11 gitpan-cpan-path: PEVANS/Parser-MGC-0.11.tar.gz gitpan-cpan-author: PEVANS gitpan-cpan-maturity: released --- Changes | 5 ++ MANIFEST | 2 + META.json | 12 ++--- META.yml | 6 +-- README | 11 ++-- examples/eval-expr.pl | 0 examples/parse-pod.pl | 0 examples/parse-xml.pl | 145 ++++++++++++++++++++++++++++++++++++++++++++++++++ examples/synopsis.pl | 0 lib/Parser/MGC.pm | 25 ++++++--- t/02expect.t | 18 +++---- t/90ex_xml.t | 39 ++++++++++++++ 12 files changed, 232 insertions(+), 31 deletions(-) diff --git a/Changes b/Changes index 4699ce1..b9c8306 100644 --- a/Changes +++ b/Changes @@ -1,5 +1,10 @@ Revision history for Parser-MGC +0.11 CHANGES: + * Allow different toplevel parse methods to the constructor + * Added another example showing parsing XML - only a minimal example; + do not use this as real code. :) + 0.10 CHANGES: * Added ->maybe_expect, for higher performance parsers diff --git a/MANIFEST b/MANIFEST index 10cfb7e..36a3af7 100644 --- a/MANIFEST +++ b/MANIFEST @@ -4,6 +4,7 @@ examples/eval-expr.pl examples/LICENSE examples/parse-dict.pl examples/parse-pod.pl +examples/parse-xml.pl examples/synopsis.pl lib/Parser/MGC.pm LICENSE @@ -38,5 +39,6 @@ t/90ex_dict.t t/90ex_expr.t t/90ex_pod.t t/90ex_synopsis.t +t/90ex_xml.t t/98backcompat.t t/99pod.t diff --git a/META.json b/META.json index aca32f7..0112d41 100644 --- a/META.json +++ b/META.json @@ -4,7 +4,7 @@ "Paul Evans <leon...@leonerd.org.uk>" ], "dynamic_config" : 1, - "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.113640", + "generated_by" : "Module::Build version 0.38, CPAN::Meta::Converter version 2.120630", "license" : [ "perl_5" ], @@ -16,20 +16,20 @@ "prereqs" : { "build" : { "requires" : { - "File::Temp" : 0, - "Test::More" : 0 + "File::Temp" : "0", + "Test::More" : "0" } }, "runtime" : { "requires" : { - "File::Slurp" : 0 + "File::Slurp" : "0" } } }, "provides" : { "Parser::MGC" : { "file" : "lib/Parser/MGC.pm", - "version" : "0.10" + "version" : "0.11" } }, "release_status" : "stable", @@ -38,5 +38,5 @@ "http://dev.perl.org/licenses/" ] }, - "version" : "0.10" + "version" : "0.11" } diff --git a/META.yml b/META.yml index e195ae3..156c6a2 100644 --- a/META.yml +++ b/META.yml @@ -6,7 +6,7 @@ build_requires: File::Temp: 0 Test::More: 0 dynamic_config: 1 -generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.113640' +generated_by: 'Module::Build version 0.38, CPAN::Meta::Converter version 2.120630' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html @@ -15,9 +15,9 @@ name: Parser-MGC provides: Parser::MGC: file: lib/Parser/MGC.pm - version: 0.10 + version: 0.11 requires: File::Slurp: 0 resources: license: http://dev.perl.org/licenses/ -version: 0.10 +version: 0.11 diff --git a/README b/README index 9f4b813..7842e5f 100644 --- a/README +++ b/README @@ -42,10 +42,15 @@ DESCRIPTION CONSTRUCTOR $parser = Parser::MGC->new( %args ) Returns a new instance of a `Parser::MGC' object. This must be called on - a subclass that provides a `parse' method. + a subclass that provides method of the name provided as `toplevel', by + default called `parse'. Takes the following named arguments + toplevel => STRING + Name of the toplevel method to use to start the parse from. If + not supplied, will try to use a method called `parse'. + patterns => HASH Keys in this hash should map to quoted regexp (`qr//') references, to override the default patterns used to match @@ -86,12 +91,12 @@ PATTERNS METHODS $result = $parser->from_string( $str ) - Parse the given literal string and return the result from the `parse' + Parse the given literal string and return the result from the toplevel method. $result = $parser->from_file( $file ) Parse the given file, which may be a pathname in a string, or an opened - IO handle, and return the result from the `parse' method. + IO handle, and return the result from the toplevel method. $result = $parser->from_reader( \&reader ) Parse the input which is read by the `reader' function. This function diff --git a/examples/eval-expr.pl b/examples/eval-expr.pl old mode 100755 new mode 100644 diff --git a/examples/parse-pod.pl b/examples/parse-pod.pl old mode 100755 new mode 100644 diff --git a/examples/parse-xml.pl b/examples/parse-xml.pl new file mode 100644 index 0000000..5277017 --- /dev/null +++ b/examples/parse-xml.pl @@ -0,0 +1,145 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +# DO NOT RELY ON THIS AS A REAL XML PARSER! + +# It is not intended to be used actually as an XML parser, simply to stand as +# an example of how you might use Parser::MGC to parse an XML-like syntax + +# There are a great many things it doesn't do correctly; it lacks at least the +# following features: +# Entities +# Processing instructions +# Comments +# CDATA + +package XmlParser; +use base qw( Parser::MGC ); + +sub parse +{ + my $self = shift; + + my $rootnode = $self->parse_node; + $rootnode->kind eq "element" or die "Expected XML root node"; + $rootnode->name eq "xml" or die "Expected XML root node"; + + return [ $rootnode->children ]; +} + +sub parse_node +{ + my $self = shift; + + # A "node" is either an XML element subtree or plaintext + $self->any_of( + \&parse_plaintext, + \&parse_element, + ); +} + +sub parse_plaintext +{ + my $self = shift; + + my $str = $self->substring_before( '<' ); + $self->fail( "No plaintext" ) unless length $str; + + return XmlParser::Node::Plain->new( $str ); +} + +sub parse_element +{ + my $self = shift; + + my $tag = $self->parse_tag; + + $self->commit; + + my $node = bless [ node => $tag->{name}, $tag->{attrs} ], "XmlParser::Node"; + return XmlParser::Node::Element->new( $tag->{name}, $tag->{attrs} ) if $tag->{selfclose}; + + my $childlist = $self->sequence_of( \&parse_node ); + + $self->parse_close_tag->{name} eq $tag->{name} + or $self->fail( "Expected $tag->{name} to be closed" ); + + return XmlParser::Node::Element->new( $tag->{name}, $tag->{attrs}, @$childlist ); +} + +sub parse_tag +{ + my $self = shift; + + $self->expect( '<' ); + my $tagname = $self->token_ident; + + my @attrs = @{ $self->sequence_of( \&parse_tag_attr ) }; + + my $selfclose = $self->maybe_expect( '/' ); + $self->expect( '>' ); + + return { + name => $tagname, + attrs => { map { ( $_->[0], $_->[1] ) } @attrs }, + selfclose => $selfclose, + }; +} + +sub parse_close_tag +{ + my $self = shift; + + $self->expect( '</' ); + my $tagname = $self->token_ident; + $self->expect( '>' ); + + return { name => $tagname }; +} + +sub parse_tag_attr +{ + my $self = shift; + + my $attrname = $self->token_ident; + $self->expect( '=' ); + return [ $attrname => $self->parse_tag_attr_value ]; +} + +sub parse_tag_attr_value +{ + my $self = shift; + + # TODO: This sucks + return $self->token_string; +} + + +use Data::Dumper; + +if( !caller ) { + my $parser = __PACKAGE__->new; + + my $ret = $parser->from_file( \*STDIN ); + print Dumper( $ret ); +} + + +package XmlParser::Node; +sub new { my $class = shift; bless [ @_ ], $class } + +package XmlParser::Node::Plain; +use base qw( XmlParser::Node ); +sub kind { "plain" } +sub text { shift->[0] } + +package XmlParser::Node::Element; +use base qw( XmlParser::Node ); +sub kind { "element" } +sub name { shift->[0] } +sub attrs { shift->[1] } +sub children { my $self = shift; @{$self}[2..$#$self] } + +1; diff --git a/examples/synopsis.pl b/examples/synopsis.pl old mode 100755 new mode 100644 diff --git a/lib/Parser/MGC.pm b/lib/Parser/MGC.pm index 2a0f3b3..f1cac25 100644 --- a/lib/Parser/MGC.pm +++ b/lib/Parser/MGC.pm @@ -8,7 +8,7 @@ package Parser::MGC; use strict; use warnings; -our $VERSION = '0.10'; +our $VERSION = '0.11'; use Carp; @@ -67,12 +67,18 @@ grammars that require backtracking. =head2 $parser = Parser::MGC->new( %args ) Returns a new instance of a C<Parser::MGC> object. This must be called on a -subclass that provides a C<parse> method. +subclass that provides method of the name provided as C<toplevel>, by default +called C<parse>. Takes the following named arguments =over 8 +=item toplevel => STRING + +Name of the toplevel method to use to start the parse from. If not supplied, +will try to use a method called C<parse>. + =item patterns => HASH Keys in this hash should map to quoted regexp (C<qr//>) references, to @@ -148,10 +154,13 @@ sub new my $class = shift; my %args = @_; - $class->can( "parse" ) or - croak "Expected to be a subclass that can ->parse"; + my $toplevel = $args{toplevel} || "parse"; + + $class->can( $toplevel ) or + croak "Expected to be a subclass that can ->$toplevel"; my $self = bless { + toplevel => $toplevel, patterns => {}, scope_level => 0, }, $class; @@ -171,7 +180,7 @@ sub new =head2 $result = $parser->from_string( $str ) -Parse the given literal string and return the result from the C<parse> method. +Parse the given literal string and return the result from the toplevel method. =cut @@ -184,7 +193,8 @@ sub from_string pos $self->{str} = 0; - my $result = $self->parse; + my $toplevel = $self->{toplevel}; + my $result = $self->$toplevel; $self->at_eos or $self->fail( "Expected end of input" ); @@ -195,7 +205,7 @@ sub from_string =head2 $result = $parser->from_file( $file ) Parse the given file, which may be a pathname in a string, or an opened IO -handle, and return the result from the C<parse> method. +handle, and return the result from the toplevel method. =cut @@ -327,6 +337,7 @@ sub at_eos { my $self = shift; + # Save pos() before skipping ws so we don't break the substring_before method my $pos = pos $self->{str}; $self->skip_ws; diff --git a/t/02expect.t b/t/02expect.t index bbfd5b0..ec9efba 100644 --- a/t/02expect.t +++ b/t/02expect.t @@ -7,27 +7,21 @@ use Test::More tests => 7; package TestParser; use base qw( Parser::MGC ); -sub parse +sub parse_hello { my $self = shift; [ $self->expect( "hello" ), $self->expect( qr/world/ ) ]; } -package HexParser; -use base qw( Parser::MGC ); - -sub parse +sub parse_hex { my $self = shift; return hex +( $self->expect( qr/0x([0-9A-F]+)/i ) )[1]; } -package FooBarParser; -use base qw( Parser::MGC ); - -sub parse +sub parse_foo_or_bar { my $self = shift; @@ -37,7 +31,7 @@ sub parse package main; -my $parser = TestParser->new; +my $parser = TestParser->new( toplevel => "parse_hello" ); is_deeply( $parser->from_string( "hello world" ), [ "hello", "world" ], @@ -58,11 +52,11 @@ is( $@, qq[^\n], 'Exception from "goodbye world" failure' ); -$parser = HexParser->new; +$parser = TestParser->new( toplevel => "parse_hex" ); is( $parser->from_string( "0x123" ), 0x123, "Hex parser captures substring" ); -$parser = FooBarParser->new; +$parser = TestParser->new( toplevel => "parse_foo_or_bar" ); is( $parser->from_string( "Foo" ), "Foo", "FooBar parser first case" ); is( $parser->from_string( "Bar" ), "Bar", "FooBar parser first case" ); diff --git a/t/90ex_xml.t b/t/90ex_xml.t new file mode 100644 index 0000000..30a852c --- /dev/null +++ b/t/90ex_xml.t @@ -0,0 +1,39 @@ +#!/usr/bin/perl -w + +use strict; + +use Test::More tests => 5; + +require "examples/parse-xml.pl"; + +my $parser = XmlParser->new; + +sub plain { bless [ @_ ], "XmlParser::Node::Plain" } +sub elem { bless [ @_ ], "XmlParser::Node::Element" } + +sub test +{ + my ( $str, $expect, $name ) = @_; + + is_deeply( $parser->from_string( $str ), $expect, $name ); +} + +test q[<xml>Hello world</xml>], + [ plain("Hello world") ], + "Plaintext"; + +test q[<xml><message>Hello world</message></xml>], + [ elem(message => {}, plain("Hello world")) ], + "Single node"; + +test q[<xml><first>Hello</first><second>world</second></xml>], + [ elem(first => {}, plain("Hello")), elem(second => {}, plain("world")) ], + "Two nodes"; + +test q[<xml><first>Hello</first> <second>world</second></xml>], + [ elem(first => {}, plain("Hello")), plain(" "), elem(second => {}, plain("world")) ], + "Two nodes with whitespace"; + +test q[<xml><node a1="v1" a2="v2" /></xml>], + [ elem(node => { a1 => "v1", a2 => "v2" }) ], + "Node with attrs"; -- Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/pkg-perl/packages/libparser-mgc-perl.git _______________________________________________ Pkg-perl-cvs-commits mailing list Pkg-perl-cvs-commits@lists.alioth.debian.org http://lists.alioth.debian.org/cgi-bin/mailman/listinfo/pkg-perl-cvs-commits