xmlgparse.pl to HTML.

index -|- end

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

index -|- top

checked by tidy  Valid HTML 4.01 Transitional