From: Will Budic Date: Wed, 5 Feb 2025 22:50:46 +0000 (+1100) Subject: CNFNode changes readopted. X-Git-Url: https://lifelog.hopto.org/gitweb/?a=commitdiff_plain;h=20b0d6f5d996be7f5c072b5d889360fcb5c90b12;p=PerlCNF.git CNFNode changes readopted. --- diff --git a/system/modules/DatabaseCentralPlugin.pm b/system/modules/DatabaseCentralPlugin.pm index c117d77..6e9b32b 100644 --- a/system/modules/DatabaseCentralPlugin.pm +++ b/system/modules/DatabaseCentralPlugin.pm @@ -136,7 +136,7 @@ sub main ($self, $parser, $property) { my $ref = ref($schema_node); if($ref eq 'CNFNode'){ - my @NodesTable = @{$schema_node -> find('/table/*')}; + my @NodesTable = @{$schema_node -> search('/table/*')}; warn "Not found any 'table/*' path elements for CNF property :". $schema_node->toPath() if not @NodesTable; ### my $cnf_data = $parser->data(); @@ -623,7 +623,7 @@ sub createSQLStatements($self, $parser, $schema,$table_name, $table_data, $node) return 1 } }else{ # Automation create sql from the schema node tree mapping not actual data header scripted. Not recomended approcah but here we go! - my @columns = @{$node->find('cols/@@')}; + my @columns = @{$node->search('cols/@@')}; die "[$cnf_property] -> $table_name Not found any 'cols/@@' path elements for CNF node script ->".$node->toScript if not @columns; my($tins,$vins,$upds,$sels,$IDName); if(!@header){ diff --git a/system/modules/HTMLIndexProcessorPlugin.pm b/system/modules/HTMLIndexProcessorPlugin.pm index 9b3ea76..95969f7 100644 --- a/system/modules/HTMLIndexProcessorPlugin.pm +++ b/system/modules/HTMLIndexProcessorPlugin.pm @@ -63,22 +63,22 @@ try{ my (@hhshCSS,@hhshJS); if($link){ if(ref($link) eq 'CNFNode'){ - my $arr = $link->find('CSS/@@'); + my $arr = $link->search('CSS/@@'); foreach (@$arr){ push @hhshCSS, {-type => 'text/css', -src => $_->val()}; } - $arr = $link->find('JS/@@'); + $arr = $link->search('JS/@@'); foreach (@$arr){ push @hhshJS, {-type => 'text/javascript', -src => $_->val()}; } - $arr = $link -> find('STYLE'); + $arr = $link -> search('STYLE'); if(ref($arr) eq 'ARRAY'){ foreach (@$arr){ $give_me .= "\n\n" }}else{ $give_me .= "\n\n" } - $arr = $link -> find('SCRIPT'); + $arr = $link -> search('SCRIPT'); if(ref($arr) eq 'ARRAY'){ foreach (@$arr){ $give_me .= "\n\n" diff --git a/system/modules/HTMLProcessorPlugin.pm b/system/modules/HTMLProcessorPlugin.pm index 96168f7..062d80c 100644 --- a/system/modules/HTMLProcessorPlugin.pm +++ b/system/modules/HTMLProcessorPlugin.pm @@ -39,22 +39,22 @@ try{ $body_attrs .= " ". $tree -> {'Body'} if exists $tree -> {'Body'}; if($link){ if(ref($link) eq 'CNFNode'){ - my $arr = $link->find('CSS/@@'); + my $arr = $link->search('CSS/@@'); foreach (@$arr){ my $v = $_->val(); $bfHDR .= qq(\t\n); } - $arr = $link->find('JS/@@'); + $arr = $link->search('JS/@@'); foreach (@$arr){ my $v = $_->val(); $bfHDR .= qq(\t\n); } # Glob find '/*' now has guaranteed array cast derefence return. Even if nothing found. Some folks will cringe on that. Ahahaha! - $arr = $link -> find('STYLE/*'); + $arr = $link -> search('STYLE/*'); foreach (@$arr){ $style = "\n" } - $arr = $link -> find('JAVASCRIPT/*'); + $arr = $link -> search('JAVASCRIPT/*'); foreach (@$arr){ $jscript = "\n" } diff --git a/system/modules/TestManagerOld.pm b/system/modules/TestManagerOld.pm deleted file mode 100644 index 8c4393a..0000000 --- a/system/modules/TestManagerOld.pm +++ /dev/null @@ -1,49 +0,0 @@ -#!/usr/bin/perl -w -# -# Test Manager to make test case source code more readable and organised. -# This is initial version, not supporting fall through and multiple test files and cases. -# -# Programed by: Will Budić -# Open Source License -> https://choosealicense.com/licenses/isc/ -# -package TestManager; - -use strict; -use warnings; - -use Test::More; -use Test::Vars; - -our $case; -our $case_cnt = 0; - -sub construct { my ($class, $self_args) = @_; - die 'Arguments not passed -> {name=?:Name of this Manger., count=?:Current test count.}' if not $self_args; - bless $self_args, $class; - return $self_args; -} - -sub checkPackage {my ($self, $package)=@_; - print "Checking package $package"; - vars_ok $package; -} -sub startCase {my ($self, $case)=@_; - $self->{case}=$case; - print "TestCase ".++$case_cnt.": Started -> $case\n" -} -sub info { my ($self, $info)=@_; - print "TestCase ".$case_cnt.":info: $info\n" -} -sub endCase {my ($self, $package)=@_; - print "TestCase $case_cnt: Ended -> $self->{case} PASSED!\n" -} -sub eval { my ($self, $a, $b, $c)=@_; - if ($c) {my $swp = $a; $a = $b; $b= $c; $c = $swp}else{$c=""}; - die "$0 Test on ->". $self->{case} .", Failed!\n\neval(\n\$a->$a\n\$b->$b\n)\n" unless $a eq $b; - print "\tTest " .++$self->{count}.": Passed -> $c [$a] equals [$b]\n" -} -sub finish {my $self = shift; - print "\nALL TESTS HAVE PASSED for ". $self->{name}. " Totals -> test cases: ".$case_cnt. " test count: ".$self->{count}."\n"; - done_testing; -} -1; \ No newline at end of file diff --git a/test.cnf b/test.cnf index 25f7faf..1da88ec 100644 --- a/test.cnf +++ b/test.cnf @@ -1,17 +1,20 @@ -< - __HAS_PROCESSING_PRIORITY__ +content> >> @@ -21,5 +24,19 @@ test list type anon with instructions. >content> >> -<>> -<value>> \ No newline at end of file +<>> +<value>>> + +<<*> + __/ +__/ >>> \ No newline at end of file