diff options
Diffstat (limited to 'knetwortdeconf/backends/xml.pl.in')
| -rw-r--r-- | knetwortdeconf/backends/xml.pl.in | 1012 |
1 files changed, 0 insertions, 1012 deletions
diff --git a/knetwortdeconf/backends/xml.pl.in b/knetwortdeconf/backends/xml.pl.in deleted file mode 100644 index b9810c6..0000000 --- a/knetwortdeconf/backends/xml.pl.in +++ /dev/null @@ -1,1012 +0,0 @@ -#!/usr/bin/env perl -#-*- Mode: perl; tab-width: 2; indent-tabs-mode: nil; c-basic-offset: 2 -*- - -# XML printing, scanning and parsing. -# -# Copyright (C) 2000-2001 Ximian, Inc. -# -# Authors: Hans Petter Jansson <hpj@ximian.com> -# Arturo Espinosa <arturo@ximian.com> -# Kenneth Christiansen <kenneth@gnu.org> -# -# This program is free software; you can redistribute it and/or modify -# it under the terms of the GNU Library General Public License as published -# by the Free Software Foundation; either version 2 of the License, or -# (at your option) any later version. -# -# This program is distributed in the hope that it will be useful, -# but WITHOUT ANY WARRANTY; without even the implied warranty of -# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -# GNU Library General Public License for more details. -# -# You should have received a copy of the GNU Library General Public License -# along with this program; if not, write to the Free Software -# Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA. - - -$SCRIPTSDIR = "@scriptsdir@"; -if ($SCRIPTSDIR =~ /^@scriptsdir[@]/) -{ - $SCRIPTSDIR = "."; - $DOTIN = ".in"; -} - -require "$SCRIPTSDIR/util.pl$DOTIN"; -require "$SCRIPTSDIR/general.pl$DOTIN"; -require "$SCRIPTSDIR/debug.pl$DOTIN"; - -use Text::ParseWords; - -$has_encode = 0; -if (eval "require Encode") { - Encode->import (); - $has_encode = 1; -} - -# --- XML print formatting --- # - - -# &gst_xml_enter: Call after entering a block. Increases indent level. -# &gst_xml_leave: Call before leaving a block. Decreases indent level. -# &gst_xml_print_indent: Call before printing a line. Indents to current level. -# &gst_xml_print_vspace: Ensures there is a vertical space of one and only one line. -# &gst_xml_print: Indent, then print all arguments. Just for sugar. - - -my $gst_indent_level = 0; -my $gst_have_vspace = 0; - -my @gst_xml_stack; - -sub gst_xml_print_comment # (comment text) -{ - my ($comment) = @_; - - &gst_xml_print_line ("<!-- $comment -->") if $comment; -} - - -sub gst_xml_print_begin -{ - my ($name) = @_; - - $name = $gst_name if !$name; - - &gst_xml_print_string ("<?xml version='1.0' encoding='UTF-8' standalone='yes'?>\n"); - &gst_xml_print_string ("<!DOCTYPE $name []>\n\n"); - &gst_xml_print_string ("<$name>\n"); - - &gst_xml_enter (); - - &gst_xml_print_vspace (); -} - - -# The frontend expects exactly this string. Don not alter. -sub gst_xml_print_request_end -{ - print "\n<!-- GST: end of request -->\n"; -} - - -sub gst_xml_print_end -{ - my ($name) = @_; - - $name = $gst_name if !$name; - - &gst_xml_leave (); - - &gst_xml_print_vspace (); - &gst_xml_print_string ("</$name>\n"); -} - - -sub gst_xml_enter -{ - $gst_indent_level += 2; -} - - -sub gst_xml_leave -{ - $gst_indent_level -= 2; -} - - -sub gst_xml_print_string -{ - if ($has_encode) - { - if (&decode_utf8 ($_[0]) eq undef) - { - # we first decode the string, if it's not - # utf-8 (returns undef), then encode it - print "" . &encode_utf8 ($_[0]); - return; - } - } - - # It could not encode the string, write it as is - print $_[0]; -} - -sub gst_xml_format_indent -{ - $gst_have_vspace = 0; - return " " x $gst_indent_level; -} - -sub gst_xml_print_indent -{ - &gst_xml_print_string(&gst_xml_format_indent ()); -} - -sub gst_xml_print_vspace -{ - if (not $gst_have_vspace) - { - &gst_xml_print_string ("\n"); - $gst_have_vspace = 1; - } -} - - -sub gst_xml_print_line -{ - my $line; - $line = join ("", @_); - $line =~ tr/\n//d; - - &gst_xml_print_indent (); - &gst_xml_print_string ($line . "\n"); -} - -sub gst_xml_format_pcdata # (name, pcdata) -{ - my ($name, $pcdata) = @_; - return "<$name>$pcdata</$name>" if defined ($name) || defined ($pcdata); -} - -sub gst_xml_print_pcdata # (name, pcdata) -{ - my ($name, $pcdata) = @_; - my $line = &gst_xml_format_pcdata ($name, $pcdata); - - &gst_xml_print_line ($line) if $line; -} - -sub gst_xml_format_state_tag -{ - my ($name, $state) = @_; - my $boolean = &gst_print_boolean_truefalse ($state); - - return "<$name state='$boolean'/>"; -} - -sub gst_xml_print_state_tag -{ - my ($name, $state) = @_; - my $state_tag = &gst_xml_format_state_tag ($name, $state); - - &gst_xml_print_line ($state_tag); -} - -# Pass a hash and the keys whose items are scalars. Print <key>val</key>. -sub gst_xml_print_scalars -{ - my ($h, @scalar_keys) = @_; - my ($i, $val); - - @scalar_keys = sort @scalar_keys; - - while ($i = shift @scalar_keys) - { - $val = &gst_xml_quote ($$h{$i}); - &gst_xml_print_line ("<$i>$val</$i>\n") if exists $$h{$i}; - } - -} - -# Print the @$array using <$tag>val</$tag> foreach val in the array. -# Actually lets print_structure do that now. Just print sequentially -# the given elements, using as $tag as the surrounding tags. -sub gst_xml_print_array -{ - my ($array, $tag) = @_; - my ($i, $val); - - return if (scalar @$array <= 0); - - &gst_xml_print_vspace (); - foreach $i (@$array) - { - &gst_xml_print_structure ($i, $tag); - } -} - -# Pass a hash and the keys whose items are arrays. Print <key>val</key> foreach val -# in the array at hash{key} -sub gst_xml_print_arrays -{ - my ($h, @array_keys) = @_; - my ($i, $j, $val); - - foreach $i (sort @array_keys) - { - &gst_xml_print_array ($$h{$i}, $i) if (exists $$h{$i}) - } -} - -# Pass a hash, create a parent tag $tag and print <key>val</key> for every -# value pair in the hash. If structure refs are found, these are recursively -# printed with print_structure. -sub gst_xml_print_hash -{ - my ($hash, $tag) = @_; - my ($j, $val); - - &gst_xml_print_vspace (); - if (defined $tag) { - &gst_xml_print_line ("<$tag>\n"); - &gst_xml_enter (); - } - - foreach $j (sort keys (%$hash)) - { - &gst_xml_print_structure ($$hash{$j}, $j); - } - - if (defined $tag) { - &gst_xml_leave (); - &gst_xml_print_line ("</$tag>\n"); - } -} - -# Call the corresponding function depending on the reference -# type of $x. If just a scalar, print <$tag>$x</$tag>. -sub gst_xml_print_structure -{ - my ($x, $tag) = @_; - - if (ref $x eq "ARRAY") { &gst_xml_print_array ($x, $tag); } - elsif (ref $x eq "HASH") { &gst_xml_print_hash ($x, $tag); } - else - { - &gst_xml_print_line ("<$tag>" . &gst_xml_quote ($x) . "</$tag>\n"); - } -} - -# Treats hash as an array: doesn't use the keys as tags for its -# elements, but the given tag. -sub gst_xml_print_hash_hash -{ - my ($h, $tag) = @_; - my $i; - - foreach $i (sort keys %$h) - { - &gst_xml_print_hash ($$h{$i}, $tag); - } -} - - -sub gst_xml_container_enter # (name) -{ - my ($container) = @_; - - ## gst_xml_stack is not my, as it is defined at top, - ## so it is global - push @gst_xml_stack, $container; - - &gst_xml_print_line ("<$container>"); - &gst_xml_enter(); -} - - -sub gst_xml_container_leave -{ - ## checks if there is a start tag - if ($#gst_xml_stack >= 0) - { - my $current_container = pop @gst_xml_stack; - - &gst_xml_leave (); - &gst_xml_print_line ("</$current_container>"); - } -} - - -sub gst_xml_print_container # (name, @strings) -{ - my ($name, @strings) = @_; - - if (@strings) { - &gst_xml_container_enter ($name); - foreach $tag (@strings) { - &gst_xml_print_line ("$tag"); - } - &gst_xml_container_leave (); - } -} - -# --- XML printing from in-memory model --- # - -sub gst_xml_model_print_attributes -{ - my ($tree) = @_; - my ($attrs, $string); - - $attrs = @$tree [0]; - - for $attr (keys %$attrs) - { - $string .= " " . $attr . "=\"" . $$attrs{$attr} . "\""; - } - - return $string; -} - -sub gst_xml_model_print_recurse -{ - my ($tree, $indent) = @_; - my ($string); - - my @children = @$tree; - shift @children; # Attributes - - while (@children) - { - my $branch = $children [1]; - - if ($children [0] eq "__unparsed__") - { - $string .= "<" . $children [1] . ">"; - } - elsif ($children [0] eq "0") - { - $string .= $children [1]; - } - elsif (@$branch == 1) # Empty tag. - { - $string .= "<" . $children [0] . &gst_xml_model_print_attributes ($branch) . "/>"; - } - else - { - $string .= "<" . $children [0] . &gst_xml_model_print_attributes ($branch) . ">"; - $string .= &gst_xml_model_print_recurse ($branch); - $string .= "</" . $children [0] . ">"; - } - - shift @children; - shift @children; - } - -# if ($branch) -# { -# return &gst_xml_get_attribute ($branch, $property) if $property ne ""; -# return &gst_xml_get_pcdata ($branch); -# } - - return $string; -} - -sub gst_xml_model_print -{ - my ($tree) = @_; - my ($string); - - $string = &gst_xml_model_print_recurse ($tree); - chomp $string; - $string .= "\n"; - - return $string; -} - -# --- XML scanning --- # - - -# This code tries to replace XML::Parser scanning from stdin in tree mode. - -sub gst_xml_scan_make_kid_array -{ - my $line = shift; - my (%hash, @sublist, @attr, @list); - - # Remove < and /> - $line =~ s/^[ \t]*<//; - $line =~ s/[\/]?>[ \t]*$//; - - my @list = "ewords ('[ \t]+', 1, $line); - shift @list; # push tag name. - - foreach (@list) - { - my @tmp = split '[ \t]*=[ \t]*'; - if (scalar @tmp == 2 && $tmp[1] =~ s/[\"\']//g) - { - push @attr, @tmp; - } - } - - %hash = @attr; - - push (@sublist, \%hash); - return \@sublist; -} - - -sub gst_xml_scan_recurse -{ - my ($gst_xml_scan_list, $list_arg) = @_; - my @list; - if ($list_arg ne undef) { @list = $$list_arg[0]; } - - while (@$gst_xml_scan_list) - { - $el = shift @$gst_xml_scan_list; - - if (($el eq "") || $el =~ /^\<[!?].*\>$/s) { next; } # Empty strings, PI and DTD must go. - if ($el =~ /^\<.*\/\>$/s) # Empty. - { - $el =~ /^\<([a-zA-Z0-9_-]+).*\/\>$/s; - push (@list, $1); - push (@list, &gst_xml_scan_make_kid_array ($el)); - } - elsif ($el =~ /^\<\/.*\>$/s) # End. - { - last; - } - elsif ($el =~ /^\<.*\>$/s) # Start. - { - $el =~ /^\<([a-zA-Z0-9_-]+).*\>$/s; - push (@list, $1); - $sublist = &gst_xml_scan_make_kid_array ($el); - push (@list, &gst_xml_scan_recurse ($gst_xml_scan_list, $sublist)); - next; - } - elsif ($el ne "") # PCDATA. - { - push (@list, 0); - push (@list, "$el"); - } - } - - return \@list; -} - - -sub gst_xml_read_file -{ - my ($file) = @_; - my ($doc, $i); - local *INPUT_FILE; - - open INPUT_FILE, $file; - $doc .= $i while ($i = <INPUT_FILE>); - close INPUT_FILE; - - return $doc; -} - - -sub gst_xml_read_compressed_file -{ - my ($file) = @_; - my ($doc, $i, $fd); - - $fd = &gst_file_run_pipe_read ("gunzip -c $file"); - return undef if $fd eq undef; - $doc .= $i while ($i = <$fd>); - &gst_file_close ($fd); - - if (length ($doc) < 4) # Allow for one blank line from gzip, '\n\r'. - { - $doc = undef; - } - - return $doc; -} - - -sub gst_xml_read_stdin -{ - my ($i, $doc); - - do { - $i = <STDIN>; - - if ($i ne undef) - { - $doc .=$i; - } - } while (! ($i =~ /^<!-- GST: end of request -->$/)); - - return $doc; -} - -# (file, tool) If no file specified, reads stdin. -# file could also contain xml document. -# If tool is an gst_tool, stores the read buffer in -# $$tool{"xml_doc"}. -sub gst_xml_scan -{ - my ($file, $tool) = @_; - my ($doc, @tree, @gst_xml_scan_list); - - $file = $gst_input_file unless $file; - - if ($file && stat ($file)) - { - $doc = &gst_xml_read_file ($file); - } - elsif ($file) - { - $doc = $file; - } - else - { - $doc = &gst_xml_read_stdin (); - } - - # remove any blank or carriage return at the beginning of the xml - $doc =~ s/^[ \n]*//; - - &gst_debug_print_log_to_file ("in.xml", $doc); - - $$tool{"xml_doc"} = $doc if (&gst_is_tool ($tool)); - - @gst_xml_scan_list = ($doc =~ /([^\<]*)(\<[^\>]*\>)[ \t\n\r]*/mg); # pcdata, tag, pcdata, tag, ... - $tree = &gst_xml_scan_recurse (\@gst_xml_scan_list); - - return $tree; -} - -# XML scanning that preserves more exact attributes of the scanned XML. - -sub gst_xml_model_scan_recurse -{ - my @list; - if (@_) { @list = $_[0]->[0]; } - - while (@gst_xml_scan_list) - { - $el = $gst_xml_scan_list[0]; shift @gst_xml_scan_list; - - if ($el eq "") # Empty strings. - { - next; - } - elsif ($el =~ /^\<[!?].*\>$/s) # PI and DTD. - { - $el =~ /^\<([^\>]+)\>$/s; - push (@list, "__unparsed__"); - push (@list, $1); - } - elsif ($el =~ /^\<.*\/\>$/s) # Empty. - { - $el =~ /^\<([a-zA-Z0-9_-]+).*\/\>$/s; - push (@list, $1); - push (@list, &gst_xml_scan_make_kid_array ($el)); - } - elsif ($el =~ /^\<\/.*\>$/s) # End. - { - last; - } - elsif ($el =~ /^\<.*\>$/s) # Start. - { - $el =~ /^\<([a-zA-Z0-9_-]+).*\>$/s; - push (@list, $1); - $sublist = &gst_xml_scan_make_kid_array ($el); - push (@list, &gst_xml_model_scan_recurse ($sublist)); - next; - } - elsif ($el ne "") # PCDATA. - { - push (@list, 0); - push (@list, "$el"); - } - } - - return \@list; -} - -sub gst_xml_model_scan # (file) If no file specified, reads stdin. -{ - my ($file) = @_; - my ($doc, $tree, $compressed); - - $file = $gst_input_file if $file eq undef; - - if ($file) - { - $doc = &gst_xml_read_compressed_file ($file); - if (!$doc) - { - $doc = &gst_xml_read_file ($file); - $compressed = 0; - } - else - { - $compressed = 1; - } - } - else - { - return undef, 0; - } - - @gst_xml_scan_list = ($doc =~ /([^\<]*)(\<[^\>]*\>)/mg); # pcdata, tag, pcdata, tag, ... - $tree = &gst_xml_model_scan_recurse; - - return $tree, $compressed; -} - -sub gst_xml_model_save -{ - my ($model, $file, $compressed) = @_; - my $fd; - - if ($compressed == 1) - { - $fd = &gst_file_open_write_compressed ($file); - } - else - { - $fd = &gst_file_open_write_from_names ($file); - } - - if ($fd == -1) { return -1; } - - print $fd &gst_xml_model_print ($model); - &gst_file_close ($fd); - - return 0; -} - -# Quote/unquote. - -@gst_xml_entities = ( "<", '<', ">", '>', "'", '\'', """, '"', "&", '&' ); - - -sub gst_xml_quote -{ - my $in = $_[0]; - my $out = ""; - my @xe; - my $joined = 0; - - my @clist = split (//, $in); - - while (@clist) - { - # Find character and join its entity equivalent. - # If none found, simply join the character. - - $joined = 0; # Cumbersome. - - for (@xe = @gst_xml_entities; @xe && !$joined; ) - { - if ($xe [1] eq $clist [0]) { $out = join ('', $out, $xe [0]); $joined = 1; } - shift @xe; shift @xe; - } - - if (!$joined) { $out = join ('', $out, $clist [0]); } - shift @clist; - } - - return $out; -} - - -sub gst_xml_unquote -{ - my $ret = $_[0]; - my $i; - - #print STDERR "INI U: $ret\n"; - - for ($i = 0; $gst_xml_entities[$i] ne undef; $i += 2) - { - $ret =~ s/$gst_xml_entities[$i]/$gst_xml_entities[$i + 1]/g; - } - - while ($ret =~ /&#([0-9]+);/) - { - $num = $1; - $c = chr ($num); - $ret =~ s/&#$num;/$c/g; - } - - #print STDERR "END U: $ret\n"; - - return $ret; -} - - -# --- XML parsing --- # - - -sub gst_xml_get_pcdata -{ - my $tree = $_[0]; - my $retval; - - shift @$tree; # Skip attributes. - - while (@$tree) - { - if ($$tree[0] == 0) - { - $retval = &gst_xml_unquote ($$tree[1]); - &gst_debug_print_line ("gst_xml_get_pcdata: $retval"); - return ($retval); - } - - shift @$tree; - shift @$tree; - } - - return ""; -} - -# Compresses node into a word and returns it. - -sub gst_xml_get_word -{ - my $tree = $_[0]; - my $retval; - - $retval = &gst_xml_get_pcdata ($tree); - $retval =~ tr/ \n\r\t\f//d; - return $retval; -} - - -# Compresses node into a size and returns it. - -sub gst_xml_get_size -{ - my $tree = $_[0]; - my $retval; - - $retval = &gst_xml_get_word ($tree); - if ($retval =~ /Mb$/) - { - $retval =~ tr/ Mb//d; - $retval *= 1024; - } - - return $retval; -} - - -# Replaces misc. whitespace with spaces and returns text. - -sub gst_xml_get_text -{ - my $tree = $_[0]; - my $retval; - - $retval = &gst_xml_get_pcdata ($tree); - my $type = ref ($retval); - - if (!$type) { $retval =~ tr/\n\r\t\f/ /; } - - return $retval; -} - -sub gst_xml_get_attribute -{ - my ($tree, $attr) = @_; - - return $$tree[0]->{$attr}; -} - -sub gst_xml_get_state -{ - my ($tree) = @_; - - # Check attribute; 'yes', 'true', 'no', 'false'. - return &gst_util_read_boolean ($$tree[0]->{state}); -} - -# XML model operations. - -# Locate a node from the branch leading up to it. -sub gst_xml_model_find -{ - my ($model, $varpath) = @_; - my ($branch, @path); - - $branch = $model; - @path = split /\//, $varpath; - - for $elem (@path) - { - next if ($elem eq ""); - my @children = @$branch; - shift @children; # Attributes - $branch = undef; - - while (@children) - { - if ($children [0] eq $elem) - { - shift @children; - $branch = shift @children; - last; - } - - shift @children; - shift @children; - } - - last if ($branch == undef); - } - - return $branch; -} - -# Add a branch to another branch. Allows duplicates. -sub gst_xml_model_add -{ - my ($model, $varpath, $addpath) = @_; - my ($branch, @path); - - @path = split /\//, $addpath; - $branch = &gst_xml_model_find ($model, $varpath); - if ($branch == undef) - { - return -1; - } - - for $elem (@path) - { - my %hash; - my @list = (); - - push @list, \%hash; - - push @$branch, $elem; - push @$branch, \@list; - - $branch = \@list; - } - - return 0; -} - -# Ensure a branch exists, by extending the branch with given elements, if needed. -sub gst_xml_model_ensure -{ - my ($model, $varpath) = @_; - my ($branch, @path); - - $branch = $model; - @path = split /\//, $varpath; - - for $elem (@path) - { - next if ($elem eq ""); - - my @children = @$branch; - my $parent_branch = $branch; - - shift @children; # Attributes - $branch = undef; - - while (@children) - { - if ($children [0] eq $elem) - { - shift @children; - $branch = shift @children; - last; - } - - shift @children; - shift @children; - } - - if ($branch == undef) - { - my %hash; - my @list = (); - - $branch = \@list; - - push @list, \%hash; - - push @$parent_branch, $elem; - push @$parent_branch, $branch; - } - } - - return $branch; -} - -sub gst_xml_model_remove -{ - my ($model, $varpath, $tag) = @_; - my ($branch, $i); - - @path = split /\//, $addpath; - $branch = &gst_xml_model_find ($model, $varpath); - if ($branch == undef) - { - return -1; - } - - for ($i = 1; $i < @$branch; $i += 2) - { - if (@$branch [$i] eq $tag) - { - @$branch = (@$branch [0 .. $i - 1], @$branch [$i + 2 .. @$branch - 1]); - return 0; - } - } - - return -1; -} - -sub gst_xml_model_get_children -{ - my ($branch) = @_; - my (@children); - - if (!$branch) { return \@children; } - - for ($i = 1; $i < @$branch; $i += 2) - { - if (@$branch [$i] ne "__unparsed__" && @$branch [$i] ne "0") - { - push @children, @$branch [$i + 1]; - } - } - - return \@children; -} - -sub gst_xml_model_get_pcdata -{ - my ($branch) = @_; - my ($i); - - for ($i = 1; $i < @$branch; $i += 2) - { - if ($$branch [$i] == 0) - { - my $retval = &gst_xml_unquote ($$branch [$i + 1]); - return ($retval); - } - } - - return ""; -} - -sub gst_xml_model_set_pcdata -{ - my ($branch, $pcdata) = @_; - - @$branch = (@$branch [0]); - - $$branch [1] = 0; - $$branch [2] = &gst_xml_quote ($pcdata); -} - -sub gst_xml_model_get_attribute -{ - my ($branch, $attr) = @_; - - return $$branch[0]->{$attr}; -} - -sub gst_xml_model_set_attribute -{ - my ($branch, $attr, $value) = @_; - - return $$branch[0]->{$attr} = $value; -} - -1; |