[libparser-mgc-perl] 11/12: Import of PEVANS/Parser-MGC-0.11 from CPAN.
Jonas Smedegaard
dr at jones.dk
Sat Dec 17 17:37:01 UTC 2016
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 <leonerd at 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 <leonerd at 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
More information about the Pkg-perl-cvs-commits
mailing list