Generated: Tue Feb 2 17:55:01 2010 from xmlgparse.pl 2010/01/25 28.2 KB.
#!/perl -w # NAME: xmlgparse.pl # AIM: My attempt at my OWN XML parser use strict; use warnings; my $add_header = 1; my $keep_path_order = 1; # special hash strings my $xml_header = "=XML HEADER="; #my $xml_comments = "=XML COMMENT="; my $xml_pathorder = "=XML PATHS="; # special hash in hash strings my $x_name = 'Name'; my $x_cont = 'Content'; my $x_attr = 'Attributes'; my $x_line = 'Line'; my $x_type = 'Type'; # 1 = <a>...</a>, 2 = <a .../> # debug my $xdbg_01 = 0; # prt("[xdbg_01] Found [$sf]\n") if ($xdbg_01); my $xdbg_02 = 0; # prt("[$xdbg_02] COMMENT:[$tag]\n") if ($xdbg_02); my $xdbg_03 = 0; # prt("[xdbg_03] HEAD:[$tag]\n") if ($xdbg_03); my $xdbg_04 = 0; # prt("[xdbg_04] CLOSE1:[$tag]\n") if ($xdbg_04); my $xdbg_05 = 0; # prt("[xdbg_05] $lnn:$cols: Stacked 1 [$currtag]\n") if ($xdbg_05); see also $xdbg_11 my $xdbg_06 = 0; # prt("[xdbg_06] $lnn:$cols: Stacked 2 [$currtag]\n") if ($xdbg_06); see also $xdbg_16 my $xdbg_07 = 0; # prt("[xdbg_07] $lnn:$cols: UNStacked 1 [$tmptag], currtag [$currtag]\n") if ($xdbg_07); my $xdbg_08 = 0; # prt("[xdbg_08] $lnn:$cols: UNStacked 2 [$tmptag], currtag [$currtag]\n") if ($xdbg_08); also see $xdbg_14 my $xdbg_09 = 0; # prt("[xdbg_09] Done $lnn lines, from [$fil]. $len chars...\n") if ($xdbg_09); my $xdbg_10 = 0; # prt("[xdbg_10] $lnn: END CDATA:<$tag>\n") if ($xdbg_10); # new set of OPEN and CLOSE debug strings my $xdbg_11 = 0; # prt("[xdbg_11] $lnn: $stktxt - [$currtag] open 1 - no attrs - text [$ttxt]\n") if ($xdbg_11); seel also $xdbg_05 my $xdbg_12 = 0; # prt("[xdbg_12]HASH:$lnn: $msg\n") if ($xdbg_12); my $xdbg_13 = 0; # prt("[xdbg_13]$lnn: $stktxt - [$tmptag] content [$ttxt] tag [$tag] closed BLANK\n") if ($xdbg_13); my $xdbg_14 = 0; # prt("[xdbg_14]$lnn: $stktxt - [$tmptag] content [$ttxt] tag [$tag] closed SAVED2 $savedcnt ($tcntc)\n") if ($xdbg_14); also see $xdbg_08 my $xdbg_15 = 0; # prt("[xdbg_15]$lnn: $stktxt - [$currtag] atts [$tmpcont] CHECKME [ "); +++ my $xdbg_16 = 0; # prt("[xdbg_16]$lnn: $stktxt - [$currtag] open 2\n") if ($xdbg_16); also see $xdbg_06 my $xdbg_17 = 0; # prt("[xdbg_17]$lnn: $stktxt - close 2 of [$tmptag] content [$tmpcont] SAVED $savedcnt ($tcntc)\n") if ($xdbg_17); ########################################################## # ### MY XML PARSER ### sub is_cdata($) { my ($txt) = @_; if ($txt =~ /^\[CDATA\[/) { return 1; } return 0; } sub ret_stack_text($) { my ($ra) = @_; my $rtxt = ''; foreach my $tx (@{$ra}) { $rtxt .= '/' if (length($rtxt)); $rtxt .= $tx; } return $rtxt; } sub get_ref_tag($$) { my ($rh,$ra) = @_; my $rtxt = ''; my $rrh = $rh; foreach my $tx (@{$ra}) { $rrh = ${$rrh}{$tx}; } return $rrh; } sub get_att_ref($) { my ($txt) = @_; $txt = substr($txt,1) while ($txt =~ /^\s/); # clear any leading spaces my $len = length($txt); my ($i,$cc,$key,$val); $i = 0; my %h = (); while ($i < $len) { $key = ''; for (; $i < $len; $i++) { $cc = substr($txt,$i,1); if ($cc eq '=') { $i++; $cc = substr($txt,$i,1); last; } $key .= $cc; } return \%h if ($cc ne '"'); $i++; $val = ''; for (; $i < $len; $i++) { $cc = substr($txt,$i,1); last if ($cc eq '"'); $val .= $cc; } $h{$key} = $val; $i++; # bump over 2nd inverted commas # and eat any spaces for (; $i < $len; $i++) { $cc = substr($txt,$i,1); last if ( !($cc =~ /\s/) ); } } return \%h; } sub get_save_ref($$$$$) { my ($tag,$attr,$cont,$lnn,$typ) = @_; my %h = (); $h{$x_name} = $tag; $h{$x_attr} = $attr; $h{$x_cont} = $cont; $h{$x_line} = $lnn; $h{$x_type} = $typ; my ($msg,$k,$v,$ats); $ats = ''; foreach $k (keys %{$attr}) { $v = ${$attr}{$k}; $ats .= ' ' if (length($ats)); $ats .= "$k=\"$v\""; } $ats = "none" if (length($ats) == 0); $msg = "$x_name=[$tag], $x_cont=[$cont], "; $msg .= "$x_attr=[$ats]"; prt("[xdbg_12]HASH:$lnn: $msg\n") if ($xdbg_12); return \%h; } sub parse_xml_text($$) { my ($fil,$text) = @_; #$in_file = $fil; my ($msg); my %xml_hash = (); my ($tag,$len,$i,$cc,$nc,$pc,$pc1,$pc2,$iscom,$tcnt,$ishead,$lnn,$isclose1,$isclose2,$ttxt,$spcnt); my ($i2,$cols,$currtag,$tmptag,$stkcnt,$iscdata,$stktxt); my ($rc,$tmpcont,$attref); my ($key,$val,$ra); my (@tagstack,$savedcnt,$saveref,@pathorder,@comstack,$tcntc); my ($intag); $len = length($text); prt("Processing $len chars, from $fil...\n"); $cc = ''; $pc1 = ''; $pc2 = ''; $iscom = 0; $ishead = 0; $lnn = 1; $isclose1 = 0; $isclose2 = 0; $ttxt = ''; $currtag = ''; $cols = 0; $iscdata = 0; @tagstack = (); @pathorder = (); @comstack = (); $tag = ''; # start with CLEAN tag $savedcnt = 0; $intag = 0; for ($i = 0; $i < $len; $i++) { $i2 = $i + 1; $cols++; $pc2 = $pc1; $pc1 = $pc; $pc = $cc; $rc = substr($text,$i,1); $nc = ($i2 < $len) ? substr($text,$i2,1) : ''; $cc = $rc; if ($cc =~ /\s/) { if ($cc eq "\n") { $lnn++; $cols = 0; } $cc = ' '; } if ($cc eq '<') { prtw("WARNING: LOST TAG DATA 3 [$tag]\n") if (length($tag)); $tag = ''; # clear the tag $i++; $tcnt = 0; $iscom = 0; $ishead = 0; $isclose1 = 0; $isclose2 = 0; $iscdata = 0; $spcnt = 0; $intag = 1; # got TAG start # proceed to END OF TAG for (; $i < $len; $i++) { $cols++; $i2 = $i + 1; $pc2 = $pc1; $pc1 = $pc; $pc = $cc; $rc = substr($text,$i,1); $nc = ($i2 < $len) ? substr($text,$i2,1) : ''; $cc = $rc; if ($cc =~ /\s/) { if ($cc eq "\n") { $lnn++; $cols = 0; } $cc = ' '; } # <?xml $ishead = 1 if (($tcnt == 2) && ($nc eq 'l') && ($cc eq 'm') && ($pc eq 'x') && ($pc1 eq '?')); # <![CDATA[ ... ]]> $iscdata = 1 if (($tcnt == 1) && ($nc eq 'C') && ($cc eq '[') && ($pc eq '!') && ($pc1 eq '<') && is_cdata(substr($text,$i))); if ($iscdata) { #prt("$lnn:$cols: Got CDATA\n"); #prt(substr($text,$i,40)."\n"); #pgm_exit(1,"Temp exit"); # stay and EAT comment completely $i++; prtw("WARNING: LOST TAG DATA 1 [$tag]\n") if (length($tag) && ($tag ne '!')); $tag = $pc.$cc; # proceed to END OF CDATA TAG $intag = 0; for (; $i < $len; $i++) { $cols++; $i2 = $i + 1; $pc2 = $pc1; $pc1 = $pc; $pc = $cc; $rc = substr($text,$i,1); $nc = ($i2 < $len) ? substr($text,$i2,1) : ''; $cc = $rc; if ($cc =~ /\s/) { if ($cc eq "\n") { $lnn++; $cols = 0; } # $cc = ' '; DO NOT CHANGE TO SPACE ON CDATA } # is it '-->', end of comment if (($cc eq '>') && ($pc eq ']') && ($pc1 eq ']')) { last; # reached END OF CDATA } $tag .= $cc; } last; # exit TAG inner loop } # <!-- $iscom = 1 if (($tcnt == 1) && ($nc eq '-') && ($cc eq '-') && ($pc eq '!') && ($pc1 eq '<')); if ($iscom) { # stay and EAT comment completely $i++; prtw("WARNING: LOST TAG DATA 2 [$tag]\n") if (length($tag) && ($tag ne '!')); $tag = $pc.$cc; # proceed to END OF TAG for (; $i < $len; $i++) { $cols++; $i2 = $i + 1; $pc2 = $pc1; $pc1 = $pc; $pc = $cc; $rc = substr($text,$i,1); $nc = ($i2 < $len) ? substr($text,$i2,1) : ''; $cc = $rc; if ($cc =~ /\s/) { if ($cc eq "\n") { $lnn++; $cols = 0; } $cc = ' '; } # is it '-->', end of comment if (($cc eq '>') && ($pc eq '-') && ($pc1 eq '-')) { last; # reached END OF COMMENT } $tag .= $rc; } push(@comstack,$tag); $intag = 0; last; # exit TAG inner loop } elsif (!$iscdata) { # </... $isclose1 = 1 if (($tcnt == 0) && ($cc eq '/')); # <... /> if (($cc eq '/') && ($nc eq '>')) { $isclose2 = 1; # this is a <... /> self closed tag if ($spcnt && @tagstack && ($tagstack[-1] eq $currtag)) { $stktxt = ret_stack_text(\@tagstack); $tmptag = pop @tagstack; if (@tagstack) { $currtag = $tagstack[-1]; } else { $currtag = "*EMPTY*"; } $tmpcont = $tag; $tmpcont =~ s/$tmptag\s+//; $savedcnt++; $attref = get_att_ref($tmpcont); $tmpcont = ''; $tcntc = scalar @comstack; if ($xdbg_17) { prt("[xdbg_17]$lnn: $stktxt - close 2 of [$tmptag] attributes ["); foreach $key (keys %{$attref}) { $val = ${$attref}{$key}; prt("$key=\"$val\" "); } prt("] SAVED $savedcnt ($tcntc)\n"); } $saveref = get_save_ref($tmptag,$attref,$tmpcont,$lnn,2); if (!defined $xml_hash{$stktxt}) { $xml_hash{$stktxt} = [ ]; push(@pathorder,$stktxt); # keep (new) PATH order from FILE } $ra = $xml_hash{$stktxt}; my @cs1 = @comstack; push(@{$ra}, [$saveref, \@cs1]); $xml_hash{$stktxt} = $ra; @comstack = (); prt("[xdbg_07] $lnn:$cols: UNStacked 1 [$tmptag], currtag [$currtag]\n") if ($xdbg_07); $tag = ''; # CLEAR TAG of tag and attributes } else { pgm_exit(1,"ERROR: $lnn:$cols: curtag [".$currtag."] WHY CLOSE NO STACK?\n"); } $i += 2; # IMPORTANT - move past these chars $intag = 0; last; } elsif ($cc eq '>') { # CLOSE OF TAG if (($spcnt == 0) && !$ishead && !$iscom) { # had no SPACES so far, and NOT head or comment # --------------------------------------------- if ($isclose1) { # had <... /> = CLOSE1 if (@tagstack && ($tagstack[-1] eq $currtag)) { $stktxt = ret_stack_text(\@tagstack); $tmptag = pop @tagstack; if (@tagstack) { $currtag = $tagstack[-1]; } else { $currtag = "*EMPTY*"; } #if ($exclude_blanks && ((length($ttxt) == 0) || ($ttxt =~ /^\s+$/))) { if ((length($ttxt) == 0) || ($ttxt =~ /^\s+$/)) { prt("[xdbg_13]$lnn: $stktxt - [$tmptag] content [$ttxt] tag [$tag] closed BLANK\n") if ($xdbg_13); } else { $savedcnt++; $tcntc = scalar @comstack; prt("[xdbg_14]$lnn: $stktxt - [$tmptag] content [$ttxt] tag [$tag] closed SAVED2 $savedcnt ($tcntc)\n") if ($xdbg_14); $saveref = get_save_ref($tmptag,$attref,$ttxt,$lnn,1); if (!defined $xml_hash{$stktxt}) { $xml_hash{$stktxt} = [ ]; push(@pathorder,$stktxt); # KEEP (new) PATH ORDER FROM FILE } $ra = $xml_hash{$stktxt}; my @cs2 = @comstack; push(@{$ra}, [$saveref, \@cs2]); # add comment stack $xml_hash{$stktxt} = $ra; @comstack = (); } prt("[xdbg_08] $lnn:$cols: UNStacked 2 [$tmptag], currtag [$currtag]\n") if ($xdbg_08); $tag = ''; # CLEAR CLOSED TAG $ttxt = ''; # CLEAR CLOSED TEXT } elsif (@tagstack) { prt("ERROR: $lnn:$cols: curtag [".$currtag."] NE tagstack [".$tagstack[-1]."]!\n"); pgm_exit(1,"Bad TAG 1! file=$fil"); } else { prt("ERROR: $lnn:$cols: curtag [".$currtag."] NOT IN tagstack!\n"); pgm_exit(1,"Bad TAG 2! file=$fil"); } $intag = 0; } elsif (length($tag)) { # CLOSE2 <...> push(@tagstack,$tag); $currtag = $tag; $stktxt = ret_stack_text(\@tagstack); prt("[xdbg_11] $lnn: $stktxt - [$currtag] open 1 - no attrs - text [$ttxt]\n") if ($xdbg_11); $attref = get_att_ref(""); # returns an EMPTY HASH prt("[xdbg_05] $lnn:$cols: Stacked 1 [$currtag]\n") if ($xdbg_05); $tag = ''; # clear STACKED tag } else { pgm_exit(1,"ERROR: $lnn:$cols: NOT Close type 1, AND NO TAG LENGTH!\n"); } } else { if ($ishead) { # what to do with the HEAD data - see below #prt("End HEAD [$tag]\n"); #} elsif ($iscom) { # comment now done above # # what to do with COMMENT data - see below # prt("End COMMENT [$tag]\n"); $intag = 0; } else { # had SPACES, and NOT head or comment - then is a tag with attributes $stktxt = ret_stack_text(\@tagstack); $tmpcont = $tag; $tmpcont =~ s/$currtag\s+//; $attref = get_att_ref($tmpcont); if ($xdbg_15) { prt("[xdbg_15]$lnn: $stktxt - [$currtag] atts [$tmpcont] CHECKME [ "); foreach $key (keys %{$attref}) { $val = ${$attref}{$key}; prt("$key = \"$val\" "); } prt("]\n"); } } $tag = '' if (!$ishead); # CLEAR TAG! } last; # exit this INNER TAG loop } elsif ($cc =~ /\s/) { if (($spcnt == 0) && !$ishead && !$isclose1 && !$iscom) { push(@tagstack,$tag); $currtag = $tag; $stktxt = ret_stack_text(\@tagstack); prt("[xdbg_16]$lnn: $stktxt - [$currtag] open 2\n") if ($xdbg_16); prt("[xdbg_06] $lnn:$cols: Stacked 2 [$currtag]\n") if ($xdbg_06); } if ( !($pc =~ /\s/) ) { $tag .= $cc; } $spcnt++; # bump the SPACE counter } else { # NOT '/', '>', '\s'... $tag .= $cc; } } $tcnt++; #last if ($iscom); } # for (; $i < $len; $i++) { # proceed to END OF TAG if ($ishead) { prt("[xdbg_03] $lnn: HEAD:<$tag>\n") if ($xdbg_03); if ($add_header) { if (defined $xml_hash{$xml_header}) { pgm_exit(1,"ERROR: Duplicate HEADER data! [$tag], previous [".$xml_hash{'XML HEADER'}."]\n"); } $xml_hash{$xml_header} = $tag; } $tag = ''; # CLEAR TAG of HEADER DATA - stored in 'XML HEADER' } elsif ($iscom) { prt("[xdbg_02] $lnn: COMMENT:<$tag>\n") if ($xdbg_02); # if ($add_comments) { # if (defined $xml_hash{$xml_comments}) { # $ra = $xml_hash{$xml_comments}; # push(@{$ra}, $tag); # $xml_hash{$xml_comments} = $ra; # } else { # $xml_hash{$xml_comments} = [ $tag ]; # } # } $tag = ''; # CLEAR TAG of COMMENT DATA } elsif ($isclose1) { prt("[xdbg_04] $lnn: CLOSE1:<$tag>\n") if ($xdbg_04); } elsif ($isclose2) { prt("[xdbg_04] $lnn: CLOSE2:<$tag>\n") if ($xdbg_04); } elsif ($iscdata) { prt("[xdbg_10] $lnn: END CDATA currtag [$currtag] [$tag]\n") if ($xdbg_10); $ttxt = $tag; # store the CDATA in tag text ($ttxt) prtw("WARNING:$lnn: tag [$tag] starts with '<'\n") if ($tag =~ /^</); $tag = ''; # CLEAR TAG of CDATA } # done this tag $ttxt = '' if (!$iscdata); next; # back to line processing OUTER LOOP } # got open tag char '<' ############################### # no 'open' yet if ((length($ttxt) == 0)&&($cc eq '<')) { prtw("WARNING:$lnn: Adding $cc to content text!\n"); } #$ttxt .= $cc; $ttxt .= $cc if ($intag); } # outer loop - process text length ##################################### $xml_hash{$xml_pathorder} = \@pathorder; $stkcnt = scalar @tagstack; prt("[xdbg_09] Done $lnn lines, from [$fil]. $len chars...\n") if ($xdbg_09); if ($stkcnt) { $msg = "WARNING: Still $stkcnt item on tag stack! "; for ($i = 0; $i < $stkcnt; $i++) { $msg .= "[".$tagstack[$i]."] "; } prtw("$msg\n"); } return \%xml_hash; } sub parse_xml_file($) { my ($fil) = @_; if (!open INF, "<$fil") { pgm_exit(1,"ERROR: Unable to open file [$fil]!"); } my @lines = <INF>; close INF; my $text = join("",@lines); my $len = length($text); my $lnn = scalar @lines; prt("Processing $lnn lines, from [$fil]. $len chars...\n"); return parse_xml_text($fil,$text); } sub fix_xml_path($$$$$$$$) { my ($rarr,$ra,$rs,$rm,$out,$nm,$lnn,$rca1) = @_; my ($pcnt,$scnt,$pele,$cnt,$nxt,$ele,$ind,$clos,$tcnt); my ($ccnt,$ctxt); $pcnt = scalar @{$rarr}; $scnt = scalar @{$rs}; $ccnt = scalar @{$rca1}; # comment array # assume stacked <1><2><3> and # new path <1><2><4> # must close <3> and open <4> $pele = ''; $cnt = 0; prt( "[dbg4]:$lnn: path elements [$pcnt], stack elements [$scnt]\n") if ($out & 4); foreach $ele (@{$rarr}) { last if ($cnt >= $scnt); $nxt = ${$rs}[$cnt]; prt( "[dbg2]$cnt: element [$ele], and next 1 [$nxt] prev [$pele]\n") if ($out & 2); if (length($pele) && ($ele ne $nxt)) { while (($scnt > 0) && ($pele ne $nxt)) { $clos = pop @{$rs}; $scnt--; $ind = ' ' x $scnt; prt("$ind</$clos>\n") if ($out); ${$rm} .= "$ind</$clos>\n"; $nxt = '<none>'; if ($scnt) { $tcnt = $scnt - 1; $nxt = ${$rs}[$tcnt]; } prt( "[dbg2]$cnt: dropped [$clos], and next 2 [$nxt] prev [$pele] ($scnt)\n") if ($out & 2); } } $cnt++; $pele = $ele; } $cnt = 0; $scnt = scalar @{$rs}; foreach $ele (@{$rarr}) { # is this element in the stack already? last if ($ele eq $nm); # reached this element if ($cnt < $scnt) { if ($ele eq ${$rs}[$cnt]) { # already done prt( "[dbg2]$cnt: element [$ele] in stack ($scnt)\n") if ($out & 2); } else { prtw("WARNING: Missing element [$ele]!\n"); } } else { $ind = ' ' x $cnt; if ($ccnt) { foreach $ctxt (@{$rca1}) { ${$rm} .= "$ind<$ctxt>\n"; prt("$ind<$ctxt>\n") if ($out); } $ccnt = 0; } ${$rm} .= "$ind<$ele>\n"; prt("$ind<$ele> added\n") if ($out); push(@{$rs},$ele); } $cnt++; } return $cnt; } sub show_rh_kv($$$$$) { my ($path,$ra,$rs,$rm,$out) = @_; my ($k,$v,$rh,$k2); my ($nm,$txt,$attrs,$n2,$v2,$lnn,$typ); my ($cnt,$ele,$rarr,$scnt,$ind,@arr); my ($rh0,$rca1); #$rarr = close_xml_paths($path,$ra,$rs,$rm,$out); $scnt = scalar @{$rs}; @arr = split("/",$path); $rarr = \@arr; foreach $rh (@{$ra}) { $nm = ''; $txt = ''; $attrs = ''; $lnn = ''; $typ = 0; #prt(Dumper($rh)); $rh0 = ${$rh}[0]; $rca1 = ${$rh}[1]; # extact any COMMENT ARRAY (ref) foreach $k (keys %{$rh0}) { $v = ${$rh0}{$k}; if ($k eq $x_attr) { # this is a hash foreach $k2 (keys %{$v}) { $v2 = ${$v}{$k2}; $attrs .= ' ' if (length($attrs)); $attrs .= "$k2=\"$v2\""; } } elsif ($k eq $x_cont) { $txt = $v; } elsif ($k eq $x_name) { $nm = $v; } elsif ($k eq $x_line) { $lnn = $v; } elsif ($k eq $x_type) { $typ = $v; } else { pgm_exit(1,"ERROR: Unknown value in HASH [$k]???\n"); } } $cnt = fix_xml_path($rarr,$ra,$rs,$rm,$out,$nm,$lnn,$rca1); $n2 = (length($attrs)) ? "$nm $attrs" : "$nm"; $ind = ' ' x $cnt; if ($typ == 2) { prt("$ind<$n2 />\n") if ($out); ${$rm} .= "$ind<$n2 />\n"; } else { prt("$ind<$n2>$txt</$nm>\n") if ($out); ${$rm} .= "$ind<$n2>$txt</$nm>\n"; } } } sub show_ref_hash($$$) { my ($rh,$fil,$out) = @_; my ($key,$val,$cnt,$itm,$msg,$scnt,$msg2); my $def_head = "?xml version=\"1.0\"?"; my @stack = (); my $dopo = ($keep_path_order && (defined ${$rh}{$xml_pathorder})) ? 1 : 0; $msg2 = "Show of ref hash... from $fil "; if ($dopo) { $msg2 .= "in path order "; } else { $msg2 .= "in sort order "; } prt("$msg2\n"); $cnt = 0; $key = $xml_header; if (defined ${$rh}{$key}) { $val = ${$rh}{$key}; } else { $val = $def_head; } $msg = "<$val>\n"; prt($msg) if ($out); $msg .= "<!-- $msg2 -->\n"; # if ($show_comments) { # $key = $xml_comments; # if (defined ${$rh}{$key}) { # $val = ${$rh}{$key}; # foreach $itm (@{$val}) { # prt("<$itm>\n") if ($out); # $msg .= "<$itm>\n"; # } # } # } if ($dopo) { my $rpo = ${$rh}{$xml_pathorder}; foreach $key (@{$rpo}) { $val = ${$rh}{$key}; $cnt++; if ($key eq $xml_header) { #prt("$cnt: $key HEADER = $val\n"); #} elsif ($key eq $xml_comments) { #prt("$cnt: $key COMMENTS\n"); } elsif ($key eq $xml_pathorder) { #prt("$cnt: $key PATH ORDER\n"); } else { prt("$cnt:PATH: $key\n") if ($out); show_rh_kv($key,$val,\@stack,\$msg,$out); #prt(Dumper($key)); #prt(Dumper($val)); #prt("$cnt: End other\n"); } } } else { foreach $key (sort keys %{$rh}) { $val = ${$rh}{$key}; $cnt++; if ($key eq $xml_header) { #prt("$cnt: $key HEADER = $val\n"); #} elsif ($key eq $xml_comments) { #prt("$cnt: $key COMMENTS\n"); } elsif ($key eq $xml_pathorder) { #prt("$cnt: $key PATH ORDER\n"); } else { prt("$cnt:PATH: $key\n") if ($out); show_rh_kv($key,$val,\@stack,\$msg,$out); #prt(Dumper($key)); #prt(Dumper($val)); #prt("$cnt: End other\n"); } } } $scnt = scalar @stack; while ($scnt > 0) { $scnt--; $key = $stack[$scnt]; $val = ' ' x $scnt; $msg .= "$val</$key>\n"; prt("$val</$key>\n") if ($out); } prt("Done $cnt keys in ref hash... from $fil\n"); return $msg; } sub get_all_children($$$$) { my ($rh,$pp,$dep,$out) = @_; my %hash = (); my @po = (); my ($key,$val,$cnt,@arr,$acnt,$ele,$fnd); my $rpo = ${$rh}{$xml_pathorder}; my ($i,$j); $cnt = 0; $fnd = 0; foreach $key (@{$rpo}) { $val = ${$rh}{$key}; $cnt++; if ($key eq $xml_header) { #prt("$cnt: $key HEADER = $val\n"); } elsif ($key eq $xml_pathorder) { #prt("$cnt: $key PATH ORDER\n"); } else { prt("$cnt:PATH: $key\n") if ($out & 2); @arr = split("/",$key); $acnt = scalar @arr; for ($i = 0; $i < $acnt; $i++) { $ele = $arr[$i]; if ($ele eq $pp) { # found our path item - check for depth if (($i + $dep + 1) == $acnt) { prt("$cnt:PATH: $key ADDED\n") if ($out); $hash{$key} = $val; push(@po,$key); $fnd++; } last; } } } } if ($fnd) { $hash{$xml_pathorder} = \@po; } return \%hash; } sub xml_get_content_text($) { my ($ra) = shift; my $rtxt = ''; my ($rh,$rh0); foreach $rh (@{$ra}) { $rh0 = ${$rh}[0]; if (defined ${$rh0}{$x_cont}) { $rtxt = ${$rh0}{$x_cont}; return $rtxt if (length($rtxt)); } } return $rtxt; } sub xml_get_element_text($$) { my ($rh,$txt) = @_; my $rtxt = ''; my ($path,@arr,$ele,$val); foreach $path (keys %{$rh}) { @arr = split('/',$path); foreach $ele (@arr) { if ($ele eq $txt) { $val = ${$rh}{$path}; $rtxt = xml_get_content_text($val); return $rtxt if (length($rtxt)); } } } return $rtxt; } sub xml_get_element_hash_for_array($$) { my ($rhc,$ra) = @_; my %h = (); my ($ele); foreach $ele (@{$ra}) { my $txt = xml_get_element_text($rhc,$ele); $h{$ele} = $txt; } return \%h; } #sub show_fg_sim_references($) { # my ($rh) = @_; # my $rc = get_all_children($rh,"sim",1,0); # my $xout = show_ref_hash($rc,"test",0); # write2file($xout,$out_xml2); # prt("XML written to $out_xml2 file...\n"); # my $txt = get_element_text($rc,'description'); # prt("Description: [$txt]\n"); # $txt = get_element_text($rc,'aero'); # prt("Aero : [$txt]\n"); # $txt = get_element_text($rc,'author'); # prt("Author : [$txt]\n"); # $txt = get_element_text($rc,'status'); # prt("Status : [$txt]\n"); # # flight-model # $txt = get_element_text($rc,'flight-model'); # $txt = "jsb (default)" if (length($txt) == 0); # prt("FDM : [$txt]\n"); #} 1; # eof