Index: /trunk/PS-IPP-Metadata-Config/Build.PL =================================================================== --- /trunk/PS-IPP-Metadata-Config/Build.PL (revision 8582) +++ /trunk/PS-IPP-Metadata-Config/Build.PL (revision 8583) @@ -2,5 +2,20 @@ # See perldoc Module::Build for details of how this works -Module::Build->new( +my $class = Module::Build->subclass(code => <<'EOF'); +use File::Copy; + +sub ACTION_code { + my $self = shift; + + $self->SUPER::ACTION_code(@_); + + system("perl -MParse::RecDescent - config_grammar.txt PS::IPP::Metadata::Parser") == 0 + or die "Parse::RecDecent code gen failed: $?"; + move("Parser.pm", "lib/PS/IPP/Metadata/Parser.pm") + or die "move failed: $!"; +} +EOF + +$class->new( module_name => 'PS::IPP::Metadata::Config', dist_version_from => 'lib/PS/IPP/Metadata/Config.pm', Index: /trunk/PS-IPP-Metadata-Config/Changes =================================================================== --- /trunk/PS-IPP-Metadata-Config/Changes (revision 8582) +++ /trunk/PS-IPP-Metadata-Config/Changes (revision 8583) @@ -1,3 +1,8 @@ Revision history for Perl module PS::IPP::Metadata::Config + +0.02 Thu Aug 24 17:08:14 HST 2006 + - split grammar out of PS::IPP::Metadata::Config into grammar_config.txt + - precompile the parser as PS::IPP::Metadata::Pasrser + - change PS::IPP::Metadata::Config to use PS::IPP::Metadata::Pasrser 0.01 Tue Feb 22 15:46:35 2005 Index: /trunk/PS-IPP-Metadata-Config/MANIFEST =================================================================== --- /trunk/PS-IPP-Metadata-Config/MANIFEST (revision 8582) +++ /trunk/PS-IPP-Metadata-Config/MANIFEST (revision 8583) @@ -7,7 +7,9 @@ README Todo +config_grammar.txt docs/sdrs_grammar.txt lib/PS/IPP/Metadata/Config.pm lib/PS/IPP/Metadata/Config.pod +lib/PS/IPP/Metadata/Parser.pm scripts/mdc-dump t/01_load.t Index: /trunk/PS-IPP-Metadata-Config/config_grammar.txt =================================================================== --- /trunk/PS-IPP-Metadata-Config/config_grammar.txt (revision 8583) +++ /trunk/PS-IPP-Metadata-Config/config_grammar.txt (revision 8583) @@ -0,0 +1,354 @@ +# Copyright (c) 2005 Joshua Hoblitt +# +# $Id: config_grammar.txt,v 1.1 2006-08-25 03:08:56 jhoblitt Exp $ + +{ + use strict; + + use Carp qw( carp ); + + our @scope_stack; +} + +startrule: grammar eofile + { $item{grammar} } + +grammar: + statement(s) + { + $thisparser->{local} = pop @scope_stack; + [ grep $_->{class} !~ /comment_line/, @{$item[1]} ]; + } + +statement: + scalar + | vector + | comment_line + | typedef + | metadata + | typedef_declare + | multi_declare + | time + | + +scalar: + name type comment(?) "\n" + { + $thisparser->{local}{name}{ $item{name} }++ + unless defined $thisparser->{local}{name}{ $item{name} }; + + $return = { + class => 'scalar', + name => $item{name}, + type => $item{type}, + value => $item[4], + }; + + $return->{comment} = $item{'comment(?)'}[0] + if $item{'comment(?)'}[0]; + + if ( defined $thisparser->{local}{name}{ $item{name} } ) { + $return->{multi}++ + if $thisparser->{local}{name}{ $item{name} } =~ /MULTI/; + } else { + $thisparser->{local}{name}{ $item{name} }++; + } + } + +vector: + vname vtype vvalue[ $item{vtype} ] comment(?) "\n" + { + $thisparser->{local}{name}{ $item{vname} }++ + unless defined $thisparser->{local}{name}{ $item{vname} }; + + $return = { + class => 'vector', + name => $item{vname}, + type => $item{vtype}, + value => $item{vvalue}, + comment => $item{comment} + }; + + $return->{comment} = $item{'comment(?)'}[0] + if $item{'comment(?)'}[0]; + } + +multi_declare: + name /MULTI/i comment(?) "\n" + { + if ( ! defined $thisparser->{local}{name}{ $item{name} } ) { + $thisparser->{local}{name}{ $item{name} } = "MULTI"; + $return = { class => 'comment_line' }; + } else { + $return = undef; + } + } + | + +metadata: + metadata_name + { push @scope_stack, $thisparser->{local}; $thisparser->{local} = {} } + grammar + metadata_end + { + my $text = $item[2]; + + if ( defined( $text ) ) { + $return = { + class => 'metadata', + name => $item{metadata_name}, + value => $item{grammar}, + }; + } else { + $return = undef; + } + + if ( defined $thisparser->{local}{name}{ $item{metadata_name} } ) { + $return->{multi}++ + if $thisparser->{local}{name}{ $item{metadata_name} } =~ /MULTI/; + } else { + $thisparser->{local}{name}{ $item{metadata_name} }++; + } + } + | + +comment_line: + comment(?) "\n" + {{ class => 'comment_line' }} + +time: + name ttype comment(?) "\n" + { + use DateTime::Format::ISO8601; + + $return = { + class => 'time', + name => $item{name}, + type => $item{ttype}, + value => $item[4], + }; + + $return->{comment} = $item{'comment(?)'}[0] + if $item{'comment(?)'}[0]; + } + +typedef_declare: + 'TYPE' name name(s) comment(?) "\n" + { + if (defined $thisparser->{local}{typedef}{ $item{name} }) { + carp "refinition of TYPE $item{name}"; + $return = undef; + } else { + + my $type = { + class => 'typedef_declare', + name => $item{name}, + fields => $item{'name(s)'}, + length => scalar @{ $item{'name(s)'} }, + }; + + $thisparser->{local}{typedef}{ $item{name} } = $type; + + # don't return anything in the parse tree + $return = { class => 'comment_line' }; + } + } + | + +typedef: + name typedef_type word(s) comment(?) "\n" + { + my $type = $thisparser->{local}{typedef}{ $item{typedef_type} }; + + unless ( scalar @{ $item{'word(s)'} } == $type->{length} ) { + my $expect = $type->{length}; + my $got = scalar @{ $item{'word(s)'} }; + carp "\"$item{name} $item{typedef_type}\"" + . " does not have enough fields, epected: $expect, got: $got"; + $return = undef; + } else { + my @md; + my $i = 0; + foreach my $name ( @{ $type->{fields} } ) { + push @md, { + name => $name, + class => 'scalar', + type => 'STR', + value => $item{'word(s)'}[$i], + }; + + $i++; + } + + $return = { + class => 'metadata', + name => $item{name}, + value => \@md, + }; + } + } + | + + +typedef_type: name + { + if ( ! defined $thisparser->{local}{typedef}{ $item{name} } ) { + $return = undef; + } else { + $return = $item{name}; + } + } + +metadata_name: + name /METADATA/i comment(?) "\n" + { $item{name} } + +metadata_end: + /END/i comment(?) "\n" + +comment: + '#' to_end_of_line + { $item{to_end_of_line} } + +vname: + '@' name + { $item{name} } + +name: + /[a-z][.\w-]*/i + { + if ( $item[1] =~ /^(METADATA|END|TYPE)$/i ) { + $return = undef; + } else { + $return = $item[1]; + } + } + +# 'STR' seems to be the most common type, trying to match it first is a simple +# optimization. +type: + 'STR' + | 'STRING' + | vtype + +vtype: + 'S8' + | 'S16' + | 'S32' + | 'S64' + | 'U8' + | 'U16' + | 'U32' + | 'U64' + | 'F32' + | 'F64' + | 'C32' + | 'C64' + | 'BOOL' + +ttype: + 'UTC' + | 'UT1' + | 'TAI' + | 'TT' + +S8: int +S16: int +S32: int +S64: int +U8 : int +U16: int +U32: int +U64: int +F32: float +F64: float +C32: float +C64: float +BOOL: bool +STR: string +STRING: string + +vvalue: + _vvalue[%arg](s) + { [ map { @$_ } @{$item[1]} ] } + +tvalue: + iso8601 + | epoch + +# backtracking optimization +_vvalue: + vector_sep(?) + { [ $item[1] ] } + +vector_sep: + /,|\s+/ + +int: + # $RE{num}{int} from Regexp::Common::number + /(?:(?:[+-]?)(?:[0-9]+))/ + +float: + # based on $RE{num}{real} from Regexp::Common::number + /(?:(?i)(?:[+-]?)(?:(?=[0-9]|[.])(?:[0-9]*)(?:(?:[.])(?:[0-9]{0,}))?)(?:(?:[Ee])(?:(?:[+-]?)(?:[0-9]+))|))/ + +bool: + /[tf]/i + { $item[1] =~ /t/i ? 1 : 0 } + +string: + /(?:\S[^#\n]*)?[^#\n ]/ + +word: + /(?:[^#\s\n]+)/ + +to_end_of_line: + /[^\n]*/ + { + my $comment = $item[1]; + # remove leading whitespace + $comment =~ s/^\s+//; + # remove trailing whitespace + $comment =~ s/\s+$//; + + $return = $comment; + } + +UTC: + iso8601 + | utc_epoch + +UT1: + iso8601 + | epoch + +TAI: + iso8601 + | epoch + +TT: + iso8601 + | epoch + +iso8601: + # based on code from DateTime::Format::ISO8601 + / (\d{4}) - (\d\d) - (\d\d) T (\d\d) : (\d\d) : (\d\d) Z /x + { DateTime::Format::ISO8601->parse_datetime( $item[1] ) } + +utc_epoch: + / (-?\d{1,19}) \s*,\s* (\d{1,9}) (?:\s*,\s* (\d))? /x + {{ + sec => $1, + nsec => $2, + leapsecond => $3, + }} + +epoch: + / (-?\d{1,19}) \s*,\s* (\d{1,9}) /x + {{ + sec => $1, + nsec => $2, + }} + +eofile: + /^\z/ Index: /trunk/PS-IPP-Metadata-Config/lib/PS/IPP/Metadata/Config.pm =================================================================== --- /trunk/PS-IPP-Metadata-Config/lib/PS/IPP/Metadata/Config.pm (revision 8582) +++ /trunk/PS-IPP-Metadata-Config/lib/PS/IPP/Metadata/Config.pm (revision 8583) @@ -1,5 +1,5 @@ # Copyright (c) 2005 Joshua Hoblitt # -# $Id: Config.pm,v 1.18 2006-07-12 02:49:53 jhoblitt Exp $ +# $Id: Config.pm,v 1.19 2006-08-25 03:08:56 jhoblitt Exp $ package PS::IPP::Metadata::Config; @@ -8,8 +8,8 @@ use warnings FATAL => qw( all ); -our $VERSION = '0.01'; +our $VERSION = '0.02'; use Carp qw( carp ); -use Parse::RecDescent; +use PS::IPP::Metadata::Parser; use base qw( Class::Accessor::Fast ); @@ -25,5 +25,5 @@ my $class = shift; - my $self = { _parser => Parse::RecDescent->new( $grammar ) }; + my $self = { _parser => PS::IPP::Metadata::Parser->new }; bless $self, $class; @@ -110,354 +110,3 @@ 1; -__DATA__ - -{ - use strict; - - use Carp qw( carp ); - - our @scope_stack; -} - -startrule: grammar eofile - { $item{grammar} } - -grammar: - statement(s) - { - $thisparser->{local} = pop @scope_stack; - [ grep $_->{class} !~ /comment_line/, @{$item[1]} ]; - } - -statement: - scalar - | vector - | comment_line - | typedef - | metadata - | typedef_declare - | multi_declare - | time - | - -scalar: - name type comment(?) "\n" - { - $thisparser->{local}{name}{ $item{name} }++ - unless defined $thisparser->{local}{name}{ $item{name} }; - - $return = { - class => 'scalar', - name => $item{name}, - type => $item{type}, - value => $item[4], - }; - - $return->{comment} = $item{'comment(?)'}[0] - if $item{'comment(?)'}[0]; - - if ( defined $thisparser->{local}{name}{ $item{name} } ) { - $return->{multi}++ - if $thisparser->{local}{name}{ $item{name} } =~ /MULTI/; - } else { - $thisparser->{local}{name}{ $item{name} }++; - } - } - -vector: - vname vtype vvalue[ $item{vtype} ] comment(?) "\n" - { - $thisparser->{local}{name}{ $item{vname} }++ - unless defined $thisparser->{local}{name}{ $item{vname} }; - - $return = { - class => 'vector', - name => $item{vname}, - type => $item{vtype}, - value => $item{vvalue}, - comment => $item{comment} - }; - - $return->{comment} = $item{'comment(?)'}[0] - if $item{'comment(?)'}[0]; - } - -multi_declare: - name /MULTI/i comment(?) "\n" - { - if ( ! defined $thisparser->{local}{name}{ $item{name} } ) { - $thisparser->{local}{name}{ $item{name} } = "MULTI"; - $return = { class => 'comment_line' }; - } else { - $return = undef; - } - } - | - -metadata: - metadata_name - { push @scope_stack, $thisparser->{local}; $thisparser->{local} = {} } - grammar - metadata_end - { - my $text = $item[2]; - - if ( defined( $text ) ) { - $return = { - class => 'metadata', - name => $item{metadata_name}, - value => $item{grammar}, - }; - } else { - $return = undef; - } - - if ( defined $thisparser->{local}{name}{ $item{metadata_name} } ) { - $return->{multi}++ - if $thisparser->{local}{name}{ $item{metadata_name} } =~ /MULTI/; - } else { - $thisparser->{local}{name}{ $item{metadata_name} }++; - } - } - | - -comment_line: - comment(?) "\n" - {{ class => 'comment_line' }} - -time: - name ttype comment(?) "\n" - { - use DateTime::Format::ISO8601; - - $return = { - class => 'time', - name => $item{name}, - type => $item{ttype}, - value => $item[4], - }; - - $return->{comment} = $item{'comment(?)'}[0] - if $item{'comment(?)'}[0]; - } - -typedef_declare: - 'TYPE' name name(s) comment(?) "\n" - { - if (defined $thisparser->{local}{typedef}{ $item{name} }) { - carp "refinition of TYPE $item{name}"; - $return = undef; - } else { - - my $type = { - class => 'typedef_declare', - name => $item{name}, - fields => $item{'name(s)'}, - length => scalar @{ $item{'name(s)'} }, - }; - - $thisparser->{local}{typedef}{ $item{name} } = $type; - - # don't return anything in the parse tree - $return = { class => 'comment_line' }; - } - } - | - -typedef: - name typedef_type word(s) comment(?) "\n" - { - my $type = $thisparser->{local}{typedef}{ $item{typedef_type} }; - - unless ( scalar @{ $item{'word(s)'} } == $type->{length} ) { - my $expect = $type->{length}; - my $got = scalar @{ $item{'word(s)'} }; - carp "\"$item{name} $item{typedef_type}\"" - . " does not have enough fields, epected: $expect, got: $got"; - $return = undef; - } else { - my @md; - my $i = 0; - foreach my $name ( @{ $type->{fields} } ) { - push @md, { - name => $name, - class => 'scalar', - type => 'STR', - value => $item{'word(s)'}[$i], - }; - - $i++; - } - - $return = { - class => 'metadata', - name => $item{name}, - value => \@md, - }; - } - } - | - - -typedef_type: name - { - if ( ! defined $thisparser->{local}{typedef}{ $item{name} } ) { - $return = undef; - } else { - $return = $item{name}; - } - } - -metadata_name: - name /METADATA/i comment(?) "\n" - { $item{name} } - -metadata_end: - /END/i comment(?) "\n" - -comment: - '#' to_end_of_line - { $item{to_end_of_line} } - -vname: - '@' name - { $item{name} } - -name: - /[a-z][.\w-]*/i - { - if ( $item[1] =~ /^(METADATA|END|TYPE)$/i ) { - $return = undef; - } else { - $return = $item[1]; - } - } - -# 'STR' seems to be the most common type, trying to match it first is a simple -# optimization. -type: - 'STR' - | 'STRING' - | vtype - -vtype: - 'S8' - | 'S16' - | 'S32' - | 'S64' - | 'U8' - | 'U16' - | 'U32' - | 'U64' - | 'F32' - | 'F64' - | 'C32' - | 'C64' - | 'BOOL' - -ttype: - 'UTC' - | 'UT1' - | 'TAI' - | 'TT' - -S8: int -S16: int -S32: int -S64: int -U8 : int -U16: int -U32: int -U64: int -F32: float -F64: float -C32: float -C64: float -BOOL: bool -STR: string -STRING: string - -vvalue: - _vvalue[%arg](s) - { [ map { @$_ } @{$item[1]} ] } - -tvalue: - iso8601 - | epoch - -# backtracking optimization -_vvalue: - vector_sep(?) - { [ $item[1] ] } - -vector_sep: - /,|\s+/ - -int: - # $RE{num}{int} from Regexp::Common::number - /(?:(?:[+-]?)(?:[0-9]+))/ - -float: - # based on $RE{num}{real} from Regexp::Common::number - /(?:(?i)(?:[+-]?)(?:(?=[0-9]|[.])(?:[0-9]*)(?:(?:[.])(?:[0-9]{0,}))?)(?:(?:[Ee])(?:(?:[+-]?)(?:[0-9]+))|))/ - -bool: - /[tf]/i - { $item[1] =~ /t/i ? 1 : 0 } - -string: - /(?:\S[^#\n]*)?[^#\n ]/ - -word: - /(?:[^#\s\n]+)/ - -to_end_of_line: - /[^\n]*/ - { - my $comment = $item[1]; - # remove leading whitespace - $comment =~ s/^\s+//; - # remove trailing whitespace - $comment =~ s/\s+$//; - - $return = $comment; - } - -UTC: - iso8601 - | utc_epoch - -UT1: - iso8601 - | epoch - -TAI: - iso8601 - | epoch - -TT: - iso8601 - | epoch - -iso8601: - # based on code from DateTime::Format::ISO8601 - / (\d{4}) - (\d\d) - (\d\d) T (\d\d) : (\d\d) : (\d\d) Z /x - { DateTime::Format::ISO8601->parse_datetime( $item[1] ) } - -utc_epoch: - / (-?\d{1,19}) \s*,\s* (\d{1,9}) (?:\s*,\s* (\d))? /x - {{ - sec => $1, - nsec => $2, - leapsecond => $3, - }} - -epoch: - / (-?\d{1,19}) \s*,\s* (\d{1,9}) /x - {{ - sec => $1, - nsec => $2, - }} - -eofile: - /^\z/ +__END__