cgi-manifest

#!/usr/bin/env perl
#
#  Synopsis:
#	Command line manifest of the contents of xml.cgi files
#  Usage:
#	cgi-manifest xml1.cgi xml2.cgi
#  Depends:
#	Perl module XML::Parser
#  Notes:
#	Should become a perl module.
#
use XML::Parser;

my $PROG = 'cgi-manifest';

my $USAGE = "$PROG [--help] [--<option>] xml1.cgi [xml2.cgi ...]";

$SIG{__DIE__} = sub
{
	chop(my $msg = join('', @_));
	#
	#  Strip off trailing ' at ./file.pl line 123.'
	#
	$msg =~ s/ at [\w\/.-]+ line \d+\.$//;
	print STDERR "$PROG: $msg\n";
	print STDERR "usage: $USAGE\n";
	exit 1;
};

sub help
{
	print <<END;
Synopsis:
	Command line manifest of the contents of xml.cgi files
Usage:
	$USAGE
Options:
	--help		Generate this message.
	--perl5-path	Generate paths to perl putters
Description:
	Extract details suitable for command line parsing from
	the xml.cgi files used by the httpd2 environment.
Depends:
	XML::Parse
Notes:
	Unfortunately, no DTD exists for the xml.cgi schema, so the
	vocabulary is subject to sudden change.
Blame:
	jmscott\@setspace.com
Copyright:
	John Scott, 2006
END
}

#
#  Find immediate element $tag in XML tree.
#
sub find_kid
{
	my %arg = @_;
	my (
		$tag,
		$kids,
		$required,
		$what
	) = (
		$arg{tag},
		$arg{kids},
		$arg{required},
		$arg{what}
	);

	die 'find_kid: missing element tag' unless $tag;

	for (my $i = 1;  defined $kids->[$i];  $i += 2) {
		return $kids->[$i + 1] if $kids->[$i] eq $tag;
	}
	if ($required eq 'yes') {
		$what = 'child' unless $what;
		die "$what: can't find element $tag" if $required eq 'yes';
	}
	return undef;
}
#
#  Find all children of a particular element in XML tree.
#
sub find_kids
{
	my %arg = @_;
	my (
		$tag,
		$kids,
		$required,
		$what
	) = (
		$arg{tag},
		$arg{kids},
		$arg{required},
		$arg{what}
	);
	my @children;

	die 'find_kids: missing element tag' unless $tag;

	for (my $i = 1;  defined $kids->[$i];  $i += 2) {
		push (@children, $kids->[$i + 1]) if $kids->[$i] eq $tag;
	}
	return @children if @children > 0;
	#
	#  Abort if kids required to exist but don't.
	#
	if ($required eq 'yes') {
		$what = 'child' unless $what;
		die "$what: can't find element $tag" if $required eq 'yes';
	}
	return @children;
}

sub perl5_path
{
	my $cgi = $_[0];
	my $main = $cgi->[0]->{name};

	die 'perl5_path: /cgi[@name] missing' unless $main;
	print $main, "\n";

	#
	#  Write /cgi/GET/out/putter scripts.
	#
	if (my $out = find_kid(
		tag     =>      'out',
		kids    =>      find_kid(
					tag     =>      'GET',
					kids    =>      $cgi,
				))
		) {
		for my $putter (find_kids(
					tag => 'putter', 
					kids => $out
				)) {
			printf "%s.d/%s.pl\n", $main, $putter->[0]->{name};
		}
	}
	#
	#  Write /cgi/POST/in/putter scripts.
	#
	if (my $in = find_kid(
		tag     =>      'in',
		kids    =>      find_kid(
					tag     =>      'POST',
					kids    =>      $cgi,
				))
		) {
		for my $putter (find_kids(
					tag => 'putter', 
					kids => $in
				)) {
			printf "%s.d/%s.pl\n", $main, $putter->[0]->{name};
		}
	}
}

my ($perl5_path, @CGI);

while (my $arg = shift @ARGV) {
	if ($arg eq '--help') {
		help();
		exit 0;
	}
	if ($arg eq '--perl5-path') {
		$perl5_path = 'yes';
	} elsif (substr($arg, 0, 2) eq '--') {
		die "unknown option: $arg";
	} else {
		die "can't read xml file: $arg" unless -r $arg;
		push @CGI, $arg;
	}
}

#
#  Create a single xml parser object for all *.cgi files.
#
my $parser = XML::Parser->new(
		Style => 'Tree'
	) or die "XML::Parser->new(Tree) failed: $!";
#
#  For each *.cgi, parse the xml file into a tree and
#  search for various details.
#
for my $cgi (@CGI) {
	#
	#  Parse the XML/cgi description file.
	#  Need to surround parsefile() with an eval(),
	#  in case xml file is not well formed.
	#
	my $tree = $parser->parsefile($cgi) or
				die "XML::Parser->parsefile($cgi) failed: $!";
	if ($perl5_path eq 'yes') {
		&perl5_path($tree->[1]);
	}
}
1;