package CGI::XMLForm; use strict; use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use CGI; use CGI::XMLForm::Path; use XML::Parser; @ISA = qw(CGI); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. @EXPORT = qw( ); $VERSION = '0.10'; sub new { my $proto = shift; my $class = ref($proto) || $proto; my $self = $class->SUPER::new(@_); bless ($self, $class); # reconsecrate return $self; } sub readXML { my $self = shift; my $xml = shift; my @queries = @_; my @Requests; my $req = new CGI::XMLForm::Path(); do { $req = new CGI::XMLForm::Path(shift @queries, $req); push @Requests, $req; } while @queries; my $currenttree = new CGI::XMLForm::Path(); my $p = new XML::Parser(Style => 'Stream', _parseresults => [], _currenttree => $currenttree, _requests => \@Requests, ); my $results; eval { $results = $p->parse($xml); # warn "Parse returned ", @{$results}, "\n"; }; if ($@) { return $@; } else { return @{$results}; } } sub StartTag { my $expat = shift; return $expat->finish() if $expat->{_done}; my $element = shift; # my %attribs = %_; #warn "Start: $element\n"; $expat->{_currenttree}->Append($element, %_); my $current = $expat->{_currenttree}; #warn "Path now: ", $expat->{_currenttree}->Path, "\n"; foreach (0..$#{$expat->{_requests}}) { next unless defined $expat->{_requests}->[$_]->Attrib; # warn "Looking for attrib: ", $expat->{_requests}->[$_]->Attrib, "\n"; if (defined $_{$expat->{_requests}->[$_]->Attrib}) { # Looking for attrib if ($expat->{_requests}->[$_]->isEqual($current)) { # We have equality! found($expat, $expat->{_requests}->[$_], $_{$expat->{_requests}->[$_]->Attrib}); splice(@{$expat->{_requests}}, $_, 1) unless $expat->{_requests}->[$_]->isRepeat; $expat->{_done} = 1 if (@{$expat->{_requests}} == 0); return; } } } } sub EndTag { my $expat = shift; return $expat->finish() if $expat->{_done}; # warn "End: $_\n"; $expat->{_currenttree}->Pop(); } sub Text { my $expat = shift; my $text = $_; return $expat->finish() if $expat->{_done}; my @Requests = @{$expat->{_requests}}; my $current = $expat->{_currenttree}; foreach (0..$#Requests) { if (!$Requests[$_]->Attrib) { # Not looking for an attrib # warn "Comparing : ", $Requests[$_]->Path, " : ", $expat->{_currenttree}->Path, "\n"; if ($Requests[$_]->isEqual($current)) { found($expat, $Requests[$_], $text); splice(@{$expat->{_requests}}, $_, 1) unless $Requests[$_]->isRepeat; $expat->{_done} = 1 if (@Requests == 0); return; } } } } sub found { my $expat = shift; my ($request, $found) = @_; #warn "Found: ", $request->Path, " : $found\n"; if ($request->Path =~ /\.\*/) { # Request path contains a regexp my $match = $request->Path; $match =~ s/\[(.*?)\]/\\\[$1\\\]/g; # warn "Regexp: ", $expat->{_currenttree}->Path, " =~ |$match|\n"; $expat->{_currenttree}->Path =~ /$match/; push @{$expat->{_parseresults}}, $&, $found; } else { push @{$expat->{_parseresults}}, $request->Path, $found; } } sub EndDocument { my $expat = shift; delete $expat->{_done}; delete $expat->{_currenttree}; delete $expat->{_requests}; return $expat->{_parseresults}; } sub formatElement($$) { # Properly formats elements whether opening or closing. my $cgi = shift; my $open = shift; my $element = shift; my $level = shift; $element =~ s/&slash;/\//g; $element =~ /^(.*?)(\[(.*)\])?$/; my $output = $1; my $attribs = $3 || ""; if (!$open) { if (!$cgi->{'.closetags'}) { $cgi->{'.closetags'} = $level; return "$output>\n"; } else { return ("\t" x --$cgi->{'.closetags'}) . "$output>\n"; } } # If we have attributes while ($attribs =~ /\@(\w+?)=([\"\'])(.*?)\2(\s+and\s+)?/g) { $output .= " $1=\"$3\""; } my $save = $cgi->{'.closetags'}; $cgi->{'.closetags'} = 0; return ($save ? '' : "\n") . ("\t" x $level) . "<$output>"; } sub ToXML { shift()->toXML(@_); } sub toXML { my $self = shift; my $filename = shift; if (defined $filename) { local *OUTPUT; open(OUTPUT, ">$filename") or die "Can't open $filename for output: $!"; print OUTPUT $self->{".xml"}; close OUTPUT; } defined wantarray && return $self->{".xml"}; } sub parse_params { my($self,$tosplit) = @_; my(@pairs) = split('&',$tosplit); my($param,$value); my $output = ""; my @prevStack; my @stack; my @rawParams; my $relative; $self->{'.closetags'} = 0; foreach (@pairs) { ($param,$value) = split('=',$_,2); $param = $self->unescape($param); $value = $self->unescape($value); $self->add_parameter($param); push (@{$self->{$param}},$value); next if $param =~ /^xmlcgi:ignore/; next if $param =~ /^\.\w/; # Skip CGI.pm ".submit" and other buttons push @rawParams, $param, $value; # Encode values $value =~ s/&/&/g; $value =~ s/</g; $value =~ s/>/>/g; $value =~ s/'/'/g; $value =~ s/"/"/g; $value =~ s/\//\&slash;/g; # We decode this later... $param =~ s/\[(.*?)\/(.*?)\]/\[$1\&slash;$2\]/g; # Here we make the attribute into an internal attrib # so that tree compares work properly my $attrib = 0; if($param =~ s/(\])?\/(\@\w+)$/(($1 && " and ")||"[").qq($2="$value"])/e) { $attrib = 1; } # Do work here if ($param =~ s/^\///) { # If starts with a slash it's a root element @stack = split /\//, $param; $relative = 0; } else { # Otherwise it's a relative path # - We don't need to do this, but it's here commented out # to show what we're implying. # @stack = @prevStack; # We don't want the last element if the previous param # was also a relative param. my $top = pop @stack if ($relative); foreach ( split(/\//, $param)) { if ($_ eq "..") { if ($top) { $output .= $self->formatElement(0, $top, scalar @stack); $top = ''; pop @prevStack; } $output .= $self->formatElement(0, pop(@stack), scalar @stack); pop @prevStack; } else { push @stack, $_; } } $relative++; } # print STDERR "Prev Stack: ", join(", ", @prevStack), "\n"; # print STDERR "New Stack: ", join(", ", @stack), "\n----------\n"; foreach my $i (0..$#stack) { if (defined $prevStack[$i]) { # We've travelled along this branch of the tree before. if (($i == $#stack) || ($prevStack[$i] ne $stack[$i])) { # If we've reached the end of the branch, or the branch has changed... while ($i <= $#prevStack) { # Close the previous branch $output .= $self->formatElement(0, pop(@prevStack), scalar @prevStack); } # And add this new branch $output .= $self->formatElement(1, $stack[$i], scalar @prevStack); push @prevStack, $stack[$i]; } } else { # here we're traversing out into the tree where we've not travelled before. $output .= $self->formatElement(1, $stack[$i], scalar @prevStack); push @prevStack, $stack[$i]; } } # Finally, we output the contents of the form field, unless it's an attribute form field if (!$attrib) { $output .= $value; } # Store the previous stack. @prevStack = @stack; } # Finish by completely popping the stack off. while (@prevStack) { $output .= $self->formatElement(0, pop(@prevStack), scalar @prevStack); } $self->{".xml"} = $output; $self->{rawParams} = \@rawParams; 1; } 1; __END__ =head1 NAME CGI::XMLForm - Extension of CGI.pm which reads/generates formated XML. NB: This is a subclass of CGI.pm, so can be used in it's place. =head1 SYNOPSIS use CGI::XMLForm; my $cgi = new CGI::XMLForm; if ($cgi->param) { print $cgi->header, $cgi->pre($cgi->escapeHTML($cgi->toXML)); } else { open(FILE, "test.xml") or die "Can't open: $!"; my @queries = ('/a', '/a/b*', '/a/b/c*', /a/d'); print $cgi->header, $cgi->pre($cgi->escapeHTML( join "\n", $cgi->readXML(*FILE, @queries))); } =head1 DESCRIPTION This module can either create form field values from XML based on XQL/XSL style queries (full XQL is _not_ supported - this module is designed for speed), or it can create XML from form values. There are 2 key functions: toXML and readXML. =head2 toXML The module takes form fields given in a specialised format, and outputs them to XML based on that format. The idea is that you can create forms that define the resulting XML at the back end. The format for the form elements is: which creates the following XML:
value1 | value2 |
value3 |