Index: /trunk/PS-IPP-Metadata-Config/lib/PS/IPP/Metadata/Config.pm =================================================================== --- /trunk/PS-IPP-Metadata-Config/lib/PS/IPP/Metadata/Config.pm (revision 3479) +++ /trunk/PS-IPP-Metadata-Config/lib/PS/IPP/Metadata/Config.pm (revision 3480) @@ -1,5 +1,5 @@ # Copyright (c) 2005 Joshua Hoblitt # -# $Id: Config.pm,v 1.8 2005-03-19 01:01:46 jhoblitt Exp $ +# $Id: Config.pm,v 1.9 2005-03-23 02:00:16 jhoblitt Exp $ package PS::IPP::Metadata::Config; @@ -46,114 +46,8 @@ #print Dumper($tree); - - # handle multi-symbol lines - $self->_merge_multi_symbols( $tree ) or return undef; - - # look for duplicate names, there should be none after processing the - # multi-symbols - $self->_merge_duplicates( $tree ) or return undef; return $tree; } -sub _merge_multi_symbols { - my ( $self, $tree ) = @_; - - # list of valid multi-symbols - my %multis; - - # Iteratate through the parse tree looking for multi-symbol - # declarations. This is done in a single pass so multi-symbols must - # actually be 'declared' before any member elements appear. - for (my $i = 0; $i < @{$tree}; $i++) { - my $elem = $tree->[$i]; - - # recurse through nested metadata - if ( $elem->{class} eq "metadata" ) { - $self->_merge_multi_symbols( $elem->{value} ); - } - - # stop if the prevous pass removed the last element and called redo - last unless defined $elem; - - if ( $elem->{class} eq "multi_symbol" ) { - # construct a valid parse spec - my $node = { - class => 'vector', - name => $elem->{name}, - type => 'STR', # only strings are allowed - value => [], - }; - - # add to list of valid multi-symbols - $multis{ $elem->{name} } = $node; - - # delete multi-symbol hash from the parse tree and replace it - splice @$tree, $i, 1, $node; - - next; - } - - if ( my $node = $multis{ $elem->{name} } ) { - if ( ! $elem->{type} =~ /STR|STRING/ ) { - carp "multi-symbol element, ", - $elem->{name}, - "has type of ", - $elem->{type}, - "instead of STR|STRING\n"; - return undef; - } - - # add element value to the appropriate multi-symbol element - my $vec = $node->{value}; - push( @$vec, $elem->{value} ); - - # delete element from array - splice @$tree, $i, 1; - - # the list just got shorter by one element so we don't want to - # increment the cursor - redo; - } - } - - return 1; -} - -sub _merge_duplicates { - my ( $self, $tree ) = @_; - - # encountered names - my %names; - - # Iteratate through the parse tree looking for duplicate declarations and - # resolving them by discarding elements according to the value of 'overwrite'. - for (my $i = 0; $i < @{$tree}; $i++) { - my $elem = $tree->[$i]; - - # recurse through nested metadata - if ( $elem->{class} eq "metadata" ) { - $self->_merge_duplicates( $elem->{value} ); - } - - if ( exists $names{ $elem->{name} } ) { - carp "duplicate element name, ", $elem->{name}, "\n"; - - if ( $self->{overwrite} ) { - # remove the previous occurance - splice @{$tree}, $names{ $elem->{name} }, 1; - } else { - # remove the current occurance - splice @{$tree}, $i, 1; - } - } - - # add element name and location to record of previously seen names - $names{ $elem->{name} } = $i; - } - - return 1; -} - 1; @@ -162,66 +56,65 @@ { use strict; - use warnings FATAL => qw( all ); - - use Carp qw( croak ); + + use Carp qw( carp ); + + our @scope_stack; } -startrule: grammar +startrule: grammar eofile + { $item{grammar} } grammar: statement(s) - {[ grep $_->{class} !~ /(comment_line|blank_line)/, @{$item[1]} ]} + { + $thisparser->{local} = pop @scope_stack; + [ grep $_->{class} !~ /(comment_line|blank_line)/, @{$item[1]} ]; + } statement: scalar | vector - | multi_symbol + | multi_declare | comment_line | metadata | blank_line + | time | typedef_declare | typedef + | scalar: - name type value comment "\n" - {{ - class => 'scalar', - name => $item{name}, - type => $item{type}, - value => $item{value}, - comment => $item{comment} - }} - | name type value "\n" - {{ - class => 'scalar', - name => $item{name}, - type => $item{type}, - value => $item{value}, - }} + name type value comment(?) "\n" + { + $return = { + class => 'scalar', + name => $item{name}, + type => $item{type}, + value => $item{value}, + }; + + $return->{comment} = $item{'comment(?)'}[0] + if $item{'comment(?)'}[0]; + } vector: - vname vtype vvalue comment "\n" - {{ - - class => 'vector', - name => $item{vname}, - type => $item{vtype}, - value => $item{vvalue}, - comment => $item{comment} - }} - | vname vtype vvalue "\n" - {{ - class => 'vector', - name => $item{vname}, - type => $item{vtype}, - value => $item{vvalue}, - }} - -multi_symbol: + vname vtype vvalue comment(?) "\n" + { + $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 '*' to_end_of_line "\n" {{ - class => 'multi_symbol', - name => $item{name}, - comment => $item{to_end_of_line}, + class => 'blank_line', }} @@ -234,10 +127,22 @@ metadata: - metadata_name grammar metadata_end - {{ - class => 'metadata', - name => $item{metadata_name}, - value => $item{grammar}, - }} + 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; + } + } + | blank_line: @@ -247,64 +152,83 @@ }} +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" { - use Carp; - if (defined $thisparser->{local}{typedef}{ $item{name} }) { - croak "refinition of TYPE $item{name}"; - } - - 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 => 'blank_line' }; - } + 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 => 'blank_line' }; + } + } + | typedef: - name typedef_type name(s) comment(?) "\n" + name typedef_type name(s) comment(?) "\n" { my $type = $thisparser->{local}{typedef}{ $item{typedef_type} }; unless ( scalar @{ $item{'name(s)'} } == $type->{length} ) { - croak "\"$item{name} $item{typedef_type}\"" + carp "\"$item{name} $item{typedef_type}\"" . " does not have enough fields"; - } - - my @md; - my $i = 0; - foreach my $name ( @{ $type->{fields} } ) { - push @md, { - name => $name, - class => 'scalar', - type => 'STR', - value => $item{'name(s)'}[$i], + $return = undef; + } else { + my @md; + my $i = 0; + foreach my $name ( @{ $type->{fields} } ) { + push @md, { + name => $name, + class => 'scalar', + type => 'STR', + value => $item{'name(s)'}[$i], + }; + + $i++; + } + + $return = { + class => 'metadata', + name => $item{name}, + value => \@md, }; - - $i++; - } - - $return = { - class => 'metadata', - name => $item{name}, - value => \@md, - }; - } + } + } + | + typedef_type: name { - use Carp; - if ( ! defined $thisparser->{local}{typedef}{ $item{name} } ) { - croak "missing TYPE defintion for $item{name}"; - } - $return = $item{name}; + $return = undef; + } else { + $return = $item{name}; + } } @@ -352,4 +276,10 @@ | 'BOOL' +ttype: + 'UTC' + | 'UT1' + | 'TAI' + | 'TT' + value: primitive | string @@ -359,4 +289,8 @@ _vvalue(s) { [ map { @$_ } @{$item[1]} ] } + +tvalue: + iso8601 + | epoch # backtracking optimization @@ -384,6 +318,54 @@ string: - /\S[^#\n]*/ + /(?:\S[^#\n]*)?[^#\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/