From: Will Budic Date: Thu, 13 Nov 2025 10:24:23 +0000 (+1100) Subject: New test file for collections and doProcessCollection subrotine. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=9dab2432da0424308772b4edf722c60233436674;p=PerlCNF.git New test file for collections and doProcessCollection subrotine. --- diff --git a/system/modules/CNFMeta.pm b/system/modules/CNFMeta.pm index fb4fa47..1d88ad0 100644 --- a/system/modules/CNFMeta.pm +++ b/system/modules/CNFMeta.pm @@ -71,6 +71,8 @@ sub _import_into_this_package { # Process or load last (includes get priority 1, tree type will get priority 4). *{"${caller}::meta_process_last"} = sub {return _meta("PROCESS_LAST")}; *{"${caller}::meta_const"} = sub {return _meta("CONST")}; + # Match whitespace as split delimiter. + *{"${caller}::meta_match_delimited"} = sub {return _meta("MATCH_DELIMITED")}; ### # Tree instruction has been scripted in collapsed nodes shorthand format. # Shortife is parsed faster and with less recursion, but can be prone to script errors, diff --git a/system/modules/CNFParser.pm b/system/modules/CNFParser.pm index bb2b500..a2bbc3c 100644 --- a/system/modules/CNFParser.pm +++ b/system/modules/CNFParser.pm @@ -130,6 +130,7 @@ our $meta_priority = meta_priority(); our $meta_on_demand = meta_on_demand(); our $meta_process_last = meta_process_last(); our $meta_const = meta_const(); +our $meta_delimited = meta_match_delimited(); ### @@ -462,7 +463,74 @@ sub template { my ($self, $property, %macros) = @_; } } # - +#private to parser sub. +sub doProcessCollection{ my($self,$e,$t,$v) = @_; + my $isArray = $t=~ m/^@/; + my $IsConstant = ($v =~ s/$meta_const/""/sexi); + my @lst = ($v =~ s/$meta_delimited// && $isArray?split(DELIMITER(), $v):split('\n', $v)); + my @props = map { + s/^\s+|\s+$//; # strip unwanted spaces + s/^\s*["']|['"]$//g;#strip quotes + #s/>+//;# strip dangling CNF tag + $_ ? $_ : undef # return the modified string + } @lst; + if($isArray){ + if($CNF::RESERVED_WORDS{$t}){ + $self->warn("ERROR collection is trying to use a reserved property name -> $t."); + next + }else{ + my @arr=(); + foreach (@props){ + push @arr, $_ if($_ && length($_)>0); + } + $properties{$t}=\@arr; + } + }else{ + my %hsh; + my $macro = 0; + if(exists($properties{$t})){ + if($CNF::RESERVED_WORDS{$t}){ + $self->warn("Skipped a try to overwrite a reserved property -> $t."); + next + }else{ + %hsh = %{$properties{$t}} + } + }else{ + %hsh =(); + } + foreach my $p(@props){ + if($p && $p eq 'MACRO'){$macro=1} + elsif( $p && length($p)>0 ){ + my @pair = ($p=~/\s*([-+_\w]*)\s*[=:]\s*(.*)/s);#split(/\s*=\s*/, $p); + next if (@pair != 2 || $pair[0] =~ m/^[#\\\/]+/m);#skip, it is a comment or not '=' delimited line. + my $name = $pair[0]; + my $value = $pair[1]; $value =~ s/^\s*["']|['"]$//g;#strip quotes + if($IsConstant && $p =~ m/\$[A-Z]+/){# if meta constant we check $p if signified to transfer into a CNF constance. + if(not exists $self->{$name}){ + $self->{$name} = $value; + next; + } + } + if($macro){ + my @arr = ($value =~ m/(\$\$\$.+?\$\$\$)/gm); + foreach my $find(@arr) { + my $s = $find; $s =~ s/^\$\$\$|\$\$\$$//g; + my $r = $anechoic->{$s}; + $r = $self->{$s} if !$r; + $r = $instructs{$s} if !$r; + CNFParserException->throw( + error=>"Unable to find property for $t.$name -> $find\n", + show_trace=>$self->{STACK_TRACE} + ) if !$r; + $value =~ s/\Q$find\E/$r/g; + } + } + $hsh{$name}=$value; $self->log("macro $t.$name->$value") if $self->{DEBUG} + } + } + $properties{$t}=\%hsh; + } +} #private to parser sub. sub doInstruction { my ($self,$e,$t,$v,$is_tagged) = @_; my $DO_ENABLED = $self->{'DO_ENABLED'}; my $priority = 4; my $isMetaConst; @@ -472,6 +540,10 @@ sub doInstruction { my ($self,$e,$t,$v,$is_tagged) = @_; $t = $itm->{ins}; $v = $itm->{val}; $priority = $itm->{'^'}; + if($t&&$t=~/^[@%]/){ #Is possibly numbered list collection type, with e not instruction the name. + doProcessCollection($self,$t,$e,$v); + return; + } } $is_tagged = defined($t); $t = $e if not $is_tagged; if($t eq 'CONST' or $t eq 'CONSTANT'){#Single constant with multiline value; @@ -912,72 +984,7 @@ sub parse { my ($self, $cnf_file, $content, $del_keys) = @_; } }elsif ($e =~ m/^@|%/){#collection processing? - my $isArray = $t=~ m/^@/; - my $IsConstant = ($v =~ s/$meta_const/""/sexi); - my @lst = ($isArray?split(DELIMITER(), $v):split('\n', $v)); - my @props = map { - s/^\s+|\s+$//; # strip unwanted spaces - s/^\s*["']|['"]$//g;#strip quotes - #s/>+//;# strip dangling CNF tag - $_ ? $_ : undef # return the modified string - } @lst; - if($isArray){ - if($CNF::RESERVED_WORDS{$t}){ - $self->warn("ERROR collection is trying to use a reserved property name -> $t."); - next - }else{ - my @arr=(); - foreach (@props){ - push @arr, $_ if($_ && length($_)>0); - } - $properties{$t}=\@arr; - } - }else{ - my %hsh; - my $macro = 0; - if(exists($properties{$t})){ - if($CNF::RESERVED_WORDS{$t}){ - $self->warn("Skipped a try to overwrite a reserved property -> $t."); - next - }else{ - %hsh = %{$properties{$t}} - } - }else{ - %hsh =(); - } - foreach my $p(@props){ - if($p && $p eq 'MACRO'){$macro=1} - elsif( $p && length($p)>0 ){ - my @pair = ($p=~/\s*([-+_\w]*)\s*[=:]\s*(.*)/s);#split(/\s*=\s*/, $p); - next if (@pair != 2 || $pair[0] =~ m/^[#\\\/]+/m);#skip, it is a comment or not '=' delimited line. - my $name = $pair[0]; - my $value = $pair[1]; $value =~ s/^\s*["']|['"]$//g;#strip quotes - if($IsConstant && $p =~ m/\$[A-Z]+/){# if meta constant we check $p if signified to transfer into a CNF constance. - if(not exists $self->{$name}){ - $self->{$name} = $value; - next; - } - } - if($macro){ - my @arr = ($value =~ m/(\$\$\$.+?\$\$\$)/gm); - foreach my $find(@arr) { - my $s = $find; $s =~ s/^\$\$\$|\$\$\$$//g; - my $r = $anechoic->{$s}; - $r = $self->{$s} if !$r; - $r = $instructs{$s} if !$r; - CNFParserException->throw( - error=>"Unable to find property for $t.$name -> $find\n", - show_trace=>$self->{STACK_TRACE} - ) if !$r; - $value =~ s/\Q$find\E/$r/g; - } - } - $hsh{$name}=$value; $self->log("macro $t.$name->$value") if $self->{DEBUG} - } - } - $properties{$t}=\%hsh; - } - next; + doProcessCollection($self,$e,$t,$v) }elsif(!$t && $e && $v){ $anechoic->{$e} = $v; }else{ diff --git a/tests/testCNFCollections.pl b/tests/testCNFCollections.pl new file mode 100644 index 0000000..c310b11 --- /dev/null +++ b/tests/testCNFCollections.pl @@ -0,0 +1,67 @@ +#!/usr/bin/env perl +use warnings; use strict; +use Syntax::Keyword::Try; +use lib::relative ('.','../system/modules'); + +require CNFParser; +require TestManager; +my $test = TestManager -> new($0); +my $cnf; +try{ + + ### + # Test instance creation. + ### + die $test->failed() if not $cnf = CNFParser->blank()->parseString(q( +<<@<@array1> _MATCH_DELIMITED_ +1 2 3 4 +>> +<<@<@array2> +"1 2 3 4" +>> +// Following qualifies as an named list. +<<@A$$<@> ___MATCH_DELIMITED_ +1,2,3 +4,5 6 +>> +<<%A$$<%> +hello = "world" +ask: How are you today? +>> +)); + $test->case("Passed new instance CNFParser.",'1'); + $test->subcase('CNFParser->VERSION is '.CNFParser->VERSION); + # + $test-> nextCase(); + # + $test->case("Test array.",'2'); + my @array1 = $cnf -> property('@array1'); + $test->evaluate('Array has 4 elements?',scalar(@array1),4); + my @array2 = $cnf -> property('@array2'); + $test->evaluate('Array has 1 element?',scalar(@array2),1); + $test->evaluate('Array[0] has value 1 2 3 4?',$array2[0],"1 2 3 4"); + my @A0 = $cnf -> property('@A0'); + $test->evaluate('Array has 6 elements?',scalar(@A0),6); + # + $test-> nextCase(); + # + $test->case("Test as a hash property.",'3'); + my %A1 = $cnf -> property('@A1'); + $test->evaluate('Hash has two keys?',scalar(keys %A1),2); + $test->evaluate('hello eq "world"?',$A1{hello},'world'); + $test->evaluate('ask eq "How are you today?"?',$A1{ask},'How are you today?'); + + + # + $test->done(); + # +} +catch{ + $test -> dumpTermination($@); + $test -> doneFailed(); +} + +# +# TESTING THE FOLLOWING IS FROM HERE # +# + diff --git a/tests/testCollections.pl b/tests/testCollections.pl index 51e50c5..5b9c019 100644 --- a/tests/testCollections.pl +++ b/tests/testCollections.pl @@ -1,9 +1,7 @@ #!/usr/bin/env perl use warnings; use strict; use Syntax::Keyword::Try; -use lib "system/modules"; - - +use lib::relative ('.','../system/modules'); require TestManager; require CNFParser; @@ -55,13 +53,13 @@ try{ # Test array instance creation. # $test->case("Test hsh property."); $test->case('Test @array property.'); - $cnf ->parse(undef,q(<<@<@array> + $cnf ->parse(undef,q(<<@<@array> __MATCH_DELIMITED__ 1,2 3,4 >> )); my @array = $cnf ->property('@array'); - #Important -> In perl array type is auto exanded into arguments. + #Important -> In perl array type is auto expanded into arguments. # Hence into scalar result we want to pass. $test->evaluate('@array contains 4 elements?', scalar(@array), 4); $test->evaluate('@array[0]==1', $array[0],1); diff --git a/tests/testNewTagParsingForVersion2.8.pl b/tests/testNewTagParsingForVersion2.8.pl index 89de324..496bcdd 100644 --- a/tests/testNewTagParsingForVersion2.8.pl +++ b/tests/testNewTagParsingForVersion2.8.pl @@ -1,7 +1,6 @@ #!/usr/bin/env perl use warnings; use strict; -use lib "system/modules"; -#use lib "system/modules"; +use lib::relative ('.','../system/modules'); require TestManager; require CNFParser; @@ -49,7 +48,7 @@ use Syntax::Keyword::Try; try { $test->isDefined("A",$cnf->anon('A')); $test->evaluate("A==C",$cnf->anon('A'),'C'); # - $script = ' <<@<@Array<1,2,3,4,5>>>'; + $script = ' <<@<@Array<_MATCH_DELIMITED__1,2,3,4,5>>>'; $test->subcase($script); $cnf->parse(undef,$script); my @a = $cnf->property('@Array');