IPP Software Navigation Tools IPP Links Communication Pan-STARRS Links

Changeset 8583


Ignore:
Timestamp:
Aug 24, 2006, 5:08:56 PM (20 years ago)
Author:
jhoblitt
Message:

VERSION to 0.02
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

Location:
trunk/PS-IPP-Metadata-Config
Files:
1 added
4 edited

Legend:

Unmodified
Added
Removed

  • trunk/PS-IPP-Metadata-Config/Build.PL

    r5202 r8583  
    22# See perldoc Module::Build for details of how this works
    33
    4 Module::Build->new(
     4my $class = Module::Build->subclass(code => <<'EOF');
     5use File::Copy;
     6
     7sub ACTION_code {
     8    my $self = shift;
     9
     10    $self->SUPER::ACTION_code(@_);
     11
     12    system("perl -MParse::RecDescent - config_grammar.txt PS::IPP::Metadata::Parser") == 0
     13        or die "Parse::RecDecent code gen failed: $?";
     14    move("Parser.pm", "lib/PS/IPP/Metadata/Parser.pm")
     15        or die "move failed: $!";
     16}
     17EOF
     18
     19$class->new(
    520    module_name         => 'PS::IPP::Metadata::Config',
    621    dist_version_from   => 'lib/PS/IPP/Metadata/Config.pm',

  • trunk/PS-IPP-Metadata-Config/Changes

    r3308 r8583  
    11Revision history for Perl module PS::IPP::Metadata::Config
     2
     30.02 Thu Aug 24 17:08:14 HST 2006
     4    - split grammar out of PS::IPP::Metadata::Config into grammar_config.txt
     5    - precompile the parser as PS::IPP::Metadata::Pasrser
     6    - change PS::IPP::Metadata::Config to use PS::IPP::Metadata::Pasrser
    27
    380.01 Tue Feb 22 15:46:35 2005

  • trunk/PS-IPP-Metadata-Config/MANIFEST

    r5205 r8583  
    77README
    88Todo
     9config_grammar.txt
    910docs/sdrs_grammar.txt
    1011lib/PS/IPP/Metadata/Config.pm
    1112lib/PS/IPP/Metadata/Config.pod
     13lib/PS/IPP/Metadata/Parser.pm
    1214scripts/mdc-dump
    1315t/01_load.t

  • trunk/PS-IPP-Metadata-Config/lib/PS/IPP/Metadata/Config.pm

    r7865 r8583  
    11# Copyright (c) 2005  Joshua Hoblitt
    22#
    3 # $Id: Config.pm,v 1.18 2006-07-12 02:49:53 jhoblitt Exp $
     3# $Id: Config.pm,v 1.19 2006-08-25 03:08:56 jhoblitt Exp $
    44
    55package PS::IPP::Metadata::Config;
    … …  
    88use warnings FATAL => qw( all );
    99
    10 our $VERSION = '0.01';
     10our $VERSION = '0.02';
    1111
    1212use Carp qw( carp );
    13 use Parse::RecDescent;
     13use PS::IPP::Metadata::Parser;
    1414
    1515use base qw( Class::Accessor::Fast );
    … …  
    2525    my $class = shift;
    2626
    27     my $self = { _parser => Parse::RecDescent->new( $grammar ) };
     27    my $self = { _parser => PS::IPP::Metadata::Parser->new };
    2828
    2929    bless $self, $class;
    … …  
    1101101;
    111111
    112 __DATA__
    113 
    114 {
    115     use strict;
    116 
    117     use Carp qw( carp );
    118 
    119     our @scope_stack;
    120 }
    121 
    122 startrule: grammar eofile
    123     { $item{grammar} }
    124 
    125 grammar:
    126     statement(s)
    127         {
    128             $thisparser->{local} = pop @scope_stack;
    129             [ grep $_->{class} !~ /comment_line/, @{$item[1]} ];
    130         }
    131 
    132 statement:
    133     scalar
    134     | vector
    135     | comment_line
    136     | typedef
    137     | metadata
    138     | typedef_declare
    139     | multi_declare
    140     | time
    141     | <error:unmatched statement: $text>
    142 
    143 scalar:
    144     <skip:'[ \t\r]*'> name type <matchrule:$item{type}> comment(?) "\n"
    145         {
    146             $thisparser->{local}{name}{ $item{name} }++
    147                 unless defined $thisparser->{local}{name}{ $item{name} };
    148 
    149             $return = {
    150                 class   => 'scalar',
    151                 name    => $item{name},
    152                 type    => $item{type},
    153                 value   => $item[4],
    154             };
    155 
    156             $return->{comment} = $item{'comment(?)'}[0]
    157                 if $item{'comment(?)'}[0];
    158 
    159             if ( defined $thisparser->{local}{name}{ $item{name} } ) {
    160                 $return->{multi}++
    161                     if $thisparser->{local}{name}{ $item{name} } =~ /MULTI/;
    162             } else {
    163                 $thisparser->{local}{name}{ $item{name} }++;
    164             }
    165         }
    166 
    167 vector:
    168      <skip:'[ \t\r]*'> vname vtype vvalue[ $item{vtype} ] comment(?) "\n"
    169         {
    170             $thisparser->{local}{name}{ $item{vname} }++
    171                 unless defined $thisparser->{local}{name}{ $item{vname} };
    172 
    173             $return = {
    174                 class   => 'vector',
    175                 name    => $item{vname},
    176                 type    => $item{vtype},
    177                 value   => $item{vvalue},
    178                 comment => $item{comment}
    179             };
    180 
    181             $return->{comment} = $item{'comment(?)'}[0]
    182                 if $item{'comment(?)'}[0];
    183         }
    184 
    185 multi_declare:
    186     <skip:'[ \t\r]*'> name /MULTI/i <commit> comment(?) "\n"
    187         {
    188             if ( ! defined $thisparser->{local}{name}{ $item{name} } ) {
    189                 $thisparser->{local}{name}{ $item{name} } = "MULTI";
    190                 $return = { class   => 'comment_line' };
    191             } else {
    192                 $return = undef;
    193             }
    194         }
    195     | <error?:redefinition of MULTI> <reject>
    196 
    197 metadata:
    198     metadata_name <commit>
    199     { push @scope_stack, $thisparser->{local}; $thisparser->{local} = {} }
    200     grammar
    201     metadata_end
    202         {
    203             my $text = $item[2];
    204            
    205             if ( defined( $text ) ) {
    206                 $return = {
    207                     class   => 'metadata',
    208                     name    => $item{metadata_name},
    209                     value   => $item{grammar},
    210                 };
    211             } else {
    212                 $return = undef;
    213             }
    214 
    215             if ( defined $thisparser->{local}{name}{ $item{metadata_name} } ) {
    216                 $return->{multi}++
    217                     if $thisparser->{local}{name}{ $item{metadata_name} } =~ /MULTI/;
    218             } else {
    219                 $thisparser->{local}{name}{ $item{metadata_name} }++;
    220             }
    221         }
    222     | <error?:bad METADATA syntax: $text> <reject>
    223 
    224 comment_line:
    225     <skip:'[ \t\r]*'> comment(?) "\n"
    226         {{ class   => 'comment_line' }}
    227 
    228 time:
    229     <skip:'[ \t\r]*'> name ttype <matchrule:$item{ttype}> comment(?) "\n"
    230         {
    231             use DateTime::Format::ISO8601;
    232 
    233             $return = {
    234                 class   => 'time',
    235                 name    => $item{name},
    236                 type    => $item{ttype},
    237                 value   => $item[4],
    238             };
    239 
    240             $return->{comment} = $item{'comment(?)'}[0]
    241                 if $item{'comment(?)'}[0];
    242         }
    243 
    244 typedef_declare:
    245     <skip:'[ \t\r]*'> 'TYPE' <commit> name name(s) comment(?) "\n"
    246         {
    247             if (defined $thisparser->{local}{typedef}{ $item{name} }) {
    248                 carp "refinition of TYPE $item{name}";   
    249                 $return = undef;
    250             } else {
    251 
    252                 my $type = {
    253                     class   => 'typedef_declare',
    254                     name    => $item{name},
    255                     fields  => $item{'name(s)'},
    256                     length  => scalar @{ $item{'name(s)'} },
    257                 };
    258 
    259                 $thisparser->{local}{typedef}{ $item{name} } = $type;
    260 
    261                 # don't return anything in the parse tree
    262                 $return = { class => 'comment_line' };
    263             }
    264         }
    265     | <error?:redefinition of TYPE> <reject>
    266 
    267 typedef:
    268     <skip:'[ \t\r]*'> name typedef_type <commit> word(s) comment(?) "\n"
    269         {
    270             my $type = $thisparser->{local}{typedef}{ $item{typedef_type} };
    271 
    272             unless ( scalar @{ $item{'word(s)'} } == $type->{length} ) {
    273                 my $expect = $type->{length};
    274                 my $got = scalar @{ $item{'word(s)'} };
    275                 carp "\"$item{name} $item{typedef_type}\""
    276                     . " does not have enough fields, epected: $expect, got: $got";
    277                 $return = undef;
    278             } else {
    279                 my @md;
    280                 my $i = 0;
    281                 foreach my $name ( @{ $type->{fields} } ) {
    282                     push @md, {
    283                         name    => $name,
    284                         class   => 'scalar',
    285                         type    => 'STR',
    286                         value   => $item{'word(s)'}[$i],
    287                     };
    288 
    289                     $i++;
    290                 }
    291 
    292                 $return = {
    293                     class   => 'metadata',
    294                     name    => $item{name},
    295                     value   => \@md,
    296                 };
    297             }
    298         }
    299     | <error?:'TYPE' does not have enough parameters: $text> <reject>
    300 
    301 
    302 typedef_type: name
    303         {
    304             if ( ! defined $thisparser->{local}{typedef}{ $item{name} } ) {
    305                 $return = undef;
    306             } else {
    307                 $return = $item{name};
    308             }
    309         }
    310 
    311 metadata_name:
    312     <skip:'[ \t\r]*'> name /METADATA/i comment(?) "\n"
    313         { $item{name} }
    314    
    315 metadata_end:
    316      <skip:'[ \t\r]*'> /END/i comment(?) "\n"
    317 
    318 comment:
    319     '#' to_end_of_line
    320         { $item{to_end_of_line} }
    321 
    322 vname:
    323     '@' name
    324         { $item{name} }
    325 
    326 name:
    327     /[a-z][.\w-]*/i
    328         {
    329             if ( $item[1] =~ /^(METADATA|END|TYPE)$/i ) {
    330                 $return = undef;
    331             } else {
    332                 $return = $item[1];
    333             }
    334         }
    335 
    336 # 'STR' seems to be the most common type, trying to match it first is a simple
    337 # optimization.
    338 type:
    339     'STR'
    340     | 'STRING'
    341     | vtype
    342 
    343 vtype:
    344     'S8'
    345     | 'S16'
    346     | 'S32'
    347     | 'S64'
    348     | 'U8'
    349     | 'U16'
    350     | 'U32'
    351     | 'U64'
    352     | 'F32'
    353     | 'F64'
    354     | 'C32'
    355     | 'C64'
    356     | 'BOOL'
    357 
    358 ttype:
    359     'UTC'
    360     | 'UT1'
    361     | 'TAI'
    362     | 'TT'
    363 
    364 S8: int
    365 S16: int
    366 S32: int
    367 S64: int
    368 U8 : int
    369 U16: int
    370 U32: int
    371 U64: int
    372 F32: float
    373 F64: float
    374 C32: float
    375 C64: float
    376 BOOL: bool
    377 STR: string
    378 STRING: string
    379 
    380 vvalue:
    381     _vvalue[%arg](s)
    382         { [ map { @$_ } @{$item[1]} ] }
    383 
    384 tvalue:
    385     iso8601
    386     | epoch
    387 
    388 # backtracking optimization
    389 _vvalue:
    390     <matchrule:$arg[0]> vector_sep(?)
    391         { [ $item[1] ] }
    392 
    393 vector_sep:
    394     /,|\s+/
    395 
    396 int:
    397     # $RE{num}{int} from Regexp::Common::number
    398     /(?:(?:[+-]?)(?:[0-9]+))/
    399 
    400 float:
    401     # based on $RE{num}{real} from Regexp::Common::number
    402     /(?:(?i)(?:[+-]?)(?:(?=[0-9]|[.])(?:[0-9]*)(?:(?:[.])(?:[0-9]{0,}))?)(?:(?:[Ee])(?:(?:[+-]?)(?:[0-9]+))|))/
    403 
    404 bool:
    405     /[tf]/i
    406         { $item[1] =~ /t/i ? 1 : 0 }
    407 
    408 string:
    409     /(?:\S[^#\n]*)?[^#\n ]/
    410 
    411 word:
    412     /(?:[^#\s\n]+)/
    413 
    414 to_end_of_line:
    415     /[^\n]*/
    416         {
    417             my $comment = $item[1];
    418             # remove leading whitespace
    419             $comment =~ s/^\s+//;
    420             # remove trailing whitespace
    421             $comment =~ s/\s+$//;
    422 
    423             $return = $comment;
    424         }
    425 
    426 UTC:
    427     iso8601
    428     | utc_epoch
    429 
    430 UT1:
    431     iso8601
    432     | epoch
    433 
    434 TAI:
    435     iso8601
    436     | epoch
    437 
    438 TT:
    439     iso8601
    440     | epoch
    441 
    442 iso8601:
    443     # based on code from DateTime::Format::ISO8601
    444     / (\d{4}) - (\d\d) - (\d\d) T (\d\d) : (\d\d) : (\d\d) Z /x
    445         { DateTime::Format::ISO8601->parse_datetime( $item[1] ) }
    446 
    447 utc_epoch:
    448     / (-?\d{1,19}) \s*,\s* (\d{1,9}) (?:\s*,\s* (\d))? /x
    449         {{
    450             sec         => $1,
    451             nsec        => $2,
    452             leapsecond  => $3,
    453         }}
    454 
    455 epoch:
    456     / (-?\d{1,19}) \s*,\s* (\d{1,9}) /x
    457         {{
    458             sec     => $1,
    459             nsec    => $2,
    460         }}
    461 
    462 eofile:
    463     /^\z/
     112__END__
Note: See TracChangeset for help on using the changeset viewer.