?????????? ????????? - ??????????????? - /home/agenciai/public_html/cd38d8/inc.zip
???????
PK � �[�\�� � Pegex.pmnu �[��� use strict; use warnings; package Pegex; our $VERSION = '0.57'; use Pegex::Parser; use Exporter 'import'; our @EXPORT = 'pegex'; sub pegex { my ($grammar, $receiver) = @_; die "Argument 'grammar' required in function 'pegex'" unless $grammar; if (not ref $grammar or $grammar->isa('Pegex::Input')) { require Pegex::Grammar; $grammar = Pegex::Grammar->new(text => $grammar), } if (not defined $receiver) { require Pegex::Tree::Wrap; $receiver = Pegex::Tree::Wrap->new; } elsif (not ref $receiver) { eval "require $receiver; 1"; $receiver = $receiver->new; } return Pegex::Parser->new( grammar => $grammar, receiver => $receiver, ); } 1; PK � �[����7 7 Pegex/Tree.pmnu �[��� package Pegex::Tree; use Pegex::Base; extends 'Pegex::Receiver'; sub gotrule { my $self = shift; @_ || return (); return {$self->{parser}{rule} => $_[0]} if $self->{parser}{parent}{-wrap}; return $_[0]; } sub final { my $self = shift; return(shift) if @_; return []; } 1; PK � �[��؈� � Pegex/Parser.pmnu �[��� package Pegex::Parser; use Pegex::Base; use Pegex::Input; use Pegex::Optimizer; use Scalar::Util; has grammar => (required => 1); has receiver => (); has input => (); has debug => ( exists($ENV{PERL_PEGEX_DEBUG}) ? $ENV{PERL_PEGEX_DEBUG} : defined($Pegex::Parser::Debug) ? $Pegex::Parser::Debug : 0 ); sub BUILD { my ($self) = @_; $self->{throw_on_error} ||= 1; # $self->{rule} = undef; # $self->{parent} = undef; # $self->{error} = undef; # $self->{position} = undef; # $self->{farthest} = undef; } # XXX Add an optional $position argument. Default to 0. This is the position # to start parsing. Set position and farthest below to this value. Allows for # sub-parsing. Need to somehow return the finishing position of a subparse. # Maybe this all goes in a subparse() method. sub parse { my ($self, $input, $start) = @_; $start =~ s/-/_/g if $start; $self->{position} = 0; $self->{farthest} = 0; $self->{input} = (not ref $input) ? Pegex::Input->new(string => $input) : $input; $self->{input}->open unless $self->{input}{_is_open}; $self->{buffer} = $self->{input}->read; die "No 'grammar'. Can't parse" unless $self->{grammar}; $self->{grammar}{tree} ||= $self->{grammar}->make_tree; my $start_rule_ref = $start || $self->{grammar}{tree}{'+toprule'} || $self->{grammar}{tree}{'TOP'} & 'TOP' or die "No starting rule for Pegex::Parser::parse"; die "No 'receiver'. Can't parse" unless $self->{receiver}; my $optimizer = Pegex::Optimizer->new( parser => $self, grammar => $self->{grammar}, receiver => $self->{receiver}, ); $optimizer->optimize_grammar($start_rule_ref); # Add circular ref and weaken it. $self->{receiver}{parser} = $self; Scalar::Util::weaken($self->{receiver}{parser}); if ($self->{receiver}->can("initial")) { $self->{rule} = $start_rule_ref; $self->{parent} = {}; $self->{receiver}->initial(); } my $match = $self->debug ? do { my $method = $optimizer->make_trace_wrapper(\&match_ref); $self->$method($start_rule_ref, {'+asr' => 0}); } : $self->match_ref($start_rule_ref, {}); $self->{input}->close; if (not $match or $self->{position} < length ${$self->{buffer}}) { $self->throw_error("Parse document failed for some reason"); return; # In case $self->throw_on_error is off } if ($self->{receiver}->can("final")) { $self->{rule} = $start_rule_ref; $self->{parent} = {}; $match = [ $self->{receiver}->final(@$match) ]; } $match->[0]; } sub match_next { my ($self, $next) = @_; my ($rule, $method, $kind, $min, $max, $assertion) = @{$next}{'rule', 'method', 'kind', '+min', '+max', '+asr'}; my ($position, $match, $count) = ($self->{position}, [], 0); while (my $return = $method->($self, $rule, $next)) { $position = $self->{position} unless $assertion; $count++; push @$match, @$return; last if $max == 1; } if (not $count and $min == 0 and $kind eq 'all') { $match = [[]]; } if ($max != 1) { if ($next->{-flat}) { $match = [ map { (ref($_) eq 'ARRAY') ? (@$_) : ($_) } @$match ]; } else { $match = [$match] } $self->{farthest} = $position if ($self->{position} = $position) > $self->{farthest}; } my $result = ($count >= $min and (not $max or $count <= $max)) ^ ($assertion == -1); if (not($result) or $assertion) { $self->{farthest} = $position if ($self->{position} = $position) > $self->{farthest}; } ($result ? $next->{'-skip'} ? [] : $match : 0); } sub match_rule { my ($self, $position, $match) = (@_, []); $self->{position} = $position; $self->{farthest} = $position if $position > $self->{farthest}; $match = [ $match ] if @$match > 1; my ($ref, $parent) = @{$self}{'rule', 'parent'}; my $rule = $self->{grammar}{tree}{$ref} or die "No rule defined for '$ref'"; [ $rule->{action}->($self->{receiver}, @$match) ]; } sub match_ref { my ($self, $ref, $parent) = @_; my $rule = $self->{grammar}{tree}{$ref} or die "No rule defined for '$ref'"; my $match = $self->match_next($rule) or return; return $Pegex::Constant::Dummy unless $rule->{action}; @{$self}{'rule', 'parent'} = ($ref, $parent); # XXX Possible API mismatch. # Not sure if we should "splat" the $match. [ $rule->{action}->($self->{receiver}, @$match) ]; } sub match_rgx { my ($self, $regexp) = @_; my $buffer = $self->{buffer}; pos($$buffer) = $self->{position}; $$buffer =~ /$regexp/g or return; $self->{position} = pos($$buffer); $self->{farthest} = $self->{position} if $self->{position} > $self->{farthest}; no strict 'refs'; my $captures = [ map $$_, 1..$#+ ]; $captures = [ $captures ] if $#+ > 1; return $captures; } sub match_all { my ($self, $list) = @_; my $position = $self->{position}; my $set = []; my $len = 0; for my $elem (@$list) { if (my $match = $self->match_next($elem)) { if (not ($elem->{'+asr'} or $elem->{'-skip'})) { push @$set, @$match; $len++; } } else { $self->{farthest} = $position if ($self->{position} = $position) > $self->{farthest}; return; } } $set = [ $set ] if $len > 1; return $set; } sub match_any { my ($self, $list) = @_; for my $elem (@$list) { if (my $match = $self->match_next($elem)) { return $match; } } return; } sub match_err { my ($self, $error) = @_; $self->throw_error($error); } sub trace { my ($self, $action) = @_; my $indent = ($action =~ /^try_/) ? 1 : 0; $self->{indent} ||= 0; $self->{indent}-- unless $indent; print STDERR ' ' x $self->{indent}; $self->{indent}++ if $indent; my $snippet = substr(${$self->{buffer}}, $self->{position}); $snippet = substr($snippet, 0, 30) . "..." if length $snippet > 30; $snippet =~ s/\n/\\n/g; print STDERR sprintf("%-30s", $action) . ($indent ? " >$snippet<\n" : "\n"); } sub throw_error { my ($self, $msg) = @_; $@ = $self->{error} = $self->format_error($msg); return undef unless $self->{throw_on_error}; require Carp; Carp::croak($self->{error}); } sub format_error { my ($self, $msg) = @_; my $buffer = $self->{buffer}; my $position = $self->{farthest}; my $real_pos = $self->{position}; my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1; my $column = $position - rindex($$buffer, "\n", $position); my $pretext = substr( $$buffer, $position < 50 ? 0 : $position - 50, $position < 50 ? $position : 50 ); my $context = substr($$buffer, $position, 50); $pretext =~ s/.*\n//gs; $context =~ s/\n/\\n/g; return <<"..."; Error parsing Pegex document: msg: $msg line: $line column: $column context: $pretext$context ${\ (' ' x (length($pretext) + 10) . '^')} position: $position ($real_pos pre-lookahead) ... } # TODO Move this to a Parser helper role/subclass sub line_column { my ($self, $position) = @_; $position ||= $self->{position}; my $buffer = $self->{buffer}; my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1; my $column = $position - rindex($$buffer, "\n", $position); return [$line, $position]; } # XXX Need to figure out what uses this. (sample.t) { package Pegex::Constant; our $Null = []; our $Dummy = []; } 1; PK � �[{ۣ��6 �6 Pegex/Bootstrap.pmnu �[��� package Pegex::Bootstrap; use Pegex::Base; extends 'Pegex::Compiler'; use Pegex::Grammar::Atoms; use Pegex::Pegex::AST; use Carp qw(carp confess croak); #------------------------------------------------------------------------------ # The grammar. A DSL data structure. Things with '=' are tokens. #------------------------------------------------------------------------------ has pointer => 0; has groups => []; has tokens => []; has ast => {}; has stack => []; has tree => {}; has grammar => { 'grammar' => [ '=pegex-start', 'meta-section', 'rule-section', '=pegex-end', ], 'meta-section' => 'meta-directive*', 'meta-directive' => [ '=directive-start', '=directive-value', '=directive-end', ], 'rule-section' => 'rule-definition*', 'rule-definition' => [ '=rule-start', '=rule-sep', 'rule-group', '=rule-end', ], 'rule-group' => 'any-group', 'any-group' => [ '=list-alt?', 'all-group', [ '=list-alt', 'all-group', '*', ], ], 'all-group' => 'rule-part+', 'rule-part' => [ 'rule-item', [ '=list-sep', 'rule-item', '?', ], ], 'rule-item' => [ '|', '=rule-reference', '=quoted-regex', 'regular-expression', 'bracketed-group', 'whitespace-token', '=error-message', ], 'regular-expression' => [ '=regex-start', '=!regex-end*', '=regex-end', ], 'bracketed-group' => [ '=group-start', 'rule-group', '=group-end', ], 'whitespace-token' => [ '|', '=whitespace-maybe', '=whitespace-must', ], }; #------------------------------------------------------------------------------ # Parser logic: #------------------------------------------------------------------------------ sub parse { my ($self, $grammar_text) = @_; $self->lex($grammar_text); # YYY $self->{tokens}; $self->{pointer} = 0; $self->{farthest} = 0; $self->{tree} = {}; $self->match_ref('grammar') || do { my $far = $self->{farthest}; my $tokens = $self->{tokens}; $far -= 4 if $far >= 4; WWW splice @$tokens, $far, 9; die "Bootstrap parse failed"; }; # XXX $self->{tree}; return $self; } sub match_next { my ($self, $next) = @_; my $method; if (ref $next) { $next = [@$next]; if ($next->[0] eq '|') { shift @$next; $method = 'match_any'; } else { $method = 'match_all'; } if ($next->[-1] =~ /^[\?\*\+]$/) { my $quant = pop @$next; return $self->match_times($quant, $method => $next); } else { return $self->$method($next); } } else { $method = ($next =~ s/^=//) ? 'match_token' : 'match_ref'; if ($next =~ s/([\?\*\+])$//) { return $self->match_times($1, $method => $next); } else { return $self->$method($next); } } } sub match_times { my ($self, $quantity, $method, @args) = @_; my ($min, $max) = $quantity eq '' ? (1, 1) : $quantity eq '?' ? (0, 1) : $quantity eq '*' ? (0, 0) : $quantity eq '+' ? (1, 0) : die "Bad quantity '$quantity'"; my $stop = $max || 9999; my $count = 0; my $pointer = $self->{pointer}; while ($stop-- and $self->$method(@args)) { $count++; } return 1 if $count >= $min and (not $max or $count <= $max); $self->{pointer} = $pointer; $self->{farthest} = $pointer if $pointer > $self->{farthest}; return; } sub match_any { my ($self, $any) = @_; my $pointer = $self->{pointer}; for (@$any) { if ($self->match_next($_)) { return 1; } } $self->{pointer} = $pointer; $self->{farthest} = $pointer if $pointer > $self->{farthest}; return; } sub match_all { my ($self, $all) = @_; my $pointer = $self->{pointer}; for (@$all) { if (not $self->match_next($_)) { $self->{pointer} = $pointer; $self->{farthest} = $pointer if $pointer > $self->{farthest}; return; } } return 1; } sub match_ref { my ($self, $ref) = @_; my $rule = $self->{grammar}->{$ref} or Carp::confess "Not a rule reference: '$ref'"; $self->match_next($rule); } sub match_token { my ($self, $token_want) = @_; my $not = ($token_want =~ s/^\!//) ? 1 : 0; return if $self->{pointer} >= @{$self->{tokens}}; my $token = $self->{tokens}[$self->{pointer}]; my $token_got = $token->[0]; if (($token_want eq $token_got) xor $not) { $token_got =~ s/-/_/g; my $method = "got_$token_got"; if ($self->can($method)) { # print "$method\n"; $self->$method($token); } $self->{pointer}++; return 1; } return; } #------------------------------------------------------------------------------ # Receiver/ast-generator methods: #------------------------------------------------------------------------------ sub got_directive_start { my ($self, $token) = @_; $self->{directive_name} = $token->[1]; } sub got_directive_value { my ($self, $token) = @_; my $value = $token->[1]; $value =~ s/\s+$//; my $name = $self->{directive_name}; if (my $old_value = $self->{tree}{"+$name"}) { if (not ref($old_value)) { $old_value = $self->{tree}{"+$name"} = [$old_value]; } push @$old_value, $value; } else { $self->{tree}{"+$name"} = $value; } } sub got_rule_start { my ($self, $token) = @_; $self->{stack} = []; my $rule_name = $token->[1]; $rule_name =~ s/-/_/g; $self->{rule_name} = $rule_name; $self->{tree}{'+toprule'} ||= $rule_name; $self->{groups} = [[0, ':']]; } sub got_rule_end { my ($self) = @_; $self->{tree}{$self->{rule_name}} = $self->group_ast; } sub got_group_start { my ($self, $token) = @_; push @{$self->{groups}}, [scalar(@{$self->{stack}}), $token->[1]]; } sub got_group_end { my ($self, $token) = @_; my $rule = $self->group_ast; Pegex::Pegex::AST::set_quantity($rule, $token->[1]); push @{$self->{stack}}, $rule; } sub got_list_alt { my ($self) = @_; push @{$self->{stack}}, '|'; } sub got_list_sep { my ($self, $token) = @_; push @{$self->{stack}}, $token->[1]; } sub got_rule_reference { my ($self, $token) = @_; my $name = $token->[2]; $name =~ s/-/_/g; $name =~ s/^<(.*)>$/$1/; my $rule = { '.ref' => $name }; Pegex::Pegex::AST::set_modifier($rule, $token->[1]); Pegex::Pegex::AST::set_quantity($rule, $token->[3]); push @{$self->{stack}}, $rule; } sub got_error_message { my ($self, $token) = @_; push @{$self->{stack}}, { '.err' => $token->[1] }; } sub got_whitespace_maybe { my ($self) = @_; $self->got_rule_reference(['whitespace-maybe', undef, '_', undef]); } sub got_whitespace_must { my ($self) = @_; $self->got_rule_reference(['whitespace-maybe', undef, '__', undef]); } sub got_quoted_regex { my ($self, $token) = @_; my $regex = $token->[1]; $regex =~ s/([^\w\`\%\:\<\/\,\=\;])/\\$1/g; push @{$self->{stack}}, { '.rgx' => $regex }; } sub got_regex_start { my ($self) = @_; push @{$self->{groups}}, [scalar(@{$self->{stack}}), '/']; } sub got_regex_end { my ($self) = @_; my $regex = join '', map { if (ref($_)) { my $part; if (defined($part = $_->{'.rgx'})) { $part; } elsif (defined($part = $_->{'.ref'})) { "<$part>"; } else { XXX $_; } } else { $_; } } splice(@{$self->{stack}}, (pop @{$self->{groups}})->[0]); $regex =~ s!\(([ism]?\:|\=|\!)!(?$1!g; push @{$self->{stack}}, {'.rgx' => $regex}; } sub got_regex_raw { my ($self, $token) = @_; push @{$self->{stack}}, $token->[1]; } #------------------------------------------------------------------------------ # Receiver helper methods: #------------------------------------------------------------------------------ sub group_ast { my ($self) = @_; my ($offset, $gmod) = @{pop @{$self->{groups}}}; $gmod ||= ''; my $rule = [splice(@{$self->{stack}}, $offset)]; for (my $i = 0; $i < @$rule-1; $i++) { if ($rule->[$i + 1] =~ /^%%?$/) { $rule->[$i] = Pegex::Pegex::AST::set_separator( $rule->[$i], splice @$rule, $i+1, 2 ); } } my $started = 0; for ( my $i = (@$rule and $rule->[0] eq '|') ? 1 : 0; $i < @$rule-1; $i++ ) { next if $rule->[$i] eq '|'; if ($rule->[$i+1] eq '|') { $i++; $started = 0; } else { $rule->[$i] = {'.all' => [$rule->[$i]]} unless $started++; push @{$rule->[$i]{'.all'}}, splice @$rule, $i+1, 1; $i-- } } if (grep {$_ eq '|'} @$rule) { $rule = [{'.any' => [ grep {$_ ne '|'} @$rule ]}]; } $rule = $rule->[0] if @$rule <= 1; Pegex::Pegex::AST::set_modifier($rule, $gmod) unless $gmod eq ':'; return $rule; } # DEBUG: wrap/trace parse methods: # for my $method (qw( # match_times match_next match_ref match_token match_any match_all # )) { # no strict 'refs'; # no warnings 'redefine'; # my $orig = \&$method; # *$method = sub { # my $self = shift; # my $args = join ', ', map { # ref($_) ? '[' . join(', ', @$_) . ']' : # length($_) ? $_ : "''" # } @_; # print "$method($args)\n"; # die if $main::x++ > 250; # $orig->($self, @_); # }; # } #------------------------------------------------------------------------------ # Lexer logic: #------------------------------------------------------------------------------ my $ALPHA = 'A-Za-z'; my $DIGIT = '0-9'; my $DASH = '\-'; my $SEMI = '\;'; my $UNDER = '\_'; my $HASH = '\#'; my $EOL = '\r?\n'; my $WORD = "$DASH$UNDER$ALPHA$DIGIT"; my $WS = "(?:[\ \t]|$HASH.*$EOL)"; my $MOD = '[\!\=\-\+\.]'; my $GMOD = '[\.\-]'; my $QUANT = '(?:[\?\*\+]|\d+(?:\+|\-\d+)?)'; my $NAME = "$UNDER?[$UNDER$ALPHA](?:[$WORD]*[$ALPHA$DIGIT])?"; # Repeated Rules: my $rem = [qr/\A(?:$WS+|$EOL+)/]; my $qr = [qr/\A\'((?:\\.|[^\'])*)\'/, 'quoted-regex']; # Lexer regex tree: has regexes => { pegex => [ [qr/\A%(grammar|version|extends|include)$WS+/, 'directive-start', 'directive'], [qr/\A($NAME)(?=$WS*\:)/, 'rule-start', 'rule'], $rem, [qr/\A\z/, 'pegex-end', 'end'], ], rule => [ [qr/\A(?:$SEMI$WS*$EOL?|\s*$EOL|)(?=$NAME$WS*\:|\z)/, 'rule-end', 'end'], [qr/\A\:/, 'rule-sep'], [qr/\A(?:\+|\~\~)(?=\s)/, 'whitespace-must'], [qr/\A(?:\-|\~)(?=\s)/, 'whitespace-maybe'], $qr, [qr/\A($MOD)?($NAME|<$NAME>)($QUANT)?(?!$WS*$NAME\:)/, 'rule-reference'], [qr/\A\//, 'regex-start', 'regex'], [qr/\A\`([^\`\n]*?)\`/, 'error-message'], [qr/\A($GMOD)?\(/, 'group-start'], [qr/\A\)($QUANT)?/, 'group-end'], [qr/\A\|/, 'list-alt'], [qr/\A(\%\%?)/, 'list-sep'], $rem, ], directive => [ [qr/\A(\S.*)/, 'directive-value'], [qr/\A$EOL/, 'directive-end', 'end'] ], regex => [ [qr/\A$WS+(?:\+|\~\~|\-\-)/, 'whitespace-must'], [qr/\A(?:\-|~)(?![-~])/, 'whitespace-maybe'], $qr, [qr/\A$WS+()($NAME|<$NAME>)/, 'rule-reference'], [qr/\A([^\s\'\/]+)/, 'regex-raw'], [qr/\A$WS+/], [qr/\A$EOL+/], [qr/\A\//, 'regex-end', 'end'], $rem, ], }; sub lex { my ($self, $grammar) = @_; my $tokens = $self->{tokens} = [['pegex-start']]; my $stack = ['pegex']; my $pos = 0; OUTER: while (1) { my $state = $stack->[-1]; my $set = $self->{regexes}->{$state} or die "Invalid state '$state'"; for my $entry (@$set) { my ($regex, $name, $scope) = @$entry; if (substr($grammar, $pos) =~ $regex) { $pos += length($&); if ($name) { no strict 'refs'; my @captures = map $$_, 1..$#+; pop @captures while @captures and not defined $captures[-1]; push @$tokens, [$name, @captures]; if ($scope) { if ($scope eq 'end') { pop @$stack; } else { push @$stack, $scope; # Hack to support /+ â¦/ if ($scope eq 'regex') { if (substr($grammar, $pos) =~ /\A\+(?=[\s\/])/) { $pos += length($&); push @$tokens, ['whitespace-must']; } } } } } last OUTER unless @$stack; next OUTER; } } my $text = substr($grammar, $pos, 50); $text =~ s/\n/\\n/g; WWW $tokens; die <<"..."; Failed to lex $state here-->$text ... } } 1; # vim: set lisp: PK � �[�ZT�� � Pegex/Receiver.pmnu �[��� package Pegex::Receiver; use Pegex::Base; has parser => (); # The parser object. sub rule { $_[0]->{parser}{rule} } # Flatten a structure of nested arrays into a single array in place. sub flatten { my ($self, $array, $times) = @_; $times = -1 unless defined $times; while ($times-- and grep {ref($_) eq 'ARRAY'} @$array) { @$array = map { (ref($_) eq 'ARRAY') ? @$_ : $_ } @$array; } return $array; } 1; PK � �[�� � � Pegex/Compiler.pmnu �[��� package Pegex::Compiler; use Pegex::Base; use Pegex::Parser; use Pegex::Pegex::Grammar; use Pegex::Pegex::AST; use Pegex::Grammar::Atoms; has tree => (); sub compile { my ($self, $grammar, @rules) = @_; # Global request to use the Pegex bootstrap compiler if ($Pegex::Bootstrap) { require Pegex::Bootstrap; $self = Pegex::Bootstrap->new; } @rules = map { s/-/_/g; $_ } @rules; $self->parse($grammar); $self->combinate(@rules); $self->native; return $self; } sub parse { my ($self, $input) = @_; my $parser = Pegex::Parser->new( grammar => Pegex::Pegex::Grammar->new, receiver => Pegex::Pegex::AST->new, ); $self->{tree} = $parser->parse($input); return $self; } #-----------------------------------------------------------------------------# # Combination #-----------------------------------------------------------------------------# has _tree => (); sub combinate { my ($self, @rule) = @_; if (not @rule) { if (my $rule = $self->{tree}->{'+toprule'}) { @rule = ($rule); } else { return $self; } } $self->{_tree} = { map {($_, $self->{tree}->{$_})} grep { /^\+/ } keys %{$self->{tree}} }; for my $rule (@rule) { $self->combinate_rule($rule); } $self->{tree} = $self->{_tree}; delete $self->{_tree}; return $self; } sub combinate_rule { my ($self, $rule) = @_; return if exists $self->{_tree}->{$rule}; my $object = $self->{_tree}->{$rule} = $self->{tree}->{$rule}; $self->combinate_object($object); } sub combinate_object { my ($self, $object) = @_; if (exists $object->{'.rgx'}) { $self->combinate_re($object); } elsif (exists $object->{'.ref'}) { my $rule = $object->{'.ref'}; if (exists $self->{tree}{$rule}) { $self->combinate_rule($rule); } else { if (my $regex = (Pegex::Grammar::Atoms::atoms)->{$rule}) { $self->{tree}{$rule} = { '.rgx' => $regex }; $self->combinate_rule($rule); } } } elsif (exists $object->{'.any'}) { for my $elem (@{$object->{'.any'}}) { $self->combinate_object($elem); } } elsif (exists $object->{'.all' }) { for my $elem (@{$object->{'.all'}}) { $self->combinate_object($elem); } } elsif (exists $object->{'.err' }) { } else { require YAML::XS; die "Can't combinate:\n" . YAML::XS::Dump($object); } } sub combinate_re { my ($self, $regexp) = @_; my $atoms = Pegex::Grammar::Atoms->atoms; my $re = $regexp->{'.rgx'}; while (1) { $re =~ s[(?<!\\)(~+)]['<ws' . length($1) . '>']ge; $re =~ s[<([\w\-]+)>][ (my $key = $1) =~ s/-/_/g; $self->{tree}->{$key} and ( $self->{tree}->{$key}{'.rgx'} or die "'$key' not defined as a single RE" ) or $atoms->{$key} or die "'$key' not defined in the grammar" ]e; last if $re eq $regexp->{'.rgx'}; $regexp->{'.rgx'} = $re; } } #-----------------------------------------------------------------------------# # Compile to native Perl regexes #-----------------------------------------------------------------------------# sub native { my ($self) = @_; $self->perl_regexes($self->{tree}); return $self; } sub perl_regexes { my ($self, $node) = @_; if (ref($node) eq 'HASH') { if (exists $node->{'.rgx'}) { my $re = $node->{'.rgx'}; $node->{'.rgx'} = qr/\G$re/; } else { for (keys %$node) { $self->perl_regexes($node->{$_}); } } } elsif (ref($node) eq 'ARRAY') { $self->perl_regexes($_) for @$node; } } #-----------------------------------------------------------------------------# # Serialization formatter methods #-----------------------------------------------------------------------------# sub to_yaml { require YAML::XS; my $self = shift; return YAML::XS::Dump($self->tree); } sub to_json { require JSON::XS; my $self = shift; return JSON::XS->new->utf8->canonical->pretty->encode($self->tree); } sub to_perl { my $self = shift; require Data::Dumper; no warnings 'once'; $Data::Dumper::Terse = 1; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; my $perl = Data::Dumper::Dumper($self->tree); $perl =~ s/\?\^:/?-xism:/g; $perl =~ s!(\.rgx.*?qr/)\(\?-xism:(.*)\)(?=/)!$1$2!g; die "to_perl failed with non compatible regex in:\n$perl" if $perl =~ /\?\^/; return $perl; } 1; PK � �[�lyF: : Pegex/Optimizer.pmnu �[��� package Pegex::Optimizer; use Pegex::Base; has parser => (required => 1); has grammar => (required => 1); has receiver => (required => 1); sub optimize_grammar { my ($self, $start) = @_; my $tree = $self->grammar->{tree}; return if $tree->{'+optimized'}; $self->set_max_parse if $self->parser->{maxparse}; $self->{extra} = {}; while (my ($name, $node) = each %$tree) { next unless ref($node); $self->optimize_node($node); } $self->optimize_node({'.ref' => $start}); my $extra = delete $self->{extra}; for my $key (%$extra) { $tree->{$key} = $extra->{$key}; } $tree->{'+optimized'} = 1; } sub optimize_node { my ($self, $node) = @_; my ($min, $max) = @{$node}{'+min', '+max'}; $node->{'+min'} = defined($max) ? 0 : 1 unless defined $node->{'+min'}; $node->{'+max'} = defined($min) ? 0 : 1 unless defined $node->{'+max'}; $node->{'+asr'} = 0 unless defined $node->{'+asr'}; for my $kind (qw(ref rgx all any err code xxx)) { return if $kind eq 'xxx'; if ($node->{rule} = $node->{".$kind"}) { delete $node->{".$kind"}; $node->{kind} = $kind; if ($kind eq 'ref') { my $rule = $node->{rule} or die; if (my $method = $self->grammar->can("rule_$rule")) { $node->{method} = $self->make_method_wrapper($method); } elsif (not $self->grammar->{tree}{$rule}) { if (my $method = $self->grammar->can("$rule")) { warn <<"..."; Warning: You have a method called '$rule' in your grammar. It should probably be called 'rule_$rule'. ... } die "No rule '$rule' defined in grammar"; } } $node->{method} ||= $self->parser->can("match_$kind") or die; last; } } if ($node->{kind} =~ /^(?:all|any)$/) { $self->optimize_node($_) for @{$node->{rule}}; } elsif ($node->{kind} eq 'ref') { my $ref = $node->{rule}; my $rule = $self->grammar->{tree}{$ref}; $rule ||= $self->{extra}{$ref} = {}; if (my $action = $self->receiver->can("got_$ref")) { $rule->{action} = $action; } elsif (my $gotrule = $self->receiver->can("gotrule")) { $rule->{action} = $gotrule; } if ($self->parser->{debug}) { $node->{method} = $self->make_trace_wrapper($node->{method}); } } elsif ($node->{kind} eq 'rgx') { # XXX $node; } } sub make_method_wrapper { my ($self, $method) = @_; return sub { my ($parser, $ref, $parent) = @_; @{$parser}{'rule', 'parent'} = ($ref, $parent); $method->( $parser->{grammar}, $parser, $parser->{buffer}, $parser->{position}, ); } } sub make_trace_wrapper { my ($self, $method) = @_; return sub { my ($self, $ref, $parent) = @_; my $asr = $parent->{'+asr'}; my $note = $asr == -1 ? '(!)' : $asr == 1 ? '(=)' : ''; $self->trace("try_$ref$note"); my $result; if ($result = $self->$method($ref, $parent)) { $self->trace("got_$ref$note"); } else { $self->trace("not_$ref$note"); } return $result; } } sub set_max_parse { require Pegex::Parser; my ($self) = @_; my $maxparse = $self->parser->{maxparse}; no warnings 'redefine'; my $method = \&Pegex::Parser::match_ref; my $counter = 0; *Pegex::Parser::match_ref = sub { die "Maximum parsing rules reached ($maxparse)\n" if $counter++ >= $maxparse; my $self = shift; $self->$method(@_); }; } 1; PK � �[D ��# # Pegex/Input.pmnu �[��� package Pegex::Input; use Pegex::Base; has string => (); has stringref => (); has file => (); has handle => (); has _buffer => (); has _is_eof => 0; has _is_open => 0; has _is_close => 0; # NOTE: Current implementation reads entire input into _buffer on open(). sub read { my ($self) = @_; die "Attempted Pegex::Input::read before open" if not $self->{_is_open}; die "Attempted Pegex::Input::read after EOF" if $self->{_is_eof}; my $buffer = $self->{_buffer}; $self->{_buffer} = undef; $self->{_is_eof} = 1; return $buffer; } sub open { my ($self) = @_; die "Attempted to reopen Pegex::Input object" if $self->{_is_open} or $self->{_is_close}; if (my $ref = $self->{stringref}) { $self->{_buffer} = $ref; } elsif (my $handle = $self->{handle}) { $self->{_buffer} = \ do { local $/; <$handle> }; } elsif (my $path = $self->{file}) { open my $handle, $path or die "Pegex::Input can't open $path for input:\n$!"; $self->{_buffer} = \ do { local $/; <$handle> }; } elsif (exists $self->{string}) { $self->{_buffer} = \$self->{string}; } else { die "Pegex::Input::open failed. No source to open"; } $self->{_is_open} = 1; return $self; } sub close { my ($self) = @_; die "Attempted to close an unopen Pegex::Input object" if $self->{_is_close}; close $self->{handle} if $self->{handle}; $self->{_is_open} = 0; $self->{_is_close} = 1; $self->{_buffer} = undef; return $self; } 1; PK � �[�υ Pegex/Base.pmnu �[��� package Pegex::Base; # use Mo qw'build default builder xxx import nonlazy required'; # The following line of code was produced from the previous line by # Mo::Inline version 0.39 no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.'::'.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};use constant XXX_skip=>1;my$dm='YAML::XS';*{$M.'xxx::e'}=sub{my($P,$e)=@_;$e->{WWW}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::WWW(@_)};$e->{XXX}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::XXX(@_)};$e->{YYY}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::YYY(@_)};$e->{ZZZ}=sub{require XXX;local$XXX::DumpModule=$dm}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};*{$M.'nonlazy::e'}=sub{${shift().':N'}=1};*{$M.'required::e'}=sub{my($P,$e,$o)=@_;$o->{required}=sub{my($m,$n,%a)=@_;if($a{required}){my$C=*{$P."new"}{CODE}||*{$M.Object::new}{CODE};no warnings 'redefine';*{$P."new"}=sub{my$s=$C->(@_);my%a=@_[1..$#_];die$n." required"if!exists$a{$n};$s}}$m}};@f=qw[build default builder xxx import nonlazy required];use strict;use warnings; our $DumpModule = 'YAML'; 1; PK � �[�Z�� Pegex/Grammar.pmnu �[��� package Pegex::Grammar; use Pegex::Base; # Grammar can be in text or tree form. Tree will be compiled from text. # Grammar can also be stored in a file. has file => (); has text => ( builder => 'make_text', lazy => 1, ); has tree => ( builder => 'make_tree', lazy => 1, ); has start_rules => []; sub make_text { my ($self) = @_; my $filename = $self->file or return ''; open TEXT, $filename or die "Can't open '$filename' for input\n:$!"; return do {local $/; <TEXT>} } sub make_tree { my ($self) = @_; my $text = $self->text or die "Can't create a '" . ref($self) . "' grammar. No tree or text or file."; require Pegex::Compiler; return Pegex::Compiler->new->compile( $text, @{$self->start_rules || []} )->tree; } # This import is to support: perl -MPegex::Grammar::Module=compile sub import { my ($package) = @_; if (((caller))[1] =~ /^-e?$/ and @_ == 2 and $_[1] eq 'compile') { $package->compile_into_module(); exit; } if (my $env = $ENV{PERL_PEGEX_AUTO_COMPILE}) { my %modules = map {($_, 1)} split ',', $env; if ($modules{$package}) { if (my $grammar_file = $package->file) { if (-f $grammar_file) { my $module = $package; $module =~ s!::!/!g; $module .= '.pm'; my $module_file = $INC{$module}; if (-M $grammar_file < -M $module_file) { $package->compile_into_module(); local $SIG{__WARN__}; delete $INC{$module}; require $module; } } } } } } sub compile_into_module { my ($package) = @_; my $grammar_file = $package->file; open GRAMMAR, $grammar_file or die "Can't open $grammar_file for input"; my $grammar_text = do {local $/; <GRAMMAR>}; close GRAMMAR; my $module = $package; $module =~ s!::!/!g; $module = "$module.pm"; my $file = $INC{$module} or return; my $perl; my @rules; if ($package->can('start_rules')) { @rules = @{$package->start_rules || []}; } if ($module eq 'Pegex/Pegex/Grammar.pm') { require Pegex::Bootstrap; $perl = Pegex::Bootstrap->new->compile($grammar_text, @rules)->to_perl; } else { require Pegex::Compiler; $perl = Pegex::Compiler->new->compile($grammar_text, @rules)->to_perl; } open IN, $file or die $!; my $module_text = do {local $/; <IN>}; require Pegex; my $msg = " # Generated/Inlined by Pegex::Grammar ($Pegex::VERSION)"; close IN; $perl =~ s/^/ /gm; $module_text =~ s/^(sub\s+make_tree\s*\{).*?(^\})/$1$msg\n$perl$2/ms; $module_text =~ s/^(sub\s+tree\s*\{).*?(^\})/$1$msg\n$perl$2/ms; chomp $grammar_text; $grammar_text = "<<'...';\n$grammar_text\n...\n"; $module_text =~ s/^(sub\s+text\s*\{).*?(^\})/$1$msg\n$grammar_text$2/ms; $grammar_text =~ s/^/# /gm; $module_text =~ s/^(# sub\s+text\s*\{).*?(^# \})/$1$msg\n$grammar_text$2/ms; open OUT, '>', $file or die $!; print OUT $module_text; close OUT; print "Compiled '$grammar_file' into '$file'.\n"; } 1; PK � �[uA� TestML/Library/Debug.pmnu �[��� package TestML::Library::Debug; use TestML::Base; extends 'TestML::Library'; no warnings 'redefine'; sub WWW { require XXX; local $XXX::DumpModule = $TestML::DumpModule; XXX::WWW(shift->value); } sub XXX { require XXX; local $XXX::DumpModule = $TestML::DumpModule; XXX::XXX(shift->value); } sub YYY { require XXX; local $XXX::DumpModule = $TestML::DumpModule; XXX::YYY(shift->value); } sub ZZZ { require XXX; local $XXX::DumpModule = $TestML::DumpModule; XXX::ZZZ(shift->value); } 1; PK � �[�� TestML/Library/Standard.pmnu �[��� package TestML::Library::Standard; use TestML::Base; extends 'TestML::Library'; use TestML::Util; sub Get { my ($self, $key) = @_; return $self->runtime->function->getvar($key->str->value); } # sub Set { # my ($self, $key, $value) = @_; # return $self->runtime->function->setvar($key, $value); # } sub GetLabel { my ($self) = @_; return str($self->runtime->get_label); } sub Type { my ($self, $var) = @_; return str($var->type); } sub Catch { my ($self) = @_; my $error = $self->runtime->error or die "Catch called but no TestML error found"; $error =~ s/ at .* line \d+\.\n\z//; $self->runtime->{error} = undef; return str($error); } sub Throw { my ($self, $msg) = @_; die $msg->value; } sub Str { my ($self, $object) = @_; return str($object->str->value); } # sub Num { # my ($self, $object) = @_; # return num($object->num->value); # } # sub Bool { # my ($self, $object) = @_; # return bool($object->bool->value); # } sub List { my $self = shift; return list([@_]); } sub Join { my ($self, $list, $separator) = @_; $separator = $separator ? $separator->value : ''; my @strings = map $_->value, @{$list->list->value}; return str join $separator, @strings; } sub Not { my ($self, $bool) = @_; return bool($bool->bool->value ? 0: 1); } sub Text { my ($self, $lines) = @_; my $value = $lines->list->value; return str(join $/, map($_->value, @$value), ''); } sub Count { my ($self, $list) = @_; return num scalar @{$list->list->value}; } sub Lines { my ($self, $text) = @_; return list([ map str($_), split /\n/, $text->value ]); } sub Reverse { my ($self, $list) = @_; my $value = $list->list->value; return list([ reverse @$value ]); } sub Sort { my ($self, $list) = @_; my $value = $list->list->value; return list([ sort { $a->value cmp $b->value } @$value ]); } sub Strip { my ($self, $string, $part) = @_; $string = $string->str->value; $part = $part->str->value; if ((my $i = index($string, $part)) >= 0) { $string = substr($string, 0, $i) . substr($string, $i + length($part)); } return str $string; } sub Print { my ($self, $string) = @_; print STDOUT $string->value; return bool(1); } sub Chomp { my ($self, $string) = @_; my $value = $string->str->value; chomp($value); return str $value; } 1; # sub Has { # my ($self, $string, $part) = @_; # $string = $string->str->value; # $part = $part->str->value; # return bool(index($string, $part) >= 0); # } # sub RunCommand { # require Capture::Tiny; # my ($self, $command) = @_; # $command = $command->value; # chomp($command); # my $sub = sub { # system($command); # }; # my ($stdout, $stderr) = Capture::Tiny::capture($sub); # $self->runtime->function->setvar('_Stdout', $stdout); # $self->runtime->function->setvar('_Stderr', $stderr); # return str(''); # } # sub RmPath { # require File::Path; # my ($self, $path) = @_; # $path = $path->value; # File::Path::rmtree($path); # return str(''); # } # sub Stdout { # my ($self) = @_; # return $self->runtime->function->getvar('_Stdout'); # } # sub Stderr { # my ($self) = @_; # return $self->runtime->function->getvar('_Stderr'); # } # sub Chdir { # my ($self, $dir) = @_; # $dir = $dir->value; # chdir $dir; # return str(''); # } # sub Read { # my ($self, $file) = @_; # $file = $file->value; # use Cwd; # open FILE, $file or die "Can't open $file for input in " . Cwd::cwd; # my $text = do { local $/; <FILE> }; # close FILE; # return str($text); # } # sub Pass { # my ($self, @args) = @_; # return @args; # } # sub Raw { # my $self = shift; # my $point = $self->point # or die "Raw called but there is no point"; # return $self->runtime->block->points->{$point}; # } # sub Point { # my ($self, $name) = @_; # $name = $name->value; # $self->runtime->get_point($name); # } PK � �[`��{ { TestML/Compiler/Lite.pmnu �[��� package TestML::Compiler::Lite; use TestML::Base; extends 'TestML::Compiler'; use TestML::Runtime; has input => (); has points => (); has tokens => (); has function => (); my $WS = qr!\s+!; my $ANY = qr!.!; my $STAR = qr!\*!; my $NUM = qr!-?[0-9]+!; my $WORD = qr!\w+!; my $HASH = qr!#!; my $EQ = qr!=!; my $TILDE = qr!~!; my $LP = qr!\(!; my $RP = qr!\)!; my $DOT = qr!\.!; my $COMMA = qr!,!; my $SEMI = qr!;!; my $SSTR = qr!'(?:[^']*)'!; my $DSTR = qr!"(?:[^"]*)"!; my $ENDING = qr!(?:$RP|$COMMA|$SEMI)!; my $POINT = qr!$STAR$WORD!; my $QSTR = qr!(?:$SSTR|$DSTR)!; my $COMP = qr!(?:$EQ$EQ|$TILDE$TILDE)!; my $OPER = qr!(?:$COMP|$EQ)!; my $PUNCT = qr!(?:$LP|$RP|$DOT|$COMMA|$SEMI)!; my $TOKENS = qr!(?:$POINT|$NUM|$WORD|$QSTR|$PUNCT|$OPER)!; sub compile_code { my ($self) = @_; $self->{function} = TestML::Function->new; while (length $self->{code}) { $self->{code} =~ s{^(.*)(\r\n|\n|)}{}; $self->{line} = $1; $self->tokenize; next if $self->done; $self->parse_assignment || $self->parse_assertion || $self->fail; } } sub tokenize { my ($self) = @_; $self->{tokens} = []; while (length $self->{line}) { next if $self->{line} =~ s/^$WS//; next if $self->{line} =~ s/^$HASH$ANY*//; if ($self->{line} =~ s/^($TOKENS)//) { push @{$self->{tokens}}, $1; } else { $self->fail("Failed to get token here: '$self->{line}'"); } } } sub parse_assignment { my ($self) = @_; return unless $self->peek(2) eq '='; my ($var, $op) = $self->pop(2); my $expr = $self->parse_expression; $self->pop if not $self->done and $self->peek eq ';'; $self->fail unless $self->done; push @{$self->function->statements}, TestML::Assignment->new(name => $var, expr => $expr); return 1; } sub parse_assertion { my ($self) = @_; return unless grep /^$COMP$/, @{$self->tokens}; $self->{points} = []; my $left = $self->parse_expression; my $token = $self->pop; my $op = $token eq '==' ? 'EQ' : $token eq '~~' ? 'HAS' : $self->fail; my $right = $self->parse_expression; $self->pop if not $self->done and $self->peek eq ';'; $self->fail unless $self->done; push @{$self->function->statements}, TestML::Statement->new( expr => $left, assert => TestML::Assertion->new( name => $op, expr => $right, ), @{$self->points} ? (points => $self->points) : (), ); return 1; } sub parse_expression { my ($self) = @_; my $calls = []; while (not $self->done and $self->peek !~ /^($ENDING|$COMP)$/) { my $token = $self->pop; if ($token =~ /^$NUM$/) { push @$calls, TestML::Num->new(value => $token + 0); } elsif ($token =~/^$QSTR$/) { my $str = substr($token, 1, length($token) - 2); push @$calls, TestML::Str->new(value => $str); } elsif ($token =~ /^$WORD$/) { my $call = TestML::Call->new(name => $token); if (not $self->done and $self->peek eq '(') { $call->{args} = $self->parse_args; } push @$calls, $call; } elsif ($token =~ /^$POINT$/) { $token =~ /($WORD)/ or die; push @{$self->{points}}, $1; push @$calls, TestML::Point->new(name => $1); } else { $self->fail("Unknown token '$token'"); } if (not $self->done and $self->peek eq '.') { $self->pop; } } return @$calls == 1 ? $calls->[0] : TestML::Expression->new(calls => $calls); } sub parse_args { my ($self) = @_; $self->pop eq '(' or die; my $args = []; while ($self->peek ne ')') { push @$args, $self->parse_expression; $self->pop if $self->peek eq ','; } $self->pop; return $args; } sub compile_data { my ($self) = @_; my $input = $self->data; $input =~ s/^#.*\n/\n/mg; $input =~ s/^\\//mg; my @blocks = grep $_, split /(^===.*?(?=^===|\z))/ms, $input; for my $block (@blocks) { $block =~ s/\n+\z/\n/; } my $data = []; for my $string_block (@blocks) { my $block = TestML::Block->new; $string_block =~ s/^===\ +(.*?)\ *\n//g or die "No block label! $string_block"; $block->{label} = $1; while (length $string_block) { next if $string_block =~ s/^\n+//; my ($key, $value); if ($string_block =~ s/\A---\ +(\w+):\ +(.*)\n//g or $string_block =~ s/\A---\ +(\w+)\n(.*?)(?=^---|\z)//msg ) { ($key, $value) = ($1, $2); } else { die "Failed to parse TestML string:\n$string_block"; } $block->{points} ||= {}; $block->{points}{$key} = $value; if ($key =~ /^(ONLY|SKIP|LAST)$/) { $block->{$key} = 1; } } push @$data, $block; } $self->function->{data} = $data if @$data; } sub done { my ($self) = @_; @{$self->{tokens}} ? 0 : 1 } sub peek { my ($self, $index) = @_; $index ||= 1; die if $index > @{$self->{tokens}}; $self->{tokens}->[$index - 1]; } sub pop { my ($self, $count) = @_; $count ||= 1; die if $count > @{$self->{tokens}}; splice @{$self->{tokens}}, 0, $count; } sub fail { my ($self, $message) = @_; my $text = "Failed to compile TestML document.\n"; $text .= "Reason: $message\n" if $message; $text .= "\nCode section of failure:\n$self->{line}\n$self->{code}\n"; die $text; } 1; PK � �[1�#� TestML/Compiler/Pegex.pmnu �[��� package TestML::Compiler::Pegex; use TestML::Base; extends 'TestML::Compiler'; use TestML::Compiler::Pegex::Grammar; use TestML::Compiler::Pegex::AST; use Pegex::Parser; has parser => (); sub compile_code { my ($self) = @_; $self->{parser} = Pegex::Parser->new( grammar => TestML::Compiler::Pegex::Grammar->new, receiver => TestML::Compiler::Pegex::AST->new, ); $self->fixup_grammar; $self->parser->parse($self->code, 'code_section') or die "Parse TestML code section failed"; } sub compile_data { my ($self) = @_; if (length $self->data) { $self->parser->parse($self->data, 'data_section') or die "Parse TestML data section failed"; } $self->{function} = $self->parser->receiver->function; } # TODO This can be moved to the AST some day. sub fixup_grammar { my ($self) = @_; my $tree = $self->{parser}->grammar->tree; my $point_lines = $tree->{point_lines}{'.rgx'}; my $block_marker = $self->directives->{BlockMarker}; if ($block_marker) { $block_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g; $tree->{block_marker}{'.rgx'} = qr/\G$block_marker/; $point_lines =~ s/===/$block_marker/; } my $point_marker = $self->directives->{PointMarker}; if ($point_marker) { $point_marker =~ s/([\$\%\^\*\+\?\|])/\\$1/g; $tree->{point_marker}{'.rgx'} = qr/\G$point_marker/; $point_lines =~ s/\\-\\-\\-/$point_marker/; } $tree->{point_lines}{'.rgx'} = qr/$point_lines/; } 1; PK � �[��]�� � TestML/Compiler/Pegex/AST.pmnu �[��� package TestML::Compiler::Pegex::AST; use TestML::Base; extends 'Pegex::Tree'; use TestML::Runtime; has points => []; has function => sub { TestML::Function->new }; # sub final { # my ($self, $match, $top) = @_; # XXX $match; # } # __END__ sub got_code_section { my ($self, $code) = @_; $self->function->{statements} = $code; } sub got_assignment_statement { my ($self, $match) = @_; return TestML::Assignment->new( name => $match->[0], expr => $match->[1], ); } sub got_code_statement { my ($self, $list) = @_; my ($expression, $assertion); my $points = $self->points; $self->{points} = []; for (@$list) { if (ref eq 'TestML::Assertion') { $assertion = $_; } else { #if (ref eq 'TestML::Expression') { $expression = $_; } } return TestML::Statement->new( $expression ? ( expr => $expression ) : (), $assertion ? ( assert => $assertion ) : (), @$points ? ( points => $points ) : (), ); } sub got_code_expression { my ($self, $list) = @_; my $calls = []; push @$calls, shift @$list if @$list; $list = shift @$list || []; for (@$list) { my $call = $_->[0]; #->{call_call}[0][0]; push @$calls, $call; } return $calls->[0] if @$calls == 1; return TestML::Expression->new( calls => $calls, ); } sub got_string_object { my ($self, $string) = @_; return TestML::Str->new( value => $string, ); } sub got_double_quoted_string { my ($self, $string) = @_; $string =~ s/\\n/\n/g; return $string; } sub got_number_object { my ($self, $number) = @_; return TestML::Num->new( value => $number + 0, ); } sub got_point_object { my ($self, $point) = @_; $point =~ s/^\*// or die; push @{$self->points}, $point; return TestML::Point->new( name => $point, ); } sub got_assertion_call { my ($self, $call) = @_; # XXX $call strangley becomes an array when $PERL_PEGEX_DEBUG is on. # Workaround for now, until I figure it out. $call = $call->[0] if ref $call eq 'ARRAY'; my ($name, $expr); for (qw( eq has ok )) { if ($expr = $call->{"assertion_$_"}) { $name = uc $_; $expr = $expr->{"assertion_operator_$_"}[0] || $expr->{"assertion_function_$_"}[0]; last; } } return TestML::Assertion->new( name => $name, $expr ? (expr => $expr) : (), ); } sub got_assertion_function_ok { my ($self, $ok) = @_; return { assertion_function_ok => [], } } sub got_function_start { my ($self) = @_; my $function = TestML::Function->new; $function->outer($self->function); $self->{function} = $function; return 1; } sub got_function_object { my ($self, $object) = @_; my $function = $self->function; $self->{function} = $function->outer; if (ref($object->[0]) and ref($object->[0][0])) { $function->{signature} = $object->[0][0]; } $function->{statements} = $object->[-1]; return $function; } sub got_call_name { my ($self, $name) = @_; return TestML::Call->new(name => $name); } sub got_call_object { my ($self, $object) = @_; my $call = $object->[0]; my $args = $object->[1][-1]; if ($args) { $args = [ map { ($_->isa('TestML::Expression') and @{$_->calls} == 1 and ( $_->calls->[0]->isa('TestML::Point') || $_->calls->[0]->isa('TestML::Object') )) ? $_->calls->[0] : $_; } @$args ]; $call->args($args) } return $call; } sub got_call_argument_list { my ($self, $list) = @_; return $list; } sub got_call_indicator { my ($self) = @_; return; } sub got_data_section { my ($self, $data) = @_; $self->function->data($data); } sub got_data_block { my ($self, $block) = @_; return TestML::Block->new( label => $block->[0][0][0], points => +{map %$_, @{$block->[1]}}, ); } sub got_block_point { my ($self, $point) = @_; return { $point->[0] => $point->[1], }; } 1; PK � �[���a) a) TestML/Compiler/Pegex/Grammar.pmnu �[��� package TestML::Compiler::Pegex::Grammar; use TestML::Base; extends 'Pegex::Grammar'; use constant file => '../testml-pgx/testml.pgx'; sub make_tree { # Generated/Inlined by Pegex::Grammar (0.43) { '+grammar' => 'testml', '+include' => 'atom', '+toprule' => 'testml_document', '+version' => '0.0.1', '__' => { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)+/ }, 'assertion_call' => { '.any' => [ { '-wrap' => 1, '.ref' => 'assertion_eq' }, { '-wrap' => 1, '.ref' => 'assertion_ok' }, { '-wrap' => 1, '.ref' => 'assertion_has' } ] }, 'assertion_call_test' => { '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)(?:EQ|OK|HAS)/ }, 'assertion_eq' => { '.any' => [ { '-wrap' => 1, '.ref' => 'assertion_operator_eq' }, { '-wrap' => 1, '.ref' => 'assertion_function_eq' } ] }, 'assertion_function_eq' => { '.all' => [ { '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)EQ\(/ }, { '.ref' => 'code_expression' }, { '.rgx' => qr/\G\)/ } ] }, 'assertion_function_has' => { '.all' => [ { '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)HAS\(/ }, { '.ref' => 'code_expression' }, { '.rgx' => qr/\G\)/ } ] }, 'assertion_function_ok' => { '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)(OK)(?:\((?:[\ \t]|\r?\n|\#.*\r?\n)*\))?/ }, 'assertion_has' => { '.any' => [ { '-wrap' => 1, '.ref' => 'assertion_operator_has' }, { '-wrap' => 1, '.ref' => 'assertion_function_has' } ] }, 'assertion_ok' => { '.ref' => 'assertion_function_ok' }, 'assertion_operator_eq' => { '.all' => [ { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)+==(?:[\ \t]|\r?\n|\#.*\r?\n)+/ }, { '.ref' => 'code_expression' } ] }, 'assertion_operator_has' => { '.all' => [ { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)+\~\~(?:[\ \t]|\r?\n|\#.*\r?\n)+/ }, { '.ref' => 'code_expression' } ] }, 'assignment_statement' => { '.all' => [ { '.ref' => 'variable_name' }, { '.rgx' => qr/\G\s+=\s+/ }, { '.ref' => 'code_expression' }, { '.ref' => 'ending' } ] }, 'blank_line' => { '.rgx' => qr/\G[\ \t]*\r?\n/ }, 'blanks' => { '.rgx' => qr/\G[\ \t]+/ }, 'block_header' => { '.all' => [ { '.ref' => 'block_marker' }, { '+max' => 1, '.all' => [ { '.ref' => 'blanks' }, { '.ref' => 'block_label' } ] }, { '.ref' => 'blank_line' } ] }, 'block_label' => { '.ref' => 'unquoted_string' }, 'block_marker' => { '.rgx' => qr/\G===/ }, 'block_point' => { '.any' => [ { '.ref' => 'lines_point' }, { '.ref' => 'phrase_point' } ] }, 'call_argument' => { '.ref' => 'code_expression' }, 'call_argument_list' => { '.all' => [ { '.rgx' => qr/\G\((?:[\ \t]|\r?\n|\#.*\r?\n)*/ }, { '+max' => 1, '.all' => [ { '.ref' => 'call_argument' }, { '+min' => 0, '-flat' => 1, '.all' => [ { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*,(?:[\ \t]|\r?\n|\#.*\r?\n)*/ }, { '.ref' => 'call_argument' } ] } ] }, { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\)/ } ] }, 'call_call' => { '.all' => [ { '+asr' => -1, '.ref' => 'assertion_call_test' }, { '.ref' => 'call_indicator' }, { '.ref' => 'code_object' } ] }, 'call_indicator' => { '.rgx' => qr/\G(?:\.(?:[\ \t]|\r?\n|\#.*\r?\n)*|(?:[\ \t]|\r?\n|\#.*\r?\n)*\.)/ }, 'call_name' => { '.any' => [ { '.ref' => 'user_call' }, { '.ref' => 'core_call' } ] }, 'call_object' => { '.all' => [ { '.ref' => 'call_name' }, { '+max' => 1, '.ref' => 'call_argument_list' } ] }, 'code_expression' => { '.all' => [ { '.ref' => 'code_object' }, { '+min' => 0, '.ref' => 'call_call' } ] }, 'code_object' => { '.any' => [ { '.ref' => 'function_object' }, { '.ref' => 'point_object' }, { '.ref' => 'string_object' }, { '.ref' => 'number_object' }, { '.ref' => 'call_object' } ] }, 'code_section' => { '+min' => 0, '.any' => [ { '.ref' => '__' }, { '.ref' => 'assignment_statement' }, { '.ref' => 'code_statement' } ] }, 'code_statement' => { '.all' => [ { '.ref' => 'code_expression' }, { '+max' => 1, '.ref' => 'assertion_call' }, { '.ref' => 'ending' } ] }, 'comment' => { '.rgx' => qr/\G\#.*\r?\n/ }, 'core_call' => { '.rgx' => qr/\G([A-Z]\w*)/ }, 'data_block' => { '.all' => [ { '.ref' => 'block_header' }, { '+min' => 0, '-skip' => 1, '.any' => [ { '.ref' => 'blank_line' }, { '.ref' => 'comment' } ] }, { '+min' => 0, '.ref' => 'block_point' } ] }, 'data_section' => { '+min' => 0, '.ref' => 'data_block' }, 'double_quoted_string' => { '.rgx' => qr/\G(?:"((?:[^\n\\"]|\\"|\\\\|\\[0nt])*?)")/ }, 'ending' => { '.any' => [ { '.rgx' => qr/\G(?:;|\r?\n)/ }, { '+asr' => 1, '.ref' => 'ending2' } ] }, 'ending2' => { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\}/ }, 'function_object' => { '.all' => [ { '+max' => 1, '.ref' => 'function_signature' }, { '.ref' => 'function_start' }, { '+min' => 0, '.any' => [ { '.ref' => '__' }, { '.ref' => 'assignment_statement' }, { '.ref' => 'code_statement' } ] }, { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\}/ } ] }, 'function_signature' => { '.all' => [ { '.rgx' => qr/\G\((?:[\ \t]|\r?\n|\#.*\r?\n)*/ }, { '+max' => 1, '.ref' => 'function_variables' }, { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*\)/ } ] }, 'function_start' => { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*(\{)(?:[\ \t]|\r?\n|\#.*\r?\n)*/ }, 'function_variable' => { '.rgx' => qr/\G([a-zA-Z]\w*)/ }, 'function_variables' => { '.all' => [ { '.ref' => 'function_variable' }, { '+min' => 0, '-flat' => 1, '.all' => [ { '.rgx' => qr/\G(?:[\ \t]|\r?\n|\#.*\r?\n)*,(?:[\ \t]|\r?\n|\#.*\r?\n)*/ }, { '.ref' => 'function_variable' } ] } ] }, 'lines_point' => { '.all' => [ { '.ref' => 'point_marker' }, { '.ref' => 'blanks' }, { '.ref' => 'point_name' }, { '.ref' => 'blank_line' }, { '.ref' => 'point_lines' } ] }, 'number' => { '.rgx' => qr/\G([0-9]+)/ }, 'number_object' => { '.ref' => 'number' }, 'phrase_point' => { '.all' => [ { '.ref' => 'point_marker' }, { '.ref' => 'blanks' }, { '.ref' => 'point_name' }, { '.rgx' => qr/\G:[\ \t]/ }, { '.ref' => 'point_phrase' }, { '.rgx' => qr/\G\r?\n/ }, { '.rgx' => qr/\G(?:\#.*\r?\n|[\ \t]*\r?\n)*/ } ] }, 'point_lines' => { '.rgx' => qr/\G((?:(?!(?:===|\-\-\-)\ \w).*\r?\n)*)/ }, 'point_marker' => { '.rgx' => qr/\G\-\-\-/ }, 'point_name' => { '.rgx' => qr/\G([a-z]\w*|[A-Z]\w*)/ }, 'point_object' => { '.rgx' => qr/\G(\*[a-z]\w*)/ }, 'point_phrase' => { '.ref' => 'unquoted_string' }, 'quoted_string' => { '.any' => [ { '.ref' => 'single_quoted_string' }, { '.ref' => 'double_quoted_string' } ] }, 'single_quoted_string' => { '.rgx' => qr/\G(?:'((?:[^\n\\']|\\'|\\\\)*?)')/ }, 'string_object' => { '.ref' => 'quoted_string' }, 'testml_document' => { '.all' => [ { '.ref' => 'code_section' }, { '+max' => 1, '.ref' => 'data_section' } ] }, 'unquoted_string' => { '.rgx' => qr/\G([^\ \t\n\#](?:[^\n\#]*[^\ \t\n\#])?)/ }, 'user_call' => { '.rgx' => qr/\G([a-z]\w*)/ }, 'variable_name' => { '.rgx' => qr/\G([a-zA-Z]\w*)/ } } } 1; PK � �[�Q��L L TestML/Bridge.pmnu �[��� package TestML::Bridge; use TestML::Base; use TestML::Util 'runtime'; 1; PK � �[�a�� � TestML/Util.pmnu �[��� use strict; use warnings; use TestML::Runtime; package TestML::Util; use Exporter 'import'; our @EXPORT = qw( runtime list str num bool none native ); sub runtime { $TestML::Runtime::Singleton } sub list { TestML::List->new(value => $_[0]) } sub str { TestML::Str->new(value => $_[0]) } sub num { TestML::Num->new(value => $_[0]) } sub bool { TestML::Bool->new(value => $_[0]) } sub none { TestML::None->new(value => $_[0]) } sub native { TestML::Native->new(value => $_[0]) } 1; PK � �[�"���1 �1 TestML/Runtime.pmnu �[��� package TestML::Runtime; use TestML::Base; has testml => (); has bridge => (); has library => (); has compiler => (); has skip => (); has function => (); has error => (); has global => (); has base => (); sub BUILD { my ($self) = @_; $TestML::Runtime::Singleton = $self; $self->{base} ||= $0 =~ m!(.*)/! ? $1 : "."; } sub run { my ($self) = @_; $self->compile_testml; $self->initialize_runtime; $self->run_function($self->{function}, []); } # TODO Functions should have return values sub run_function { my ($self, $function, $args) = @_; $self->apply_signature($function, $args); my $parent = $self->function; $self->{function} = $function; for my $statement (@{$function->statements}) { if (ref($statement) eq 'TestML::Assignment') { $self->run_assignment($statement); } else { $self->run_statement($statement); } } $self->{function} = $parent; return; } sub apply_signature { my ($self, $function, $args) = @_; my $signature = $function->signature; die sprintf( "Function received %d args but expected %d", scalar(@$args), scalar(@$signature), ) if @$signature and @$args != @$signature; $function->setvar('Self', $function); for (my $i = 0; $i < @$signature; $i++) { my $arg = $args->[$i]; $arg = $self->run_expression($arg) if ref($arg) eq 'TestML::Expression'; $function->setvar($signature->[$i], $arg); } } sub run_statement { my ($self, $statement) = @_; my $blocks = $self->select_blocks($statement->points || []); for my $block (@$blocks) { $self->function->setvar('Block', $block) if $block != 1; my $result = $self->run_expression($statement->expr); if (my $assert = $statement->assert) { $self->run_assertion($result, $assert); } } } sub run_assignment { my ($self, $assignment) = @_; $self->function->setvar( $assignment->name, $self->run_expression($assignment->expr), ); } sub run_assertion { my ($self, $left, $assert) = @_; my $method = 'assert_' . $assert->name; $self->function->getvar('TestNumber')->{value}++; if ($assert->expr) { $self->$method($left, $self->run_expression($assert->expr)); } else { $self->$method($left); } } sub run_expression { my ($self, $expr) = @_; my $context = undef; $self->{error} = undef; if ($expr->isa('TestML::Expression')) { my @calls = @{$expr->calls}; die if @calls <= 1; $context = $self->run_call(shift(@calls)); for my $call (@calls) { if ($self->error) { next unless $call->isa('TestML::Call') and $call->name eq 'Catch'; } $context = $self->run_call($call, $context); } } else { $context = $self->run_call($expr); } if ($self->error) { die $self->error; } return $context; } sub run_call { my ($self, $call, $context) = @_; if ($call->isa('TestML::Object')) { return $call; } if ($call->isa('TestML::Function')) { return $call; } if ($call->isa('TestML::Point')) { return $self->get_point($call->name); } if ($call->isa('TestML::Call')) { my $name = $call->name; my $callable = $self->function->getvar($name) || $self->lookup_callable($name) || die "Can't locate '$name' callable"; if ($callable->isa('TestML::Object')) { return $callable; } return $callable unless $call->args or defined $context; $call->{args} ||= []; my $args = [map $self->run_expression($_), @{$call->args}]; unshift @$args, $context if $context; if ($callable->isa('TestML::Callable')) { my $value = eval { $callable->value->(@$args) }; if ($@) { $self->{error} = $@; return TestML::Error->new(value => $@); } die "'$name' did not return a TestML::Object object" unless UNIVERSAL::isa($value, 'TestML::Object'); return $value; } if ($callable->isa('TestML::Function')) { return $self->run_function($callable, $args); } die; } die; } sub lookup_callable { my ($self, $name) = @_; for my $library (@{$self->function->getvar('Library')->value}) { if ($library->can($name)) { my $function = sub { $library->$name(@_) }; my $callable = TestML::Callable->new(value => $function); $self->function->setvar($name, $callable); return $callable; } } return; } sub get_point { my ($self, $name) = @_; my $value = $self->function->getvar('Block')->{points}{$name}; defined $value or return; if ($value =~ s/\n+\z/\n/ and $value eq "\n") { $value = ''; } $value =~ s/^\\//gm; return TestML::Str->new(value => $value); } sub select_blocks { my ($self, $wanted) = @_; return [1] unless @$wanted; my $selected = []; OUTER: for my $block (@{$self->function->data}) { my %points = %{$block->points}; next if exists $points{SKIP}; if (exists $points{ONLY}) { for my $point (@$wanted) { return [] unless exists $points{$point}; } $selected = [$block]; last; } for my $point (@$wanted) { next OUTER unless exists $points{$point}; } push @$selected, $block; last if exists $points{LAST}; } return $selected; } sub compile_testml { my ($self) = @_; die "'testml' document required but not found" unless $self->testml; if ($self->testml !~ /\n/) { $self->testml =~ /(?:(.*)\/)?(.*)/ or die; $self->{testml} = $2; $self->{base} .= '/' . $1 if $1; $self->{testml} = $self->read_testml_file($self->testml); } $self->{function} = $self->compiler->new->compile($self->testml) or die "TestML document failed to compile"; } sub initialize_runtime { my ($self) = @_; $self->{global} = $self->function->outer; $self->{global}->setvar(Block => TestML::Block->new); $self->{global}->setvar(Label => TestML::Str->new(value => '$BlockLabel')); $self->{global}->setvar(True => $TestML::Constant::True); $self->{global}->setvar(False => $TestML::Constant::False); $self->{global}->setvar(None => $TestML::Constant::None); $self->{global}->setvar(TestNumber => TestML::Num->new(value => 0)); $self->{global}->setvar(Library => TestML::List->new); my $library = $self->function->getvar('Library'); for my $lib ($self->bridge, $self->library) { if (ref($lib) eq 'ARRAY') { $library->push($_->new) for @$lib; } else { $library->push($lib->new); } } } sub get_label { my ($self) = @_; my $label = $self->function->getvar('Label') or return; $label = $label->value or return; $label =~ s/\$(\w+)/$self->replace_label($1)/ge; return $label; } sub replace_label { my ($self, $var) = @_; my $block = $self->function->getvar('Block'); return $block->label if $var eq 'BlockLabel'; if (my $v = $block->points->{$var}) { $v =~ s/\n.*//s; $v =~ s/^\s*(.*?)\s*$/$1/; return $v; } if (my $v = $self->function->getvar($var)) { return $v->value; } } sub read_testml_file { my ($self, $file) = @_; my $path = $self->base . '/' . $file; open my $fh, $path or die "Can't open '$path' for input: $!"; local $/; return <$fh>; } #----------------------------------------------------------------------------- package TestML::Function; use TestML::Base; has type => 'Func'; # Functions are TestML typed objects has signature => []; # Input variable names has namespace => {}; # Lexical scoped variable stash has statements => []; # Exexcutable code statements has data => []; # Data section scoped to this function my $outer = {}; sub outer { @_ == 1 ? $outer->{$_[0]} : ($outer->{$_[0]} = $_[1]) } sub getvar { my ($self, $name) = @_; while ($self) { if (my $object = $self->namespace->{$name}) { return $object; } $self = $self->outer; } undef; } sub setvar { my ($self, $name, $value) = @_; $self->namespace->{$name} = $value; } sub forgetvar { my ($self, $name) = @_; delete $self->namespace->{$name}; } #----------------------------------------------------------------------------- package TestML::Assignment; use TestML::Base; has name => (); has expr => (); #----------------------------------------------------------------------------- package TestML::Statement; use TestML::Base; has expr => (); has assert => (); has points => (); #----------------------------------------------------------------------------- package TestML::Expression; use TestML::Base; has calls => []; #----------------------------------------------------------------------------- package TestML::Assertion; use TestML::Base; has name => (); has expr => (); #----------------------------------------------------------------------------- package TestML::Call; use TestML::Base; has name => (); has args => (); #----------------------------------------------------------------------------- package TestML::Callable; use TestML::Base; has value => (); #----------------------------------------------------------------------------- package TestML::Block; use TestML::Base; has label => ''; has points => {}; #----------------------------------------------------------------------------- package TestML::Point; use TestML::Base; has name => (); #----------------------------------------------------------------------------- package TestML::Object; use TestML::Base; has value => (); sub type { my $type = ref($_[0]); $type =~ s/^TestML::// or die "Can't find type of '$type'"; return $type; } sub str { die "Cast from ${\ $_[0]->type} to Str is not supported" } sub num { die "Cast from ${\ $_[0]->type} to Num is not supported" } sub bool { die "Cast from ${\ $_[0]->type} to Bool is not supported" } sub list { die "Cast from ${\ $_[0]->type} to List is not supported" } sub none { $TestML::Constant::None } #----------------------------------------------------------------------------- package TestML::Str; use TestML::Base; extends 'TestML::Object'; sub str { $_[0] } sub num { TestML::Num->new( value => ($_[0]->value =~ /^-?\d+(?:\.\d+)$/ ? ($_[0]->value + 0) : 0), )} sub bool { length($_[0]->value) ? $TestML::Constant::True : $TestML::Constant::False } sub list { TestML::List->new(value => [split //, $_[0]->value]) } #----------------------------------------------------------------------------- package TestML::Num; use TestML::Base; extends 'TestML::Object'; sub str { TestML::Str->new(value => $_[0]->value . "") } sub num { $_[0] } sub bool { ($_[0]->value != 0) ? $TestML::Constant::True : $TestML::Constant::False } sub list { my $list = []; $#{$list} = int($_[0]) -1; TestML::List->new(value =>$list); } #----------------------------------------------------------------------------- package TestML::Bool; use TestML::Base; extends 'TestML::Object'; sub str { TestML::Str->new(value => $_[0]->value ? "1" : "") } sub num { TestML::Num->new(value => $_[0]->value ? 1 : 0) } sub bool { $_[0] } #----------------------------------------------------------------------------- package TestML::List; use TestML::Base; extends 'TestML::Object'; has value => []; sub list { $_[0] } sub push { my ($self, $elem) = @_; push @{$self->value}, $elem; } #----------------------------------------------------------------------------- package TestML::None; use TestML::Base; extends 'TestML::Object'; sub str { TestML::Str->new(value => '') } sub num { TestML::Num->new(value => 0) } sub bool { $TestML::Constant::False } sub list { TestML::List->new(value => []) } #----------------------------------------------------------------------------- package TestML::Native; use TestML::Base; extends 'TestML::Object'; #----------------------------------------------------------------------------- package TestML::Error; use TestML::Base; extends 'TestML::Object'; #----------------------------------------------------------------------------- package TestML::Constant; our $True = TestML::Bool->new(value => 1); our $False = TestML::Bool->new(value => 0); our $None = TestML::None->new; 1; PK � �[B��=� � TestML/Runtime/TAP.pmnu �[��� use Test::Builder; use TestML::Runtime; package TestML::Runtime::TAP; use TestML::Base; extends 'TestML::Runtime'; has tap_object => sub { Test::Builder->new }; has planned => 0; sub run { my ($self) = @_; $self->SUPER::run; $self->check_plan; $self->plan_end; } sub run_assertion { my ($self, @args) = @_; $self->check_plan; $self->SUPER::run_assertion(@args); } sub check_plan { my ($self) = @_; if (! $self->planned) { $self->title; $self->plan_begin; $self->{planned} = 1; } } sub title { my ($self) = @_; if (my $title = $self->function->getvar('Title')) { $title = $title->value; $title = "=== $title ===\n"; $self->tap_object->note($title); } } sub skip_test { my ($self, $reason) = @_; $self->tap_object->plan(skip_all => $reason); } sub plan_begin { my ($self) = @_; if (my $tests = $self->function->getvar('Plan')) { $self->tap_object->plan(tests => $tests->value); } } sub plan_end { my ($self) = @_; $self->tap_object->done_testing(); } # TODO Use Test::Diff here. sub assert_EQ { my ($self, $got, $want) = @_; $got = $got->str->value; $want = $want->str->value; if ($got ne $want and $want =~ /\n/) { my $block = $self->function->getvar('Block'); my $diff = $self->function->getvar('Diff'); if ($diff or exists $block->points->{DIFF}) { require Text::Diff; $self->tap_object->ok(0, $self->get_label); my $diff = Text::Diff::diff( \$want, \$got, { FILENAME_A => "want", FILENAME_B => "got", }, ); $self->tap_object->diag($diff); return; } } $self->tap_object->is_eq( $got, $want, $self->get_label, ); } sub assert_HAS { my ($self, $got, $has) = @_; $got = $got->str->value; $has = $has->str->value; my $assertion = (index($got, $has) >= 0); if (not $assertion) { my $msg = <<"..."; Failed TestML HAS (~~) assertion. This text: '$got' does not contain this string: '$has' ... $self->tap_object->diag($msg); } $self->tap_object->ok($assertion, $self->get_label); } sub assert_OK { my ($self, $got) = @_; $self->tap_object->ok( $got->bool->value, $self->get_label, ); } 1; PK � �[G � TestML/Compiler.pmnu �[��� use TestML::Runtime; package TestML::Compiler; use TestML::Base; has code => (); has data => (); has text => (); has directives => (); has function => (); sub compile { my ($self, $input) = @_; $self->preprocess($input, 'top'); $self->compile_code; $self->compile_data; if ($self->directives->{DumpAST}) { XXX($self->function); } $self->function->namespace->{TestML} = $self->directives->{TestML}; $self->function->outer(TestML::Function->new); return $self->function; } sub preprocess { my ($self, $input, $top) = @_; my @parts = split /^((?:\%\w+.*|\#.*|\ *)\n)/m, $input; $input = ''; $self->{directives} = { TestML => '', DataMarker => '', BlockMarker => '===', PointMarker => '---', }; my $order_error = 0; for my $part (@parts) { next unless length($part); if ($part =~ /^(\#.*|\ *)\n/) { $input .= "\n"; next; } if ($part =~ /^%(\w+)\s*(.*?)\s*\n/) { my ($directive, $value) = ($1, $2); $input .= "\n"; if ($directive eq 'TestML') { die "Invalid TestML directive" unless $value =~ /^\d+\.\d+\.\d+$/; die "More than one TestML directive found" if $self->directives->{TestML}; $self->directives->{TestML} = TestML::Str->new(value => $value); next; } $order_error = 1 unless $self->directives->{TestML}; if ($directive eq 'Include') { my $runtime = $TestML::Runtime::Singleton or die "Can't process Include. No runtime available"; my $include = ref($self)->new; $include->preprocess($runtime->read_testml_file($value)); $input .= $include->text; $self->directives->{DataMarker} = $include->directives->{DataMarker}; $self->directives->{BlockMarker} = $include->directives->{BlockMarker}; $self->directives->{PointMarker} = $include->directives->{PointMarker}; die "Can't define %TestML in an Included file" if $include->directives->{TestML}; } elsif ($directive =~ /^(DataMarker|BlockMarker|PointMarker)$/) { $self->directives->{$directive} = $value; } elsif ($directive =~ /^(DebugPegex|DumpAST)$/) { $value = 1 unless length($value); $self->directives->{$directive} = $value; } else { die "Unknown TestML directive '$directive'"; } } else { $order_error = 1 if $input and not $self->directives->{TestML}; $input .= $part; } } if ($top) { die "No TestML directive found" unless $self->directives->{TestML}; die "%TestML directive must be the first (non-comment) statement" if $order_error; my $DataMarker = $self->directives->{DataMarker} ||= $self->directives->{BlockMarker}; if ((my $split = index($input, "\n$DataMarker")) >= 0) { $self->{code} = substr($input, 0, $split + 1); $self->{data} = substr($input, $split + 1); } else { $self->{code} = $input; $self->{data} = ''; } } else { $self->{text} = $input; } } 1; PK � �[C��t� � TestML/Base.pmnu �[��� package TestML::Base; # use Mo qw'build default builder xxx import'; # The following line of code was produced from the previous line by # Mo::Inline version 0.38 no warnings;my$M=__PACKAGE__.'::';*{$M.Object::new}=sub{my$c=shift;my$s=bless{@_},$c;my%n=%{$c.::.':E'};map{$s->{$_}=$n{$_}->()if!exists$s->{$_}}keys%n;$s};*{$M.import}=sub{import warnings;$^H|=1538;my($P,%e,%o)=caller.'::';shift;eval"no Mo::$_",&{$M.$_.::e}($P,\%e,\%o,\@_)for@_;return if$e{M};%e=(extends,sub{eval"no $_[0]()";@{$P.ISA}=$_[0]},has,sub{my$n=shift;my$m=sub{$#_?$_[0]{$n}=$_[1]:$_[0]{$n}};@_=(default,@_)if!($#_%2);$m=$o{$_}->($m,$n,@_)for sort keys%o;*{$P.$n}=$m},%e,);*{$P.$_}=$e{$_}for keys%e;@{$P.ISA}=$M.Object};*{$M.'build::e'}=sub{my($P,$e)=@_;$e->{new}=sub{$c=shift;my$s=&{$M.Object::new}($c,@_);my@B;do{@B=($c.::BUILD,@B)}while($c)=@{$c.::ISA};exists&$_&&&$_($s)for@B;$s}};*{$M.'default::e'}=sub{my($P,$e,$o)=@_;$o->{default}=sub{my($m,$n,%a)=@_;exists$a{default}or return$m;my($d,$r)=$a{default};my$g='HASH'eq($r=ref$d)?sub{+{%$d}}:'ARRAY'eq$r?sub{[@$d]}:'CODE'eq$r?$d:sub{$d};my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=$g and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$g->(@_):$m->(@_)}}};*{$M.'builder::e'}=sub{my($P,$e,$o)=@_;$o->{builder}=sub{my($m,$n,%a)=@_;my$b=$a{builder}or return$m;my$i=exists$a{lazy}?$a{lazy}:!${$P.':N'};$i or ${$P.':E'}{$n}=\&{$P.$b}and return$m;sub{$#_?$m->(@_):!exists$_[0]{$n}?$_[0]{$n}=$_[0]->$b:$m->(@_)}}};use constant XXX_skip=>1;my$dm='YAML::XS';*{$M.'xxx::e'}=sub{my($P,$e)=@_;$e->{WWW}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::WWW(@_)};$e->{XXX}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::XXX(@_)};$e->{YYY}=sub{require XXX;local$XXX::DumpModule=$dm;XXX::YYY(@_)};$e->{ZZZ}=sub{require XXX;local$XXX::DumpModule=$dm}};my$i=\&import;*{$M.import}=sub{(@_==2 and not$_[1])?pop@_:@_==1?push@_,grep!/import/,@f:();goto&$i};@f=qw[build default builder xxx import];use strict;use warnings; our $DumpModule = 'YAML'; 1; PK � �[��#� TestML.pmnu �[��� package TestML; use TestML::Base; our $VERSION = '0.49'; has runtime => (); has compiler => (); has bridge => (); has library => (); has testml => (); sub run { my ($self) = @_; $self->set_default_classes; $self->runtime->new( compiler => $self->compiler, bridge => $self->bridge, library => $self->library, testml => $self->testml, )->run; } sub set_default_classes { my ($self) = @_; if (not $self->runtime) { require TestML::Runtime::TAP; $self->{runtime} = 'TestML::Runtime::TAP'; } if (not $self->compiler) { require TestML::Compiler::Pegex; $self->{compiler} = 'TestML::Compiler::Pegex'; } if (not $self->bridge) { require TestML::Bridge; $self->{bridge} = 'TestML::Bridge'; } if (not $self->library) { require TestML::Library::Standard; require TestML::Library::Debug; $self->{library} = [ 'TestML::Library::Standard', 'TestML::Library::Debug', ]; } } 1; PK � �[����� � Test/Base/Filter.pmnu �[��� #=============================================================================== # This is the default class for handling Test::Base data filtering. #=============================================================================== package Test::Base::Filter; use Spiffy -Base; use Spiffy ':XXX'; field 'current_block'; our $arguments; sub current_arguments { return undef unless defined $arguments; my $args = $arguments; $args =~ s/(\\s)/ /g; $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee; return $args; } sub assert_scalar { return if @_ == 1; require Carp; my $filter = (caller(1))[3]; $filter =~ s/.*:://; Carp::croak "Input to the '$filter' filter must be a scalar, not a list"; } sub _apply_deepest { my $method = shift; return () unless @_; if (ref $_[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_apply_deepest($method, @$aref); } return @_; } $self->$method(@_); } sub _split_array { map { [$self->split($_)]; } @_; } sub _peel_deepest { return () unless @_; if (ref $_[0] eq 'ARRAY') { if (ref $_[0]->[0] eq 'ARRAY') { for my $aref (@_) { @$aref = $self->_peel_deepest(@$aref); } return @_; } return map { $_->[0] } @_; } return @_; } #=============================================================================== # these filters work on the leaves of nested arrays #=============================================================================== sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) } sub Reverse { $self->_apply_deepest(reverse => @_) } sub Split { $self->_apply_deepest(_split_array => @_) } sub Sort { $self->_apply_deepest(sort => @_) } sub append { my $suffix = $self->current_arguments; map { $_ . $suffix } @_; } sub array { return [@_]; } sub base64_decode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::decode_base64(shift); } sub base64_encode { $self->assert_scalar(@_); require MIME::Base64; MIME::Base64::encode_base64(shift); } sub chomp { map { CORE::chomp; $_ } @_; } sub chop { map { CORE::chop; $_ } @_; } sub dumper { no warnings 'once'; require Data::Dumper; local $Data::Dumper::Sortkeys = 1; local $Data::Dumper::Indent = 1; local $Data::Dumper::Terse = 1; Data::Dumper::Dumper(@_); } sub escape { $self->assert_scalar(@_); my $text = shift; $text =~ s/(\\.)/eval "qq{$1}"/ge; return $text; } sub eval { $self->assert_scalar(@_); my @return = CORE::eval(shift); return $@ if $@; return @return; } sub eval_all { $self->assert_scalar(@_); my $out = ''; my $err = ''; Test::Base::tie_output(*STDOUT, $out); Test::Base::tie_output(*STDERR, $err); my $return = CORE::eval(shift); no warnings; untie *STDOUT; untie *STDERR; return $return, $@, $out, $err; } sub eval_stderr { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDERR, $output); CORE::eval(shift); no warnings; untie *STDERR; return $output; } sub eval_stdout { $self->assert_scalar(@_); my $output = ''; Test::Base::tie_output(*STDOUT, $output); CORE::eval(shift); no warnings; untie *STDOUT; return $output; } sub exec_perl_stdout { my $tmpfile = "/tmp/test-blocks-$$"; $self->_write_to($tmpfile, @_); open my $execution, "$^X $tmpfile 2>&1 |" or die "Couldn't open subprocess: $!\n"; local $/; my $output = <$execution>; close $execution; unlink($tmpfile) or die "Couldn't unlink $tmpfile: $!\n"; return $output; } sub flatten { $self->assert_scalar(@_); my $ref = shift; if (ref($ref) eq 'HASH') { return map { ($_, $ref->{$_}); } sort keys %$ref; } if (ref($ref) eq 'ARRAY') { return @$ref; } die "Can only flatten a hash or array ref"; } sub get_url { $self->assert_scalar(@_); my $url = shift; CORE::chomp($url); require LWP::Simple; LWP::Simple::get($url); } sub hash { return +{ @_ }; } sub head { my $size = $self->current_arguments || 1; return splice(@_, 0, $size); } sub join { my $string = $self->current_arguments; $string = '' unless defined $string; CORE::join $string, @_; } sub lines { $self->assert_scalar(@_); my $text = shift; return () unless length $text; my @lines = ($text =~ /^(.*\n?)/gm); return @lines; } sub norm { $self->assert_scalar(@_); my $text = shift; $text = '' unless defined $text; $text =~ s/\015\012/\n/g; $text =~ s/\r/\n/g; return $text; } sub prepend { my $prefix = $self->current_arguments; map { $prefix . $_ } @_; } sub read_file { $self->assert_scalar(@_); my $file = shift; CORE::chomp $file; open my $fh, $file or die "Can't open '$file' for input:\n$!"; CORE::join '', <$fh>; } sub regexp { $self->assert_scalar(@_); my $text = shift; my $flags = $self->current_arguments; if ($text =~ /\n.*?\n/s) { $flags = 'xism' unless defined $flags; } else { CORE::chomp($text); } $flags ||= ''; my $regexp = eval "qr{$text}$flags"; die $@ if $@; return $regexp; } sub reverse { CORE::reverse(@_); } sub slice { die "Invalid args for slice" unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/; my ($x, $y) = ($1, $2); $y = $x if not defined $y; die "Invalid args for slice" if $x > $y; return splice(@_, $x, 1 + $y - $x); } sub sort { CORE::sort(@_); } sub split { $self->assert_scalar(@_); my $separator = $self->current_arguments; if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) { my $regexp = $1; $separator = qr{$regexp}; } $separator = qr/\s+/ unless $separator; CORE::split $separator, shift; } sub strict { $self->assert_scalar(@_); <<'...' . shift; use strict; use warnings; ... } sub tail { my $size = $self->current_arguments || 1; return splice(@_, @_ - $size, $size); } sub trim { map { s/\A([ \t]*\n)+//; s/(?<=\n)\s*\z//g; $_; } @_; } sub unchomp { map { $_ . "\n" } @_; } sub write_file { my $file = $self->current_arguments or die "No file specified for write_file filter"; if ($file =~ /(.*)[\\\/]/) { my $dir = $1; if (not -e $dir) { require File::Path; File::Path::mkpath($dir) or die "Can't create $dir"; } } open my $fh, ">$file" or die "Can't open '$file' for output\n:$!"; print $fh @_; close $fh; return $file; } sub yaml { $self->assert_scalar(@_); require YAML; return YAML::Load(shift); } sub _write_to { my $filename = shift; open my $script, ">$filename" or die "Couldn't open $filename: $!\n"; print $script @_; close $script or die "Couldn't close $filename: $!\n"; } 1; PK � �[Yh� �G �G Test/Base.pmnu �[��� package Test::Base; our $VERSION = '0.89'; use Spiffy -Base; use Spiffy ':XXX'; my $HAS_PROVIDER; BEGIN { $HAS_PROVIDER = eval "require Test::Builder::Provider; 1"; if ($HAS_PROVIDER) { Test::Builder::Provider->import('provides'); } else { *provides = sub { 1 }; } } my @test_more_exports; BEGIN { @test_more_exports = qw( ok isnt like unlike is_deeply cmp_ok skip todo_skip pass fail eq_array eq_hash eq_set plan can_ok isa_ok diag use_ok $TODO ); } use Test::More import => \@test_more_exports; use Carp; our @EXPORT = (@test_more_exports, qw( is no_diff blocks next_block first_block delimiters spec_file spec_string filters filters_delay filter_arguments run run_compare run_is run_is_deeply run_like run_unlike skip_all_unless_require is_deep run_is_deep WWW XXX YYY ZZZ tie_output no_diag_on_only find_my_self default_object croak carp cluck confess )); field '_spec_file'; field '_spec_string'; field _filters => [qw(norm trim)]; field _filters_map => {}; field spec => -init => '$self->_spec_init'; field block_list => -init => '$self->_block_list_init'; field _next_list => []; field block_delim => -init => '$self->block_delim_default'; field data_delim => -init => '$self->data_delim_default'; field _filters_delay => 0; field _no_diag_on_only => 0; field block_delim_default => '==='; field data_delim_default => '---'; my $default_class; my $default_object; my $reserved_section_names = {}; sub default_object { $default_object ||= $default_class->new; return $default_object; } my $import_called = 0; sub import() { $import_called = 1; my $class = (grep /^-base$/i, @_) ? scalar(caller) : $_[0]; if (not defined $default_class) { $default_class = $class; } # else { # croak "Can't use $class after using $default_class" # unless $default_class->isa($class); # } unless (grep /^-base$/i, @_) { my @args; for (my $ii = 1; $ii <= $#_; ++$ii) { if ($_[$ii] eq '-package') { ++$ii; } else { push @args, $_[$ii]; } } Test::More->import(import => \@test_more_exports, @args) if @args; } _strict_warnings(); goto &Spiffy::import; } # Wrap Test::Builder::plan my $plan_code = \&Test::Builder::plan; my $Have_Plan = 0; { no warnings 'redefine'; *Test::Builder::plan = sub { $Have_Plan = 1; goto &$plan_code; }; } my $DIED = 0; $SIG{__DIE__} = sub { $DIED = 1; die @_ }; sub block_class { $self->find_class('Block') } sub filter_class { $self->find_class('Filter') } sub find_class { my $suffix = shift; my $class = ref($self) . "::$suffix"; return $class if $class->can('new'); $class = __PACKAGE__ . "::$suffix"; return $class if $class->can('new'); eval "require $class"; return $class if $class->can('new'); die "Can't find a class for $suffix"; } sub check_late { if ($self->{block_list}) { my $caller = (caller(1))[3]; $caller =~ s/.*:://; croak "Too late to call $caller()" } } sub find_my_self() { my $self = ref($_[0]) eq $default_class ? splice(@_, 0, 1) : default_object(); return $self, @_; } sub blocks() { (my ($self), @_) = find_my_self(@_); croak "Invalid arguments passed to 'blocks'" if @_ > 1; croak sprintf("'%s' is invalid argument to blocks()", shift(@_)) if @_ && $_[0] !~ /^[a-zA-Z]\w*$/; my $blocks = $self->block_list; my $section_name = shift || ''; my @blocks = $section_name ? (grep { exists $_->{$section_name} } @$blocks) : (@$blocks); return scalar(@blocks) unless wantarray; return (@blocks) if $self->_filters_delay; for my $block (@blocks) { $block->run_filters unless $block->is_filtered; } return (@blocks); } sub next_block() { (my ($self), @_) = find_my_self(@_); my $list = $self->_next_list; if (@$list == 0) { $list = [@{$self->block_list}, undef]; $self->_next_list($list); } my $block = shift @$list; if (defined $block and not $block->is_filtered) { $block->run_filters; } return $block; } sub first_block() { (my ($self), @_) = find_my_self(@_); $self->_next_list([]); $self->next_block; } sub filters_delay() { (my ($self), @_) = find_my_self(@_); $self->_filters_delay(defined $_[0] ? shift : 1); } sub no_diag_on_only() { (my ($self), @_) = find_my_self(@_); $self->_no_diag_on_only(defined $_[0] ? shift : 1); } sub delimiters() { (my ($self), @_) = find_my_self(@_); $self->check_late; my ($block_delimiter, $data_delimiter) = @_; $block_delimiter ||= $self->block_delim_default; $data_delimiter ||= $self->data_delim_default; $self->block_delim($block_delimiter); $self->data_delim($data_delimiter); return $self; } sub spec_file() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_file(shift); return $self; } sub spec_string() { (my ($self), @_) = find_my_self(@_); $self->check_late; $self->_spec_string(shift); return $self; } sub filters() { (my ($self), @_) = find_my_self(@_); if (ref($_[0]) eq 'HASH') { $self->_filters_map(shift); } else { my $filters = $self->_filters; push @$filters, @_; } return $self; } sub filter_arguments() { $Test::Base::Filter::arguments; } sub have_text_diff { eval { require Text::Diff; 1 } && $Text::Diff::VERSION >= 0.35 && $Algorithm::Diff::VERSION >= 1.15; } provides 'is'; sub is($$;$) { (my ($self), @_) = find_my_self(@_); my ($actual, $expected, $name) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1 unless $HAS_PROVIDER; if ($ENV{TEST_SHOW_NO_DIFFS} or not defined $actual or not defined $expected or $actual eq $expected or not($self->have_text_diff) or $expected !~ /\n./s ) { Test::More::is($actual, $expected, $name); } else { $name = '' unless defined $name; ok $actual eq $expected, $name; diag Text::Diff::diff(\$expected, \$actual); } } sub run(&;$) { (my ($self), @_) = find_my_self(@_); my $callback = shift; for my $block (@{$self->block_list}) { $block->run_filters unless $block->is_filtered; &{$callback}($block); } } my $name_error = "Can't determine section names"; sub _section_names { return unless defined $self->spec; return @_ if @_ == 2; my $block = $self->first_block or croak $name_error; my @names = grep { $_ !~ /^(ONLY|LAST|SKIP)$/; } @{$block->{_section_order}[0] || []}; croak "$name_error. Need two sections in first block" unless @names == 2; return @names; } sub _assert_plan { plan('no_plan') unless $Have_Plan; } sub END { run_compare() unless $Have_Plan or $DIED or not $import_called; } sub run_compare() { (my ($self), @_) = find_my_self(@_); return unless defined $self->spec; $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; if (ref $block->$x) { is_deeply($block->$x, $block->$y, $block->name ? $block->name : ()); } elsif (ref $block->$y eq 'Regexp') { my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : ()); } else { is($block->$x, $block->$y, $block->name ? $block->name : ()); } } } sub run_is() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); local $Test::Builder::Level = $Test::Builder::Level + 1; for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_is_deeply() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deeply($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub run_like() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; like($block->$x, $regexp, $block->name ? $block->name : () ); } } sub run_unlike() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and defined($y); $block->run_filters unless $block->is_filtered; my $regexp = ref $y ? $y : $block->$y; unlike($block->$x, $regexp, $block->name ? $block->name : () ); } } sub skip_all_unless_require() { (my ($self), @_) = find_my_self(@_); my $module = shift; eval "require $module; 1" or Test::More::plan( skip_all => "$module failed to load" ); } sub is_deep() { (my ($self), @_) = find_my_self(@_); require Test::Deep; Test::Deep::cmp_deeply(@_); } sub run_is_deep() { (my ($self), @_) = find_my_self(@_); $self->_assert_plan; my ($x, $y) = $self->_section_names(@_); for my $block (@{$self->block_list}) { next unless exists($block->{$x}) and exists($block->{$y}); $block->run_filters unless $block->is_filtered; is_deep($block->$x, $block->$y, $block->name ? $block->name : () ); } } sub _pre_eval { my $spec = shift; return unless defined $spec; return $spec unless $spec =~ s/\A\s*<<<(.*?)>>>\s*$//sm; my $eval_code = $1; eval "package main; $eval_code"; croak $@ if $@; return $spec; } sub _block_list_init { my $spec = $self->spec; return [] unless defined $spec; $spec = $self->_pre_eval($spec); my $cd = $self->block_delim; my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg); my $blocks = $self->_choose_blocks(@hunks); $self->block_list($blocks); # Need to set early for possible filter use my $seq = 1; for my $block (@$blocks) { $block->blocks_object($self); $block->seq_num($seq++); } return $blocks; } sub _choose_blocks { my $blocks = []; for my $hunk (@_) { my $block = $self->_make_block($hunk); if (exists $block->{ONLY}) { diag "I found ONLY: maybe you're debugging?" unless $self->_no_diag_on_only; return [$block]; } next if exists $block->{SKIP}; push @$blocks, $block; if (exists $block->{LAST}) { return $blocks; } } return $blocks; } sub _check_reserved { my $id = shift; croak "'$id' is a reserved name. Use something else.\n" if $reserved_section_names->{$id} or $id =~ /^_/; } sub _make_block { my $hunk = shift; my $cd = $self->block_delim; my $dd = $self->data_delim; my $block = $self->block_class->new; $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die; my $name = $1; my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk; my $description = shift @parts; $description ||= ''; unless ($description =~ /\S/) { $description = $name; } $description =~ s/\s*\z//; $block->set_value(description => $description); my $section_map = {}; my $section_order = []; while (@parts) { my ($type, $filters, $value) = splice(@parts, 0, 3); $self->_check_reserved($type); $value = '' unless defined $value; $filters = '' unless defined $filters; if ($filters =~ /:(\s|\z)/) { croak "Extra lines not allowed in '$type' section" if $value =~ /\S/; ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2; $value = '' unless defined $value; $value =~ s/^\s*(.*?)\s*$/$1/; } $section_map->{$type} = { filters => $filters, }; push @$section_order, $type; $block->set_value($type, $value); } $block->set_value(name => $name); $block->set_value(_section_map => $section_map); $block->set_value(_section_order => $section_order); return $block; } sub _spec_init { return $self->_spec_string if $self->_spec_string; local $/; my $spec; if (my $spec_file = $self->_spec_file) { open FILE, $spec_file or die $!; $spec = <FILE>; close FILE; } else { require Scalar::Util; my $handle = Scalar::Util::openhandle( \*main::DATA ); if ($handle) { $spec = <$handle>; } } return $spec; } sub _strict_warnings() { require Filter::Util::Call; my $done = 0; Filter::Util::Call::filter_add( sub { return 0 if $done; my ($data, $end) = ('', ''); while (my $status = Filter::Util::Call::filter_read()) { return $status if $status < 0; if (/^__(?:END|DATA)__\r?$/) { $end = $_; last; } $data .= $_; $_ = ''; } $_ = "use strict;use warnings;$data$end"; $done = 1; } ); } sub tie_output() { my $handle = shift; die "No buffer to tie" unless @_; tie *$handle, 'Test::Base::Handle', $_[0]; } sub no_diff { $ENV{TEST_SHOW_NO_DIFFS} = 1; } package Test::Base::Handle; sub TIEHANDLE() { my $class = shift; bless \ $_[0], $class; } sub PRINT { $$self .= $_ for @_; } #=============================================================================== # Test::Base::Block # # This is the default class for accessing a Test::Base block object. #=============================================================================== package Test::Base::Block; our @ISA = qw(Spiffy); our @EXPORT = qw(block_accessor); sub AUTOLOAD { return; } sub block_accessor() { my $accessor = shift; no strict 'refs'; return if defined &$accessor; *$accessor = sub { my $self = shift; if (@_) { Carp::croak "Not allowed to set values for '$accessor'"; } my @list = @{$self->{$accessor} || []}; return wantarray ? (@list) : $list[0]; }; } block_accessor 'name'; block_accessor 'description'; Spiffy::field 'seq_num'; Spiffy::field 'is_filtered'; Spiffy::field 'blocks_object'; Spiffy::field 'original_values' => {}; sub set_value { no strict 'refs'; my $accessor = shift; block_accessor $accessor unless defined &$accessor; $self->{$accessor} = [@_]; } sub run_filters { my $map = $self->_section_map; my $order = $self->_section_order; Carp::croak "Attempt to filter a block twice" if $self->is_filtered; for my $type (@$order) { my $filters = $map->{$type}{filters}; my @value = $self->$type; $self->original_values->{$type} = $value[0]; for my $filter ($self->_get_filters($type, $filters)) { $Test::Base::Filter::arguments = $filter =~ s/=(.*)$// ? $1 : undef; my $function = "main::$filter"; no strict 'refs'; if (defined &$function) { local $_ = (@value == 1 and not defined($value[0])) ? undef : join '', @value; my $old = $_; @value = &$function(@value); if (not(@value) or @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/ ) { if ($value[0] && $_ eq $old) { Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't."); } @value = ($_); } } else { my $filter_object = $self->blocks_object->filter_class->new; die "Can't find a function or method for '$filter' filter\n" unless $filter_object->can($filter); $filter_object->current_block($self); @value = $filter_object->$filter(@value); } # Set the value after each filter since other filters may be # introspecting. $self->set_value($type, @value); } } $self->is_filtered(1); } sub _get_filters { my $type = shift; my $string = shift || ''; $string =~ s/\s*(.*?)\s*/$1/; my @filters = (); my $map_filters = $self->blocks_object->_filters_map->{$type} || []; $map_filters = [ $map_filters ] unless ref $map_filters; my @append = (); for ( @{$self->blocks_object->_filters}, @$map_filters, split(/\s+/, $string), ) { my $filter = $_; last unless length $filter; if ($filter =~ s/^-//) { @filters = grep { $_ ne $filter } @filters; } elsif ($filter =~ s/^\+//) { push @append, $filter; } else { push @filters, $filter; } } return @filters, @append; } { %$reserved_section_names = map { ($_, 1); } keys(%Test::Base::Block::), qw( new DESTROY ); } 1; PK � �[�+_}< }< Spiffy.pmnu �[��� use strict; use warnings; package Spiffy; our $VERSION = '0.46'; use Carp; require Exporter; our @EXPORT = (); our @EXPORT_BASE = qw(field const stub super); our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ)); our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]); my $stack_frame = 0; my $dump = 'yaml'; my $bases_map = {}; sub WWW; sub XXX; sub YYY; sub ZZZ; # This line is here to convince "autouse" into believing we are autousable. sub can { ($_[1] eq 'import' and caller()->isa('autouse')) ? \&Exporter::import # pacify autouse's equality test : $_[0]->SUPER::can($_[1]) # normal case } # TODO # # Exported functions like field and super should be hidden so as not to # be confused with methods that can be inherited. # sub new { my $class = shift; $class = ref($class) || $class; my $self = bless {}, $class; while (@_) { my $method = shift; $self->$method(shift); } return $self; } my $filtered_files = {}; my $filter_dump = 0; my $filter_save = 0; our $filter_result = ''; sub import { no strict 'refs'; no warnings; my $self_package = shift; # XXX Using parse_arguments here might cause confusion, because the # subclass's boolean_arguments and paired_arguments can conflict, causing # difficult debugging. Consider using something truly local. my ($args, @export_list) = do { local *boolean_arguments = sub { qw( -base -Base -mixin -selfless -XXX -dumper -yaml -filter_dump -filter_save ) }; local *paired_arguments = sub { qw(-package) }; $self_package->parse_arguments(@_); }; return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list) if $args->{-mixin}; $filter_dump = 1 if $args->{-filter_dump}; $filter_save = 1 if $args->{-filter_save}; $dump = 'yaml' if $args->{-yaml}; $dump = 'dumper' if $args->{-dumper}; local @EXPORT_BASE = @EXPORT_BASE; if ($args->{-XXX}) { push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}} unless grep /^XXX$/, @EXPORT_BASE; } spiffy_filter() if ($args->{-selfless} or $args->{-Base}) and not $filtered_files->{(caller($stack_frame))[1]}++; my $caller_package = $args->{-package} || caller($stack_frame); push @{"$caller_package\::ISA"}, $self_package if $args->{-Base} or $args->{-base}; for my $class (@{all_my_bases($self_package)}) { next unless $class->isa('Spiffy'); my @export = grep { not defined &{"$caller_package\::$_"}; } ( @{"$class\::EXPORT"}, ($args->{-Base} or $args->{-base}) ? @{"$class\::EXPORT_BASE"} : (), ); my @export_ok = grep { not defined &{"$caller_package\::$_"}; } @{"$class\::EXPORT_OK"}; # Avoid calling the expensive Exporter::export # if there is nothing to do (optimization) my %exportable = map { ($_, 1) } @export, @export_ok; next unless keys %exportable; my @export_save = @{"$class\::EXPORT"}; my @export_ok_save = @{"$class\::EXPORT_OK"}; @{"$class\::EXPORT"} = @export; @{"$class\::EXPORT_OK"} = @export_ok; my @list = grep { (my $v = $_) =~ s/^[\!\:]//; $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v}; } @export_list; Exporter::export($class, $caller_package, @list); @{"$class\::EXPORT"} = @export_save; @{"$class\::EXPORT_OK"} = @export_ok_save; } } sub spiffy_filter { require Filter::Util::Call; my $done = 0; Filter::Util::Call::filter_add( sub { return 0 if $done; my ($data, $end) = ('', ''); while (my $status = Filter::Util::Call::filter_read()) { return $status if $status < 0; if (/^__(?:END|DATA)__\r?$/) { $end = $_; last; } $data .= $_; $_ = ''; } $_ = $data; my @my_subs; s[^(sub\s+\w+\s+\{)(.*\n)] [${1}my \$self = shift;$2]gm; s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)] [${1}${2}]gm; s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n] [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem; my $preclare = ''; if (@my_subs) { $preclare = join ',', map "\$$_", @my_subs; $preclare = "my($preclare);"; } $_ = "use strict;use warnings;$preclare${_};1;\n$end"; if ($filter_dump) { print; exit } if ($filter_save) { $filter_result = $_; $_ = $filter_result; } $done = 1; } ); } sub base { push @_, -base; goto &import; } sub all_my_bases { my $class = shift; return $bases_map->{$class} if defined $bases_map->{$class}; my @bases = ($class); no strict 'refs'; for my $base_class (@{"${class}::ISA"}) { push @bases, @{all_my_bases($base_class)}; } my $used = {}; $bases_map->{$class} = [grep {not $used->{$_}++} @bases]; } my %code = ( sub_start => "sub {\n", set_default => " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n", init => " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" . " unless \$#_ > 0 or defined \$_[0]->{%s};\n", weak_init => " return do {\n" . " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" . " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" . " \$_[0]->{%s};\n" . " } unless \$#_ > 0 or defined \$_[0]->{%s};\n", return_if_get => " return \$_[0]->{%s} unless \$#_ > 0;\n", set => " \$_[0]->{%s} = \$_[1];\n", weaken => " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n", sub_end => " return \$_[0]->{%s};\n}\n", ); sub field { my $package = caller; my ($args, @values) = do { no warnings; local *boolean_arguments = sub { (qw(-weak)) }; local *paired_arguments = sub { (qw(-package -init)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; die "Cannot have a default for a weakened field ($field)" if defined $default && $args->{-weak}; return if defined &{"${package}::$field"}; require Scalar::Util if $args->{-weak}; my $default_string = ( ref($default) eq 'ARRAY' and not @$default ) ? '[]' : (ref($default) eq 'HASH' and not keys %$default ) ? '{}' : default_as_code($default); my $code = $code{sub_start}; if ($args->{-init}) { my $fragment = $args->{-weak} ? $code{weak_init} : $code{init}; my @count = ($fragment =~ /(%s)/g); $code .= sprintf $fragment, $field, $args->{-init}, ($field) x (@count - 2); } $code .= sprintf $code{set_default}, $field, $default_string, $field if defined $default; $code .= sprintf $code{return_if_get}, $field; $code .= sprintf $code{set}, $field; $code .= sprintf $code{weaken}, $field, $field if $args->{-weak}; $code .= sprintf $code{sub_end}, $field; my $sub = eval $code; die $@ if $@; no strict 'refs'; *{"${package}::$field"} = $sub; return $code if defined wantarray; } sub default_as_code { require Data::Dumper; local $Data::Dumper::Sortkeys = 1; my $code = Data::Dumper::Dumper(shift); $code =~ s/^\$VAR1 = //; $code =~ s/;$//; return $code; } sub const { my $package = caller; my ($args, @values) = do { no warnings; local *paired_arguments = sub { (qw(-package)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; no strict 'refs'; return if defined &{"${package}::$field"}; *{"${package}::$field"} = sub { $default } } sub stub { my $package = caller; my ($args, @values) = do { no warnings; local *paired_arguments = sub { (qw(-package)) }; Spiffy->parse_arguments(@_); }; my ($field, $default) = @values; $package = $args->{-package} if defined $args->{-package}; no strict 'refs'; return if defined &{"${package}::$field"}; *{"${package}::$field"} = sub { require Carp; Carp::confess "Method $field in package $package must be subclassed"; } } sub parse_arguments { my $class = shift; my ($args, @values) = ({}, ()); my %booleans = map { ($_, 1) } $class->boolean_arguments; my %pairs = map { ($_, 1) } $class->paired_arguments; while (@_) { my $elem = shift; if (defined $elem and defined $booleans{$elem}) { $args->{$elem} = (@_ and $_[0] =~ /^[01]$/) ? shift : 1; } elsif (defined $elem and defined $pairs{$elem} and @_) { $args->{$elem} = shift; } else { push @values, $elem; } } return wantarray ? ($args, @values) : $args; } sub boolean_arguments { () } sub paired_arguments { () } # get a unique id for any node sub id { if (not ref $_[0]) { return 'undef' if not defined $_[0]; \$_[0] =~ /\((\w+)\)$/o or die; return "$1-S"; } require overload; overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die; return $1; } #=============================================================================== # It's super, man. #=============================================================================== package DB; { no warnings 'redefine'; sub super_args { my @dummy = caller(@_ ? $_[0] : 2); return @DB::args; } } package Spiffy; sub super { my $method; my $frame = 1; while ($method = (caller($frame++))[3]) { $method =~ s/.*::// and last; } my @args = DB::super_args($frame); @_ = @_ ? ($args[0], @_) : @args; my $class = ref $_[0] ? ref $_[0] : $_[0]; my $caller_class = caller; my $seen = 0; my @super_classes = reverse grep { ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1; } reverse @{all_my_bases($class)}; for my $super_class (@super_classes) { no strict 'refs'; next if $super_class eq $class; if (defined &{"${super_class}::$method"}) { ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"} if $method eq 'AUTOLOAD'; return &{"${super_class}::$method"}; } } return; } #=============================================================================== # This code deserves a spanking, because it is being very naughty. # It is exchanging base.pm's import() for its own, so that people # can use base.pm with Spiffy modules, without being the wiser. #=============================================================================== my $real_base_import; my $real_mixin_import; BEGIN { require base unless defined $INC{'base.pm'}; $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm'; $real_base_import = \&base::import; $real_mixin_import = \&mixin::import; no warnings; *base::import = \&spiffy_base_import; *mixin::import = \&spiffy_mixin_import; } # my $i = 0; # while (my $caller = caller($i++)) { # next unless $caller eq 'base' or $caller eq 'mixin'; # croak <<END; # Spiffy.pm must be loaded before calling 'use base' or 'use mixin' with a # Spiffy module. See the documentation of Spiffy.pm for details. # END # } sub spiffy_base_import { my @base_classes = @_; shift @base_classes; no strict 'refs'; goto &$real_base_import unless grep { eval "require $_" unless %{"$_\::"}; $_->isa('Spiffy'); } @base_classes; my $inheritor = caller(0); for my $base_class (@base_classes) { next if $inheritor->isa($base_class); croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n", "See the documentation of Spiffy.pm for details\n " unless $base_class->isa('Spiffy'); $stack_frame = 1; # tell import to use different caller import($base_class, '-base'); $stack_frame = 0; } } sub mixin { my $self = shift; my $target_class = ref($self); spiffy_mixin_import($target_class, @_) } sub spiffy_mixin_import { my $target_class = shift; $target_class = caller(0) if $target_class eq 'mixin'; my $mixin_class = shift or die "Nothing to mixin"; eval "require $mixin_class"; my @roles = @_; my $pseudo_class = join '-', $target_class, $mixin_class, @roles; my %methods = spiffy_mixin_methods($mixin_class, @roles); no strict 'refs'; no warnings; @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"}; @{"$target_class\::ISA"} = ($pseudo_class); for (keys %methods) { *{"$pseudo_class\::$_"} = $methods{$_}; } } sub spiffy_mixin_methods { my $mixin_class = shift; no strict 'refs'; my %methods = spiffy_all_methods($mixin_class); map { $methods{$_} ? ($_, \ &{"$methods{$_}\::$_"}) : ($_, \ &{"$mixin_class\::$_"}) } @_ ? (get_roles($mixin_class, @_)) : (keys %methods); } sub get_roles { my $mixin_class = shift; my @roles = @_; while (grep /^!*:/, @roles) { @roles = map { s/!!//g; /^!:(.*)/ ? do { my $m = "_role_$1"; map("!$_", $mixin_class->$m); } : /^:(.*)/ ? do { my $m = "_role_$1"; ($mixin_class->$m); } : ($_) } @roles; } if (@roles and $roles[0] =~ /^!/) { my %methods = spiffy_all_methods($mixin_class); unshift @roles, keys(%methods); } my %roles; for (@roles) { s/!!//g; delete $roles{$1}, next if /^!(.*)/; $roles{$_} = 1; } keys %roles; } sub spiffy_all_methods { no strict 'refs'; my $class = shift; return if $class eq 'Spiffy'; my %methods = map { ($_, $class) } grep { defined &{"$class\::$_"} and not /^_/ } keys %{"$class\::"}; my %super_methods; %super_methods = spiffy_all_methods(${"$class\::ISA"}[0]) if @{"$class\::ISA"}; %{{%super_methods, %methods}}; } # END of naughty code. #=============================================================================== # Debugging support #=============================================================================== sub spiffy_dump { no warnings; if ($dump eq 'dumper') { require Data::Dumper; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Indent = 1; return Data::Dumper::Dumper(@_); } require YAML; $YAML::UseVersion = 0; return YAML::Dump(@_) . "...\n"; } sub at_line_number { my ($file_path, $line_number) = (caller(1))[1,2]; " at $file_path line $line_number\n"; } sub WWW { warn spiffy_dump(@_) . at_line_number; return wantarray ? @_ : $_[0]; } sub XXX { die spiffy_dump(@_) . at_line_number; } sub YYY { print spiffy_dump(@_) . at_line_number; return wantarray ? @_ : $_[0]; } sub ZZZ { require Carp; Carp::confess spiffy_dump(@_); } 1; PK T/�[���& & headerfile.hnu �[��� int foo(void); int libversion(void); PK � �[�\�� � Pegex.pmnu �[��� PK � �[����7 7 ( Pegex/Tree.pmnu �[��� PK � �[��؈� � � Pegex/Parser.pmnu �[��� PK � �[{ۣ��6 �6 �# Pegex/Bootstrap.pmnu �[��� PK � �[�ZT�� � �Z Pegex/Receiver.pmnu �[��� PK � �[�� � � �\ Pegex/Compiler.pmnu �[��� PK � �[�lyF: : �o Pegex/Optimizer.pmnu �[��� PK � �[D ��# # Pegex/Input.pmnu �[��� PK � �[�υ � Pegex/Base.pmnu �[��� PK � �[�Z�� Ŏ Pegex/Grammar.pmnu �[��� PK � �[uA� � TestML/Library/Debug.pmnu �[��� PK � �[�� h� TestML/Library/Standard.pmnu �[��� PK � �[`��{ { Ϯ TestML/Compiler/Lite.pmnu �[��� PK � �[1�#� �� TestML/Compiler/Pegex.pmnu �[��� PK � �[��]�� � �� TestML/Compiler/Pegex/AST.pmnu �[��� PK � �[���a) a) �� TestML/Compiler/Pegex/Grammar.pmnu �[��� PK � �[�Q��L L � TestML/Bridge.pmnu �[��� PK � �[�a�� � 4 TestML/Util.pmnu �[��� PK � �[�"���1 �1 X TestML/Runtime.pmnu �[��� PK � �[B��=� � }; TestML/Runtime/TAP.pmnu �[��� PK � �[G � BE TestML/Compiler.pmnu �[��� PK � �[C��t� � �S TestML/Base.pmnu �[��� PK � �[��#� �[ TestML.pmnu �[��� PK � �[����� � �_ Test/Base/Filter.pmnu �[��� PK � �[Yh� �G �G | Test/Base.pmnu �[��� PK � �[�+_}< }< �� Spiffy.pmnu �[��� PK T/�[���& & � headerfile.hnu �[��� PK � �
| ver. 1.6 |
Github
|
.
| PHP 8.2.30 | ??????????? ?????????: 0 |
proxy
|
phpinfo
|
???????????