File Coverage

blib/lib/CGI/XMLForm.pm

Criterion	Covered	Total	%
statement	13	15	86.6
branch			n/a
condition			n/a
subroutine	5	5	100.0
pod			n/a
total	18	20	90.0

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 "\n";
		}
		else {
			return ("\t" x --$cgi->{'.closetags'}) . "\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/
		$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__