home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / share / system-tools-backends-2.0 / scripts / Utils / XML.pm < prev   
Encoding:
Perl POD Document  |  2006-08-14  |  17.5 KB  |  1,002 lines
  1. #!/usr/bin/env perl
  2. #-*- Mode: perl; tab-width: 2; indent-tabs-mode: nil; c-basic-offset: 2 -*-
  3.  
  4. # XML printing, scanning and parsing.
  5. #
  6. # Copyright (C) 2000-2001 Ximian, Inc.
  7. #
  8. # Authors: Hans Petter Jansson <hpj@ximian.com>
  9. #          Arturo Espinosa <arturo@ximian.com>
  10. #          Kenneth Christiansen <kenneth@gnu.org>
  11. #
  12. # This program is free software; you can redistribute it and/or modify
  13. # it under the terms of the GNU Library General Public License as published
  14. # by the Free Software Foundation; either version 2 of the License, or
  15. # (at your option) any later version.
  16. #
  17. # This program is distributed in the hope that it will be useful,
  18. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  19. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20. # GNU Library General Public License for more details.
  21. #
  22. # You should have received a copy of the GNU Library General Public License
  23. # along with this program; if not, write to the Free Software
  24. # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307, USA.
  25.  
  26. package Utils::XML;
  27.  
  28. use Utils::Util;
  29. use Utils::Backend;
  30. use Text::ParseWords;
  31.  
  32. $has_encode = 0;
  33. if (eval "require Encode") {
  34.   Encode->import ();
  35.   $has_encode = 1;
  36. }
  37.  
  38. # --- XML print formatting  --- #
  39.  
  40.  
  41. # &gst_xml_enter: Call after entering a block. Increases indent level.
  42. # &gst_xml_leave: Call before leaving a block. Decreases indent level.
  43. # &gst_xml_print_indent: Call before printing a line. Indents to current level. 
  44. # &gst_xml_print_vspace: Ensures there is a vertical space of one and only one line.
  45. # &gst_xml_print: Indent, then print all arguments. Just for sugar.
  46.  
  47.  
  48. my $gst_indent_level = 0;
  49. my $gst_have_vspace = 0;
  50.  
  51. my @gst_xml_stack;
  52.  
  53. sub print_comment # (comment text)
  54. {
  55.   my ($comment) = @_;
  56.  
  57.   &print_line ("<!-- $comment -->") if $comment;
  58. }
  59.  
  60.  
  61. sub print_begin
  62. {
  63.   my ($name) = @_;
  64.  
  65.   $name = "response" if !$name;
  66.  
  67.   &print_string ("<?xml version='1.0' encoding='UTF-8' standalone='yes'?>\n");
  68.   &print_string ("<!DOCTYPE $name []>\n\n");
  69.   &print_string ("<$name>\n");
  70.  
  71.   &enter ();
  72.  
  73.   &print_vspace ();
  74. }
  75.  
  76.  
  77. # The frontend expects exactly this string. Don not alter.
  78. sub print_request_end
  79. {
  80.   print "\n<!-- GST: end of request -->\n";
  81. }
  82.  
  83.  
  84. sub print_end
  85. {
  86.   my ($name) = @_;
  87.  
  88.   $name = "response" if !$name;
  89.   
  90.   &leave ();
  91.  
  92.   &print_vspace ();
  93.   &print_string ("</$name>\n");
  94. }
  95.  
  96.  
  97. sub enter
  98. {
  99.   $gst_indent_level += 2;
  100. }
  101.  
  102.  
  103. sub leave
  104. {
  105.   $gst_indent_level -= 2;
  106. }
  107.  
  108.  
  109. sub print_string
  110. {
  111.   if ($has_encode)
  112.   {
  113.     if (&decode_utf8 ($_[0]) eq undef)
  114.     {
  115.       # we first decode the string, if it's not
  116.       # utf-8 (returns undef), then encode it
  117.       print "" . &encode_utf8 ($_[0]);
  118.       return;
  119.     }
  120.   }
  121.  
  122.   # It could not encode the string, write it as is
  123.   print $_[0];
  124. }
  125.  
  126. sub format_indent
  127. {
  128.   $gst_have_vspace = 0;
  129.   return " " x $gst_indent_level;
  130. }
  131.  
  132. sub print_indent
  133. {
  134.   &print_string(&format_indent ());
  135. }
  136.  
  137. sub print_vspace
  138. {
  139.   if (not $gst_have_vspace)
  140.   {
  141.     &print_string ("\n");
  142.     $gst_have_vspace = 1;
  143.   }
  144. }
  145.  
  146.  
  147. sub print_line
  148. {
  149.   my $line;
  150.   $line = join ("", @_);
  151.   $line =~ tr/\n//d;
  152.  
  153.   &print_indent ();
  154.   &print_string ($line . "\n");
  155. }
  156.  
  157. sub format_pcdata # (name, pcdata)
  158. {
  159.   my ($name, $pcdata) = @_;
  160.   return "<$name>$pcdata</$name>" if defined ($name) || defined ($pcdata);
  161. }
  162.  
  163. sub print_pcdata # (name, pcdata)
  164. {
  165.   my ($name, $pcdata) = @_;
  166.   my $line = &format_pcdata ($name, $pcdata);
  167.  
  168.   &print_line ($line) if $line;
  169. }
  170.  
  171. sub format_state_tag
  172. {
  173.   my ($name, $state) = @_;
  174.   my $boolean = &Utils::Util::print_boolean_truefalse ($state);
  175.  
  176.   return "<$name state='$boolean'/>";
  177. }
  178.  
  179. sub print_state_tag
  180. {
  181.   my ($name, $state) = @_;
  182.   my $state_tag = &format_state_tag ($name, $state);
  183.  
  184.   &print_line ($state_tag); 
  185. }
  186.  
  187. # Pass a hash and the keys whose items are scalars. Print <key>val</key>.
  188. sub print_scalars
  189. {
  190.   my ($h, @scalar_keys) = @_;
  191.   my ($i, $val);
  192.  
  193.   @scalar_keys = sort @scalar_keys;
  194.  
  195.   while ($i = shift @scalar_keys)
  196.   {
  197.     $val = "e ($$h{$i});
  198.     &print_line ("<$i>$val</$i>\n") if exists $$h{$i};
  199.   }
  200.   
  201. }
  202.  
  203. # Print the @$array using <$tag>val</$tag> foreach val in the array.
  204. # Actually lets print_structure do that now. Just print sequentially
  205. # the given elements, using as $tag as the surrounding tags.
  206. sub print_array
  207. {
  208.   my ($array, $tag) = @_;
  209.   my ($i, $val);
  210.  
  211.   return if (scalar @$array <= 0);
  212.  
  213.   &print_vspace ();
  214.   foreach $i (@$array)
  215.   {
  216.     &print_structure ($i, $tag);
  217.   }
  218. }
  219.  
  220. # Pass a hash and the keys whose items are arrays. Print <key>val</key> foreach val
  221. # in the array at hash{key}
  222. sub print_arrays
  223. {
  224.   my ($h, @array_keys) = @_;
  225.   my ($i, $j, $val);
  226.   
  227.   foreach $i (sort @array_keys)
  228.   {
  229.     &print_array ($$h{$i}, $i) if (exists $$h{$i})
  230.   }
  231. }
  232.  
  233. # Pass a hash, create a parent tag $tag and print <key>val</key> for every
  234. # value pair in the hash. If structure refs are found, these are recursively
  235. # printed with print_structure.
  236. sub print_hash
  237. {
  238.   my ($hash, $tag) = @_;
  239.   my ($j, $val);
  240.   
  241.   &print_vspace ();
  242.   if (defined $tag) {
  243.       &print_line ("<$tag>\n");
  244.       &enter ();
  245.   }
  246.   
  247.   foreach $j (sort keys (%$hash))
  248.   {
  249.     &print_structure ($$hash{$j}, $j);
  250.   }
  251.  
  252.   if (defined $tag) {
  253.       &leave ();
  254.       &print_line ("</$tag>\n");
  255.   }
  256. }
  257.  
  258. # Call the corresponding function depending on the reference
  259. # type of $x. If just a scalar, print <$tag>$x</$tag>.
  260. sub print_structure
  261. {
  262.   my ($x, $tag) = @_;
  263.  
  264.   if (ref $x eq "ARRAY") { &print_array ($x, $tag); }
  265.   elsif (ref $x eq "HASH")  { &print_hash  ($x, $tag); }
  266.   else
  267.   {
  268.     &print_line ("<$tag>" . "e ($x) . "</$tag>\n");
  269.   }
  270. }
  271.  
  272. # Treats hash as an array: doesn't use the keys as tags for its
  273. # elements, but the given tag.
  274. sub print_hash_hash
  275. {
  276.   my ($h, $tag) = @_;
  277.   my $i;
  278.   
  279.   foreach $i (sort keys %$h)
  280.   {
  281.     &print_hash ($$h{$i}, $tag);
  282.   } 
  283. }
  284.  
  285.  
  286. sub container_enter # (name)
  287. {
  288.   my ($container) = @_;
  289.  
  290.   ## gst_xml_stack is not my, as it is defined at top,
  291.   ## so it is global
  292.   push @gst_xml_stack, $container;
  293.  
  294.   &print_line ("<$container>");
  295.   &enter();
  296. }
  297.  
  298.  
  299. sub container_leave
  300. {
  301.   ## checks if there is a start tag
  302.   if ($#gst_xml_stack >= 0)
  303.   { 
  304.     my $current_container = pop @gst_xml_stack;
  305.  
  306.     &leave ();
  307.     &print_line ("</$current_container>");
  308.   }
  309. }
  310.  
  311.  
  312. sub print_container # (name, @strings)
  313. {
  314.   my ($name, @strings) = @_;
  315.  
  316.   if (@strings) {
  317.     &container_enter ($name);
  318.     foreach $tag (@strings) {
  319.       &print_line ("$tag");
  320.     }
  321.     &container_leave ();
  322.   }
  323. } 
  324.  
  325. # --- XML printing from in-memory model --- #
  326.  
  327. sub model_print_attributes
  328. {
  329.   my ($tree) = @_;
  330.   my ($attrs, $string);
  331.  
  332.   $attrs = @$tree [0];
  333.  
  334.   for $attr (keys %$attrs)
  335.   {
  336.     $string .= " " . $attr . "=\"" . $$attrs{$attr} . "\"";
  337.   }
  338.  
  339.   return $string;
  340. }
  341.  
  342. sub model_print_recurse
  343. {
  344.   my ($tree, $indent) = @_;
  345.   my ($string);
  346.  
  347.   my @children = @$tree;
  348.   shift @children;  # Attributes
  349.  
  350.   while (@children)
  351.   {
  352.     my $branch = $children [1];
  353.  
  354.     if ($children [0] eq "__unparsed__")
  355.     {
  356.       $string .= "<" . $children [1] . ">";
  357.     }
  358.     elsif ($children [0] eq "0")
  359.     {
  360.       $string .= $children [1];
  361.     }
  362.     elsif (@$branch == 1)  # Empty tag.
  363.     {
  364.       $string .= "<" . $children [0] . &model_print_attributes ($branch) . "/>";
  365.     }
  366.     else
  367.     {
  368.       $string .= "<" . $children [0] . &model_print_attributes ($branch) . ">";
  369.       $string .= &model_print_recurse ($branch);
  370.       $string .= "</" . $children [0] . ">";
  371.     }
  372.  
  373.     shift @children;
  374.     shift @children;
  375.   }
  376.  
  377. #  if ($branch)
  378. #  {
  379. #    return &get_attribute ($branch, $property) if $property ne "";
  380. #    return &get_pcdata ($branch);
  381. #  }
  382.  
  383.   return $string;
  384. }
  385.  
  386. sub model_print
  387. {
  388.   my ($tree) = @_;
  389.   my ($string);
  390.  
  391.   $string = &model_print_recurse ($tree);
  392.   chomp $string;
  393.   $string .= "\n";
  394.  
  395.   return $string;
  396. }
  397.  
  398. # --- XML scanning --- #
  399.  
  400.  
  401. # This code tries to replace XML::Parser scanning from stdin in tree mode.
  402.  
  403. sub scan_make_kid_array
  404. {
  405.   my $line = shift;
  406.   my (%hash, @sublist, @attr, @list);
  407.  
  408.   # Remove < and />
  409.   $line =~ s/^[ \t]*<//;
  410.   $line =~ s/[\/]?>[ \t]*$//;
  411.  
  412.   my @list = "ewords ('[ \t]+', 1, $line);
  413.   shift @list; # push tag name.
  414.  
  415.   foreach (@list)
  416.   {
  417.     my @tmp = split '[ \t]*=[ \t]*';
  418.     if (scalar @tmp == 2 && $tmp[1] =~ s/[\"\']//g)
  419.     {
  420.       push @attr, @tmp;
  421.     }
  422.   }
  423.  
  424.   %hash = @attr;
  425.  
  426.   push (@sublist, \%hash);
  427.   return \@sublist;
  428. }
  429.  
  430.  
  431. sub scan_recurse
  432. {
  433.   my ($gst_xml_scan_list, $list_arg) = @_;
  434.   my @list;
  435.   if ($list_arg ne undef) { @list = $$list_arg[0]; }
  436.   
  437.   while (@$gst_xml_scan_list)
  438.   {
  439.     $el = shift @$gst_xml_scan_list;
  440.  
  441.     if (($el eq "") || $el =~ /^\<[!?].*\>$/s) { next; }  # Empty strings, PI and DTD must go.
  442.     if ($el =~ /^\<.*\/\>$/s)  # Empty.
  443.     {
  444.       $el =~ /^\<([a-zA-Z0-9_-]+).*\/\>$/s;
  445.       push (@list, $1);
  446.       push (@list, &scan_make_kid_array ($el));
  447.     }
  448.     elsif ($el =~ /^\<\/.*\>$/s)  # End.
  449.     {
  450.       last;
  451.     }
  452.     elsif ($el =~ /^\<.*\>$/s)  # Start.
  453.     {
  454.       $el =~ /^\<([a-zA-Z0-9_-]+).*\>$/s;
  455.       push (@list, $1);
  456.       $sublist = &scan_make_kid_array ($el);
  457.       push (@list, &scan_recurse ($gst_xml_scan_list, $sublist));
  458.       next;
  459.     }
  460.     elsif ($el ne "")  # PCDATA.
  461.     {
  462.       push (@list, 0);
  463.       push (@list, "$el");
  464.     }
  465.   }
  466.  
  467.   return \@list;
  468. }
  469.  
  470.  
  471. sub read_file
  472. {
  473.   my ($file) = @_;
  474.   my ($doc, $i);
  475.   local *INPUT_FILE;
  476.   
  477.   open INPUT_FILE, $file;
  478.   $doc .= $i while ($i = <INPUT_FILE>);
  479.   close INPUT_FILE;
  480.  
  481.   return $doc;
  482. }
  483.  
  484.  
  485. sub read_compressed_file
  486. {
  487.   my ($file) = @_;
  488.   my ($doc, $i, $fd);
  489.  
  490.   $fd = &Utils::File::run_pipe_read ("gunzip -c $file");
  491.   return undef if $fd eq undef;
  492.   $doc .= $i while ($i = <$fd>);
  493.   &Utils::File::close_file ($fd);
  494.  
  495.   if (length ($doc) < 4)  # Allow for one blank line from gzip, '\n\r'.
  496.   {
  497.     $doc = undef;
  498.   }
  499.  
  500.   return $doc;
  501. }
  502.  
  503.  
  504. sub read_stdin
  505. {
  506.   my ($i, $doc);
  507.   
  508.   do {
  509.     $i = <STDIN>;
  510.  
  511.     if ($i ne undef)
  512.     {
  513.       $doc .=$i;
  514.     }
  515.   } while (! ($i =~ /^<!-- GST: end of request -->$/));
  516.  
  517.   return $doc;
  518. }
  519.  
  520. # (file, tool) If no file specified, reads stdin.
  521. # file could also contain xml document.
  522. # If tool is an gst_tool, stores the read buffer in
  523. # $$tool{"xml_doc"}.
  524. sub scan
  525. {
  526.   my ($file, $tool) = @_;
  527.   my ($doc, @tree, @gst_xml_scan_list);
  528.  
  529.   $file = $gst_input_file unless $file;
  530.  
  531.   if ($file && stat ($file))
  532.   {
  533.     $doc = &read_file ($file);
  534.   }
  535.   elsif ($file)
  536.   {
  537.     $doc = $file;
  538.   }
  539.   else
  540.   {
  541.     $doc = &read_stdin ();
  542.   }
  543.  
  544.   # remove any blank or carriage return at the beginning of the xml
  545.   $doc =~ s/^[ \n]*//;
  546.  
  547.   $$tool{"xml_doc"} = $doc if (&Utils::Backend::is_backend ($tool));
  548.  
  549.   @gst_xml_scan_list = ($doc =~ /([^\<]*)(\<[^\>]*\>)[ \t\n\r]*/mg); # pcdata, tag, pcdata, tag, ...
  550.   $tree = &scan_recurse (\@gst_xml_scan_list);
  551.  
  552.   return $tree;
  553. }
  554.  
  555. # XML scanning that preserves more exact attributes of the scanned XML.
  556.  
  557. sub model_scan_recurse
  558. {
  559.   my @list;
  560.   if (@_) { @list = $_[0]->[0]; }
  561.   
  562.   while (@gst_xml_scan_list)
  563.   {
  564.     $el = $gst_xml_scan_list[0]; shift @gst_xml_scan_list;
  565.  
  566.     if ($el eq "")  # Empty strings.
  567.     {
  568.       next;
  569.     }
  570.     elsif ($el =~ /^\<[!?].*\>$/s)  # PI and DTD.
  571.     {
  572.       $el =~ /^\<([^\>]+)\>$/s;
  573.       push (@list, "__unparsed__");
  574.       push (@list, $1);
  575.     }
  576.     elsif ($el =~ /^\<.*\/\>$/s)  # Empty.
  577.     {
  578.       $el =~ /^\<([a-zA-Z0-9_-]+).*\/\>$/s;
  579.       push (@list, $1);
  580.       push (@list, &scan_make_kid_array ($el));
  581.     }
  582.     elsif ($el =~ /^\<\/.*\>$/s)  # End.
  583.     {
  584.       last;
  585.     }
  586.     elsif ($el =~ /^\<.*\>$/s)  # Start.
  587.     {
  588.       $el =~ /^\<([a-zA-Z0-9_-]+).*\>$/s;
  589.       push (@list, $1);
  590.       $sublist = &scan_make_kid_array ($el);
  591.       push (@list, &model_scan_recurse ($sublist));
  592.       next;
  593.     }
  594.     elsif ($el ne "")  # PCDATA.
  595.     {
  596.       push (@list, 0);
  597.       push (@list, "$el");
  598.     }
  599.   }
  600.  
  601.   return \@list;
  602. }
  603.  
  604. sub model_scan  # (file) If no file specified, reads stdin.
  605. {
  606.   my ($file) = @_;
  607.   my ($doc, $tree, $compressed);
  608.  
  609.   $file = $gst_input_file if $file eq undef;
  610.  
  611.   if ($file)
  612.   {
  613.     $doc = &read_compressed_file ($file);
  614.     if (!$doc)
  615.     {
  616.       $doc = &read_file ($file);
  617.       $compressed = 0;
  618.     }
  619.     else
  620.     {
  621.       $compressed = 1;
  622.     }
  623.   }
  624.   else
  625.   {
  626.     return undef, 0;
  627.   }
  628.  
  629.   @gst_xml_scan_list = ($doc =~ /([^\<]*)(\<[^\>]*\>)/mg); # pcdata, tag, pcdata, tag, ...
  630.   $tree = &model_scan_recurse;
  631.  
  632.   return $tree, $compressed;
  633. }
  634.  
  635. sub model_save
  636. {
  637.   my ($model, $file, $compressed) = @_;
  638.   my $fd;
  639.  
  640.   if ($compressed == 1)
  641.   {
  642.     $fd = &Utils::File::open_write_compressed ($file);
  643.   }
  644.   else
  645.   {
  646.     $fd = &Utils::File::open_write_from_names ($file);
  647.   }
  648.  
  649.   if ($fd == -1) { return -1; }
  650.  
  651.   print $fd &model_print ($model);
  652.   &Utils::File::close_file ($fd);
  653.  
  654.   return 0;
  655. }
  656.  
  657. # Quote/unquote.
  658.  
  659. @gst_xml_entities = ( "<", '<', ">", '>', "'", '\'', """, '"', "&", '&' );
  660.  
  661.  
  662. sub quote
  663. {
  664.   my $in = $_[0];
  665.   my $out = "";
  666.   my @xe;
  667.   my $joined = 0;
  668.   
  669.   my @clist = split (//, $in);
  670.   
  671.   while (@clist)
  672.   {
  673.     # Find character and join its entity equivalent.
  674.     # If none found, simply join the character.
  675.     
  676.     $joined = 0;        # Cumbersome.
  677.     
  678.     for (@xe = @gst_xml_entities; @xe && !$joined; )
  679.     {
  680.       if ($xe [1] eq $clist [0]) { $out = join ('', $out, $xe [0]); $joined = 1; }
  681.       shift @xe; shift @xe;
  682.     }
  683.     
  684.     if (!$joined) { $out = join ('', $out, $clist [0]); }
  685.     shift @clist;
  686.   }
  687.   
  688.   return $out;
  689. }
  690.  
  691.  
  692. sub unquote
  693. {
  694.   my $ret = $_[0];
  695.   my $i;
  696.  
  697.   #print STDERR "INI U: $ret\n";
  698.   
  699.   for ($i = 0; $gst_xml_entities[$i] ne undef; $i += 2)
  700.   {
  701.     $ret =~ s/$gst_xml_entities[$i]/$gst_xml_entities[$i + 1]/g;
  702.   }
  703.  
  704.   while ($ret =~ /&#([0-9]+);/)
  705.   {
  706.     $num = $1;
  707.     $c = chr ($num);
  708.     $ret =~ s/&#$num;/$c/g;
  709.   }
  710.  
  711.   #print STDERR "END U: $ret\n";
  712.   
  713.   return $ret;
  714. }
  715.  
  716.  
  717. # --- XML parsing --- #
  718.  
  719.  
  720. sub get_pcdata
  721. {
  722.   my $tree = $_[0];
  723.   my $retval;
  724.   
  725.   shift @$tree;  # Skip attributes.
  726.   
  727.   while (@$tree)
  728.   {
  729.     if ($$tree[0] == 0)
  730.     {
  731.       $retval = &unquote ($$tree[1]);
  732.       return ($retval);
  733.     }
  734.     
  735.     shift @$tree;
  736.     shift @$tree;
  737.   }
  738.  
  739.   return "";
  740. }
  741.  
  742. # Compresses node into a word and returns it.
  743.  
  744. sub get_word
  745. {
  746.   my $tree = $_[0];
  747.   my $retval;
  748.  
  749.   $retval = &get_pcdata ($tree);
  750.   $retval =~ tr/ \n\r\t\f//d;
  751.   return $retval;
  752. }
  753.  
  754.  
  755. # Compresses node into a size and returns it.
  756.  
  757. sub get_size
  758. {
  759.   my $tree = $_[0];
  760.   my $retval;
  761.  
  762.   $retval = &get_word ($tree);
  763.   if ($retval =~ /Mb$/)
  764.   {
  765.     $retval =~ tr/ Mb//d; 
  766.     $retval *= 1024;
  767.   }
  768.  
  769.   return $retval;
  770. }
  771.  
  772.  
  773. # Replaces misc. whitespace with spaces and returns text.
  774.  
  775. sub get_text
  776. {
  777.   my $tree = $_[0];
  778.   my $retval;
  779.  
  780.   $retval = &get_pcdata ($tree);
  781.   my $type = ref ($retval);
  782.  
  783.   if (!$type) { $retval =~ tr/\n\r\t\f/    /; }  
  784.  
  785.   return $retval;
  786. }
  787.  
  788. sub get_attribute
  789. {
  790.   my ($tree, $attr) = @_;
  791.  
  792.   return $$tree[0]->{$attr};
  793. }
  794.  
  795. sub get_state
  796. {
  797.   my ($tree) = @_;
  798.  
  799.   # Check attribute; 'yes', 'true', 'no', 'false'.
  800.   return &Utils::Util::read_boolean ($$tree[0]->{state});
  801. }
  802.  
  803. # XML model operations.
  804.  
  805. # Locate a node from the branch leading up to it.
  806. sub model_find
  807. {
  808.   my ($model, $varpath) = @_;
  809.   my ($branch, @path);
  810.  
  811.   $branch = $model;
  812.   @path   = split /\//, $varpath;
  813.  
  814.   for $elem (@path)
  815.   {
  816.     next if ($elem eq "");
  817.     my @children = @$branch;
  818.     shift @children;  # Attributes
  819.     $branch = undef;
  820.  
  821.     while (@children)
  822.     {
  823.       if ($children [0] eq $elem)
  824.       {
  825.         shift @children;
  826.         $branch = shift @children;
  827.         last;
  828.       }
  829.  
  830.       shift @children;
  831.       shift @children;
  832.     }
  833.  
  834.     last if ($branch == undef);
  835.   }
  836.  
  837.   return $branch;
  838. }
  839.  
  840. # Add a branch to another branch. Allows duplicates.
  841. sub model_add
  842. {
  843.   my ($model, $varpath, $addpath) = @_;
  844.   my ($branch, @path);
  845.  
  846.   @path = split /\//, $addpath;
  847.   $branch = &model_find ($model, $varpath);
  848.   if ($branch == undef)
  849.   {
  850.     return -1;
  851.   }
  852.  
  853.   for $elem (@path)
  854.   {
  855.     my %hash;
  856.     my @list = ();
  857.  
  858.     push @list, \%hash;
  859.  
  860.     push @$branch, $elem;
  861.     push @$branch, \@list;
  862.  
  863.     $branch = \@list;
  864.   }
  865.  
  866.   return 0;
  867. }
  868.  
  869. # Ensure a branch exists, by extending the branch with given elements, if needed.
  870. sub model_ensure
  871. {
  872.   my ($model, $varpath) = @_;
  873.   my ($branch, @path);
  874.  
  875.   $branch = $model;
  876.   @path   = split /\//, $varpath;
  877.  
  878.   for $elem (@path)
  879.   {
  880.     next if ($elem eq "");
  881.  
  882.     my @children = @$branch;
  883.     my $parent_branch = $branch;
  884.  
  885.     shift @children;  # Attributes
  886.     $branch = undef;
  887.  
  888.     while (@children)
  889.     {
  890.       if ($children [0] eq $elem)
  891.       {
  892.         shift @children;
  893.         $branch = shift @children;
  894.         last;
  895.       }
  896.  
  897.       shift @children;
  898.       shift @children;
  899.     }
  900.  
  901.     if ($branch == undef)
  902.     {
  903.       my %hash;
  904.       my @list = ();
  905.  
  906.       $branch = \@list;
  907.  
  908.       push @list, \%hash;
  909.  
  910.       push @$parent_branch, $elem;
  911.       push @$parent_branch, $branch;
  912.     }
  913.   }
  914.  
  915.   return $branch;
  916. }
  917.  
  918. sub model_remove
  919. {
  920.   my ($model, $varpath, $tag) = @_;
  921.   my ($branch, $i);
  922.  
  923.   @path = split /\//, $addpath;
  924.   $branch = &model_find ($model, $varpath);
  925.   if ($branch == undef)
  926.   {
  927.     return -1;
  928.   }
  929.  
  930.   for ($i = 1; $i < @$branch; $i += 2)
  931.   {
  932.     if (@$branch [$i] eq $tag)
  933.     {
  934.       @$branch = (@$branch [0 .. $i - 1], @$branch [$i + 2 .. @$branch - 1]);
  935.       return 0;
  936.     }
  937.   }
  938.  
  939.   return -1;
  940. }
  941.  
  942. sub model_get_children
  943. {
  944.   my ($branch) = @_;
  945.   my (@children);
  946.  
  947.   if (!$branch) { return \@children; }
  948.  
  949.   for ($i = 1; $i < @$branch; $i += 2)
  950.   {
  951.     if (@$branch [$i] ne "__unparsed__" && @$branch [$i] ne "0")
  952.     {
  953.       push @children, @$branch [$i + 1];
  954.     }
  955.   }
  956.  
  957.   return \@children;
  958. }
  959.  
  960. sub model_get_pcdata
  961. {
  962.   my ($branch) = @_;
  963.   my ($i);
  964.  
  965.   for ($i = 1; $i < @$branch; $i += 2)
  966.   {
  967.     if ($$branch [$i] == 0)
  968.     {
  969.       my $retval = &unquote ($$branch [$i + 1]);
  970.       return ($retval);
  971.     }
  972.   }
  973.  
  974.   return "";
  975. }
  976.  
  977. sub model_set_pcdata
  978. {
  979.   my ($branch, $pcdata) = @_;
  980.  
  981.   @$branch = (@$branch [0]);
  982.  
  983.   $$branch [1] = 0;
  984.   $$branch [2] = "e ($pcdata);
  985. }
  986.  
  987. sub model_get_attribute
  988. {
  989.   my ($branch, $attr) = @_;
  990.  
  991.   return $$branch[0]->{$attr};
  992. }
  993.  
  994. sub model_set_attribute
  995. {
  996.   my ($branch, $attr, $value) = @_;
  997.  
  998.   return $$branch[0]->{$attr} = $value;
  999. }
  1000.  
  1001. 1;
  1002.