IPP Software Navigation Tools IPP Links Communication Pan-STARRS Links

Changeset 3480


Ignore:
Timestamp:
Mar 22, 2005, 4:00:16 PM (21 years ago)
Author:
jhoblitt
Message:

removed _merge_multi_symbols() & _merge_duplicates() (breaks stuff)
add time support
add scoping rules
stop croaking from grammar
major grammar cleanup

File:
1 edited

Legend:

Unmodified
Added
Removed

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

    r3457 r3480  
    11# Copyright (c) 2005  Joshua Hoblitt
    22#
    3 # $Id: Config.pm,v 1.8 2005-03-19 01:01:46 jhoblitt Exp $
     3# $Id: Config.pm,v 1.9 2005-03-23 02:00:16 jhoblitt Exp $
    44
    55package PS::IPP::Metadata::Config;
    … …  
    4646
    4747    #print Dumper($tree);
    48    
    49     # handle multi-symbol lines
    50     $self->_merge_multi_symbols( $tree ) or return undef;
    51 
    52     # look for duplicate names, there should be none after processing the
    53     # multi-symbols
    54     $self->_merge_duplicates( $tree ) or return undef;
    5548
    5649    return $tree;
    5750}
    5851
    59 sub _merge_multi_symbols {
    60     my ( $self, $tree ) = @_;
    61 
    62     # list of valid multi-symbols
    63     my %multis;
    64 
    65     # Iteratate through the parse tree looking for multi-symbol
    66     # declarations.  This is done in a single pass so multi-symbols must
    67     # actually be 'declared' before any member elements appear. 
    68     for (my $i = 0; $i < @{$tree}; $i++) {
    69         my $elem = $tree->[$i];
    70 
    71         # recurse through nested metadata
    72         if ( $elem->{class} eq "metadata" ) {
    73             $self->_merge_multi_symbols( $elem->{value} );
    74         }
    75 
    76         # stop if the prevous pass removed the last element and called redo
    77         last unless defined $elem;
    78 
    79         if ( $elem->{class} eq "multi_symbol" ) {
    80             # construct a valid parse spec
    81             my $node = {
    82                 class   => 'vector',
    83                 name    => $elem->{name},
    84                 type    => 'STR',   # only strings are allowed
    85                 value   => [],
    86             };
    87 
    88             # add to list of valid multi-symbols
    89             $multis{ $elem->{name} } = $node;
    90 
    91             # delete multi-symbol hash from the parse tree and replace it
    92             splice @$tree, $i, 1, $node;
    93 
    94             next;
    95         }
    96 
    97         if ( my $node = $multis{ $elem->{name} } ) {
    98             if ( ! $elem->{type} =~ /STR|STRING/ ) {
    99                 carp "multi-symbol element, ",
    100                      $elem->{name},
    101                      "has type of ",
    102                      $elem->{type},
    103                      "instead of STR|STRING\n";
    104                 return undef;
    105             }
    106 
    107             # add element value to the appropriate multi-symbol element
    108             my $vec = $node->{value};
    109             push( @$vec, $elem->{value} );
    110 
    111             # delete element from array
    112             splice @$tree, $i, 1;
    113 
    114             # the list just got shorter by one element so we don't want to
    115             # increment the cursor
    116             redo;
    117         }
    118     }
    119 
    120     return 1;
    121 }
    122 
    123 sub _merge_duplicates {
    124     my ( $self, $tree ) = @_;
    125 
    126     # encountered names
    127     my %names;
    128 
    129     # Iteratate through the parse tree looking for duplicate declarations and
    130     # resolving them by discarding elements according to the value of 'overwrite'.
    131     for (my $i = 0; $i < @{$tree}; $i++) {
    132         my $elem = $tree->[$i];
    133 
    134         # recurse through nested metadata
    135         if ( $elem->{class} eq "metadata" ) {
    136             $self->_merge_duplicates( $elem->{value} );
    137         }
    138 
    139         if ( exists $names{ $elem->{name} } ) {
    140             carp "duplicate element name, ", $elem->{name}, "\n";
    141 
    142             if ( $self->{overwrite} ) {
    143                 # remove the previous occurance
    144                 splice @{$tree}, $names{ $elem->{name} }, 1;
    145             } else {
    146                 # remove the current occurance
    147                 splice @{$tree}, $i, 1;
    148             }
    149         }
    150 
    151         # add element name and location to record of previously seen names
    152         $names{ $elem->{name} } = $i;
    153     }
    154 
    155     return 1;
    156 }
    157 
    158521;
    15953
    … …  
    16256{
    16357    use strict;
    164     use warnings FATAL => qw( all );
    165 
    166     use Carp qw( croak );
     58
     59    use Carp qw( carp );
     60
     61    our @scope_stack;
    16762}
    16863
    169 startrule: grammar
     64startrule: grammar eofile
     65    { $item{grammar} }
    17066
    17167grammar:
    17268    statement(s)
    173         {[ grep $_->{class} !~ /(comment_line|blank_line)/, @{$item[1]} ]}
     69        {
     70            $thisparser->{local} = pop @scope_stack;
     71            [ grep $_->{class} !~ /(comment_line|blank_line)/, @{$item[1]} ];
     72        }
    17473
    17574statement:
    17675    scalar
    17776    | vector
    178     | multi_symbol
     77    | multi_declare
    17978    | comment_line
    18079    | metadata
    18180    | blank_line
     81    | time
    18282    | typedef_declare
    18383    | typedef
     84    | <error:unmatched statement: $text>
    18485
    18586scalar:
    186     <skip:'[ \t\r]*'> name type value comment "\n"
    187         {{
    188             class   => 'scalar',
    189             name    => $item{name},
    190             type    => $item{type},
    191             value   => $item{value},
    192             comment => $item{comment}
    193          }}
    194     | <skip:'[ \t\r]*'> name type value "\n"
    195         {{
    196             class   => 'scalar',
    197             name    => $item{name},
    198             type    => $item{type},
    199             value   => $item{value},
    200         }}
     87    <skip:'[ \t\r]*'> name type value comment(?) "\n"
     88        {
     89            $return = {
     90                class   => 'scalar',
     91                name    => $item{name},
     92                type    => $item{type},
     93                value   => $item{value},
     94            };
     95
     96            $return->{comment} = $item{'comment(?)'}[0]
     97                if $item{'comment(?)'}[0];
     98        }
    20199
    202100vector:
    203      <skip:'[ \t\r]*'> vname vtype vvalue comment "\n"
    204         {{
    205 
    206             class   => 'vector',
    207             name    => $item{vname},
    208             type    => $item{vtype},
    209             value   => $item{vvalue},
    210             comment => $item{comment}
    211          }}
    212     | <skip:'[ \t\r]*'> vname vtype vvalue "\n"
    213         {{
    214             class   => 'vector',
    215             name    => $item{vname},
    216             type    => $item{vtype},
    217             value   => $item{vvalue},
    218          }}
    219 
    220 multi_symbol:
     101     <skip:'[ \t\r]*'> vname vtype vvalue comment(?) "\n"
     102        {
     103            $return = {
     104                class   => 'vector',
     105                name    => $item{vname},
     106                type    => $item{vtype},
     107                value   => $item{vvalue},
     108                comment => $item{comment}
     109            };
     110
     111            $return->{comment} = $item{'comment(?)'}[0]
     112                if $item{'comment(?)'}[0];
     113        }
     114
     115multi_declare:
    221116    <skip:'[ \t\r]*'> name '*' to_end_of_line "\n"
    222117        {{
    223             class   => 'multi_symbol',
    224             name    => $item{name},
    225             comment => $item{to_end_of_line},
     118            class   => 'blank_line',
    226119        }}
    227120
    … …  
    234127
    235128metadata:
    236     metadata_name grammar metadata_end
    237         {{
    238             class   => 'metadata',
    239             name    => $item{metadata_name},
    240             value   => $item{grammar},
    241          }}
     129    metadata_name <commit>
     130    { push @scope_stack, $thisparser->{local}; $thisparser->{local} = {} }
     131    grammar
     132    metadata_end
     133        {
     134            my $text = $item[2];
     135           
     136            if ( defined( $text ) ) {
     137                $return = {
     138                    class   => 'metadata',
     139                    name    => $item{metadata_name},
     140                    value   => $item{grammar},
     141                };
     142            } else {
     143                $return = undef;
     144            }
     145        }
     146    | <error?:bad METADATA syntax: $text> <reject>
    242147
    243148blank_line:
    … …  
    247152        }}
    248153
     154time:
     155    <skip:'[ \t\r]*'> name ttype <matchrule:$item{ttype}> comment(?) "\n"
     156        {
     157            use DateTime::Format::ISO8601;
     158
     159            $return = {
     160                class   => 'time',
     161                name    => $item{name},
     162                type    => $item{ttype},
     163                value   => $item[4],
     164            };
     165
     166            $return->{comment} = $item{'comment(?)'}[0]
     167                if $item{'comment(?)'}[0];
     168        }
     169
    249170typedef_declare:
    250171    <skip:'[ \t\r]*'> 'TYPE' <commit> name name(s) comment(?) "\n"
    251172        {
    252             use Carp;
    253 
    254173            if (defined $thisparser->{local}{typedef}{ $item{name} }) {
    255                 croak "refinition of TYPE $item{name}";   
    256             }
    257 
    258             my $type = {
    259                 class   => 'typedef_declare',
    260                 name    => $item{name},
    261                 fields  => $item{'name(s)'},
    262                 length  => scalar @{ $item{'name(s)'} },
    263             };
    264 
    265             $thisparser->{local}{typedef}{ $item{name} } = $type;
    266 
    267             # don't return anything in the parse tree
    268             $return = { class => 'blank_line' };
    269         }
     174                carp "refinition of TYPE $item{name}";   
     175                $return = undef;
     176            } else {
     177
     178                my $type = {
     179                    class   => 'typedef_declare',
     180                    name    => $item{name},
     181                    fields  => $item{'name(s)'},
     182                    length  => scalar @{ $item{'name(s)'} },
     183                };
     184
     185                $thisparser->{local}{typedef}{ $item{name} } = $type;
     186
     187                # don't return anything in the parse tree
     188                $return = { class => 'blank_line' };
     189            }
     190        }
     191    | <error?:redefinition of TYPE> <reject>
    270192
    271193typedef:
    272     <skip:'[ \t\r]*'> name typedef_type name(s) comment(?) "\n"
     194    <skip:'[ \t\r]*'> name typedef_type <commit> name(s) comment(?) "\n"
    273195        {
    274196            my $type = $thisparser->{local}{typedef}{ $item{typedef_type} };
    275197
    276198            unless ( scalar @{ $item{'name(s)'} } == $type->{length} ) {
    277                 croak "\"$item{name} $item{typedef_type}\""
     199                carp "\"$item{name} $item{typedef_type}\""
    278200                    . " does not have enough fields";
    279             }
    280 
    281             my @md;
    282             my $i = 0;
    283             foreach my $name ( @{ $type->{fields} } ) {
    284                 push @md, {
    285                     name    => $name,
    286                     class   => 'scalar',
    287                     type    => 'STR',
    288                     value   => $item{'name(s)'}[$i],
     201                $return = undef;
     202            } else {
     203                my @md;
     204                my $i = 0;
     205                foreach my $name ( @{ $type->{fields} } ) {
     206                    push @md, {
     207                        name    => $name,
     208                        class   => 'scalar',
     209                        type    => 'STR',
     210                        value   => $item{'name(s)'}[$i],
     211                    };
     212
     213                    $i++;
     214                }
     215
     216                $return = {
     217                    class   => 'metadata',
     218                    name    => $item{name},
     219                    value   => \@md,
    289220                };
    290 
    291                 $i++;
    292             }
    293 
    294             $return = {
    295                 class   => 'metadata',
    296                 name    => $item{name},
    297                 value   => \@md,
    298             };
    299         }
     221            }
     222        }
     223    | <error?:'TYPE' does not have enough parameters: $text> <reject>
     224
    300225
    301226typedef_type: name
    302227        {
    303             use Carp;
    304 
    305228            if ( ! defined $thisparser->{local}{typedef}{ $item{name} } ) {
    306                 croak "missing TYPE defintion for $item{name}";
    307             }
    308             $return = $item{name};
     229                $return = undef;
     230            } else {
     231                $return = $item{name};
     232            }
    309233        }
    310234
    … …  
    352276    | 'BOOL'
    353277
     278ttype:
     279    'UTC'
     280    | 'UT1'
     281    | 'TAI'
     282    | 'TT'
     283
    354284value:
    355285    primitive | string
    … …  
    359289    _vvalue(s)
    360290        { [ map { @$_ } @{$item[1]} ] }
     291
     292tvalue:
     293    iso8601
     294    | epoch
    361295
    362296# backtracking optimization
    … …  
    384318
    385319string:
    386     /\S[^#\n]*/
     320    /(?:\S[^#\n]*)?[^#\n ]/
    387321
    388322to_end_of_line:
    389323    /[^\n]*/
     324        {
     325            my $comment = $item[1];
     326            # remove leading whitespace
     327            $comment =~ s/^\s+//;
     328            # remove trailing whitespace
     329            $comment =~ s/\s+$//;
     330
     331            $return = $comment;
     332        }
     333
     334UTC:
     335    iso8601
     336    | utc_epoch
     337
     338UT1:
     339    iso8601
     340    | epoch
     341
     342TAI:
     343    iso8601
     344    | epoch
     345
     346TT:
     347    iso8601
     348    | epoch
     349
     350iso8601:
     351    # based on code from DateTime::Format::ISO8601
     352    / (\d{4}) - (\d\d) - (\d\d) T (\d\d) : (\d\d) : (\d\d) Z /x
     353        { DateTime::Format::ISO8601->parse_datetime( $item[1] ) }
     354
     355utc_epoch:
     356    / (-?\d{1,19}) \s*,\s* (\d{1,9}) (?:\s*,\s* (\d))? /x
     357        {{
     358            sec         => $1,
     359            nsec        => $2,
     360            leapsecond  => $3,
     361        }}
     362
     363epoch:
     364    / (-?\d{1,19}) \s*,\s* (\d{1,9}) /x
     365        {{
     366            sec     => $1,
     367            nsec    => $2,
     368        }}
     369
     370eofile:
     371    /^\z/
Note: See TracChangeset for help on using the changeset viewer.