
########################################################################
# SGMLSPL script for recursively skel-ing
#
# Written by: W. F. Hammond 29-Aug-1999
# Based on "skel.pl" in David Megginson's distribution.
########################################################################
#
# Usage:  sgmlspl  <  instance-ESIS  $thisname  doc-type  [ prev-skel ]
#
# where  prev-skel  is a previous skel for the same  doc-type
# (which is verified for sanity).
#

use SGMLS;			# Use the SGMLS package.
use SGMLS::Output;		# Use stack-based output.

$scriptname = $ARGV;
$appname = "";  # the name of the SGML application = doc-type arg
$doctype = "";
$prevtype = "";
$prevskel = "";
$intro=0;                       # Has do_intro() been run?
%subdocs = ();			# Subdocument entities seen so far.
%entities = ();			# External data entities seen so far.
%sdata = ();			# SDATA strings seen so far.
%elements = ();			# Elements seen so far.
$pi = 0;			# Any processing instructions?
@prevs = ();                    # Array of names in prev-skel

$| = 1;                         # autoflush

$warns = 0;          # CV: cumulative number of warnings issued
$pskl = 0;           # CV: current line number in prev-skel handle PSKEL
$slct = 0;           # CV: number of "sgml('" lines in prev-skel

# Command line processing
# 1. Set $appname for comparison later with $doctype and $prevtype
# 2. If $prevskel, trying bringing it in with use before anything
#    else so that definitions here supersede those in $prevskel

$pname = $0;
$pname =~ s/^.*\///;
$usage = "Usage:  " . $pname . " < nsgmls-ESIS  " . $scriptname
        . "  doc-type  [prev-skel]\n";
$argc = scalar(@ARGV);
if (!( ($argc == 1) || ($argc == 2) ) ){
    print STDERR $usage;
    exit(1);
};
$appname = $ARGV[0];
if($argc == 2){
    $prevskel = $ARGV[1];
};

## $gos = "Dbg: ";
## $gos = $gos . $scriptname . "  args: doc-type = " . $appname;

if($prevskel ne ""){
##    $gos = $gos . " ,  prev-skel = " . $prevskel;
    if(!open(PSKEL, $prevskel)){
	print STDERR $scriptname, ": Cannot open  ", $prevskel ,
                   "  for reading.\n";
	exit(2);
    };
}

## $gos = $gos . "\n";
## print STDERR $gos;
## # Debugging exit
## exit(0);

## For keeping Perl names straight
## $gos = "";
## $gos = $gos . "\$_[0] (nil?): " . $_[0] . "\n";
## $gos = $gos . "Pname (\$0) (= sgmlspl?): " . $pname . "\n";
## $gos = $gos . "\$ARGV (= this script?): " . $ARGV . "\n";
## $gos = $gos . "\$_ (\$ARG) (nil?): " . $_ . "\n";
## $gos = $gos . "No. of args -- scalar(\@ARGV): " . $argc . "\n";
## $gos = $gos . "ARGV[0]: " . $ARGV[0] . "\n";
## $gos = $gos . "ARGV[1]: " . $ARGV[1] . "\n";
## $gos = $gos . "ARGV[2]: " . $ARGV[2] . "\n";
## output($gos);

# If there is a previous version go through it, incorporating whatever
# is found and stuffing names in the tables so that skeletons for
# previous names are not re-written.
if($prevskel ne ""){
    # Note: we previously exited if $prevskel could not be opened.
    $tss = "";
    $uss = "";
    $pss = "";
    @arr = ();
    $pskl = 0;
    while($tss = <PSKEL>){
	if($pskl > 0){
	    print $pss;
	}; #  This blocks premature printing of the last line
           #  in prev-skel, which should be simply "1;"
	$pskl++;
	if($prevtype eq ""){
	    if($tss =~ /^ *\# *Document *Type:/){
		my $tdt = $tss;
##		print STDERR "Dbg: Document Type line:\n", $tdt;
		$tdt =~ s/^ *\# *Document *Type: *//;
##		print STDERR "Stripping off: ", $tdt;
		$prevtype = $tdt;
		$prevtype =~ s/\s.*$//;
                chomp $prevtype;
##		print STDERR "Value: ", $prevtype, "\n";
	    };
	};
	$uss = $tss;
	if($uss =~ /^ *sgml\(\'/){
##	    print STDERR $uss;
	    @arr = split(/\'/, $uss);
	    $prevs[$slct] = $arr[1];
	    $slct++;
	};
	$pss = $tss;
    };
    chomp $pss;
    if($pss !~ /^ *1; *$/){
	$warns++;
	print STDERR $scriptname , 
              ": WARNING -- last line in previous list not '1;'-- instead:\n";
	print STDERR "'", $pss, "'\n";
    };
    if($prevtype eq ""){
	$warns++;
	print STDERR $scriptname,
              ": WARNING -- No Document Type (comment) found.\n";
    }
    else{
	if($prevtype ne $appname){
	    $warns++;
	    print STDERR $scriptname, ": WARNING -- Previous type, ",
                  $prevtype , ", does not match type on command line: ",
                  $appname , "\n";
	};
    };

# Now take steps to prevent skeletons for previous code. 
    $vss = "";
    # print STDERR "Found ", $slct , " sgml('.*') lines.\n";
    foreach $vss (@prevs){
	$wss = $vss;
	# print STDERR $wss, "\n";
	if($wss =~ /^<\/[0-9A-Za-z]+>$/){
	    # print STDERR "-- end_element\n";
	    ; # end_element ignored
	}
	elsif($wss =~ /^<[0-9A-Za-z]+>$/){
	    # print STDERR "-- start_element\n";
	    $wss =~ s/^<//;
	    $wss =~ s/>$//;
	    # print STDERR "Dbg: found in prev -- ", $wss, "\n";
	    $elements{$wss} = 2;
	}
	elsif($wss =~ /^{[0-9A-Za-z]+}$/){
	    # print STDERR "-- start_subdoc\n";
	    $wss =~ s/^{//;
	    $wss =~ s/}$//;
	    $subdocs{$wss} = 2;
	}
	elsif($wss =~ /^&[0-9A-Za-z]+;$/){
	    # print STDERR "-- entity\n";
	    $wss =~ s/^&//;
	    $wss =~ s/;$//;
	    $entities{$wss} = 2;
	}    # next   /^\|[0-9A-Za-z]*\|$/
	elsif($wss =~ /^\|[^|]+\|$/){
	    # print STDERR "-- sdata\n";
	    $wss =~ s/^\|//;
	    $wss =~ s/\|$//;
	    print STDERR "Dbg: found in prev-skel -- ", $wss, "\n";
	    $sdata{$wss} = 2;
	}
	elsif($wss =~ /pi/){
	    # print STDERR "-- pi\n";
	    $pi = 2;
	}
	else{
	    # print STDERR "-- Not on the list.\n";
	};
	# print STDERR "  Loop control: ", $vss, " -- morphed to: ", $wss, "\n";
    };
};

# print STDERR "Dbg: Prior to 'start' listing of sdata hash:\n";
hprint("STDERR", \%sdata);

# Input processing functions

sgml('start', '');
sgml('end_element', '');	# Ignore the ends of elements.
sgml('end_subdoc', '');		# Ignore the ends of subdocument entities.
sgml('cdata', '');		# Ignore CDATA.
sgml('re', '');			# Ignore Record Ends.
sgml('conforming','');

# Note any processing instructions.
sgml('pi', sub{
    if(!($pi > 0)){
	$pi = 1;
    };
});

# Array building for subdocs, external data entities, and sdata

# Keep track of all subdocument entities.
sgml('start_subdoc', sub {
    my $subdoc = shift;
    if(!($subdocs{$subdoc->name} == 2)){
	$subdocs{$subdoc->name} = 1;
    };
});

# Keep track of all external data entities.
sgml('entity', sub {
    my $entity = shift;
    if(!($entities{entity->name} == 2)){
	$entities{$entity->name} = 1;
    };
});

# Keep track of all SDATA strings
sgml('sdata', sub {
    my $tsdata = shift;
    if(!($sdata{$tsdata} == 2)){
	$sdata{$tsdata} = 1;
    };
});

# Display element handlers as they appear.
sgml('start_element', sub {
    my $element = shift;
    # Special handling for the first (root) element
    unless ($intro) {
	$intro = 1;
	$doctype = $element->name;
	if($doctype ne $appname){
	    print STDERR $scriptname, " -- WARNING: Document type, ",
                  $doctype, ", does not match first argument: ",
                  $appname, "\n";
	    $warns++;
	};
	do_intro($doctype);  # passing name of root element
                             # first output occurs in this call to
                             # generate DocType id
    }
    if (!($elements{$element->name} > 0)) {
	# print STDERR "Found: element -- ", $element->name, "\n";
	output "# Element: " . $element->name . "\n";
	output "sgml('<" . $element->name . ">', \"\");\n";
	output "sgml('</" . $element->name . ">', \"\");\n\n";
	$elements{$element->name} = 1;
    }
});

sgml('end', sub {
				# generate subdoc handlers
    my @keys = keys(%subdocs);
    if ($#keys > 0) {
	output "#\n# Subdocument Entity Handlers\n#\n\n";
        foreach (@keys) {
	    output "# Subdocument Entity: $_\n";
	    output "sgml('{" . $_ . "}', \"\");\n";
	    output "sgml('{/" . $_ . "}', \"\");\n\n";
	}
    }
				# generate entity handlers
    my @keys = keys(%entities);
    if ($#keys > 0) {
	output "#\n# External Data Entity Handlers\n#\n\n";
        foreach (@keys) {
	    output "sgml('&" . $_ . ";', \"\");\n";
	}
    }

#    print STDERR "Dbg: 'end' listing of sdata hash:\n";
    hprint("STDERR", \%sdata);

# generate sdata handlers
    my @keys = keys(%sdata);
    if ($#keys > 0) {
	if($prevskel eq ""){
	    output "#\n# SDATA Handlers\n#\n\n";
	};
        # foreach (@keys) {
	#    output "sgml('|" . $_ . "|', \"\");\n";
	# }
	foreach $kk (@keys){
	    if($sdata{$kk} == 1){
		my $os = "sgml('|" . $kk . "|', \"\");\n";
		output($os);
	    };
	};
    }

    if ($pi == 1) {
	output "#\n# Processing-Instruction Handler\n#\n";
	output "sgml('pi', sub {});\n\n";
    }

    if($prevskel eq ""){
	output <<END;
#
# Default handlers (uncomment these if needed).  Right now, these are set
# up to gag on any unrecognised elements, sdata, processing-instructions,
# or entities.
#
# sgml('start_element',sub { die "Unknown element: " . \$_[0]->name; });
# sgml('end_element','');
# sgml('cdata',sub { output \$_[0]; });
# sgml('sdata',sub { die "Unknown SDATA: " . \$_[0]; });
# sgml('re',"\\n");
# sgml('pi',sub { die "Unknown processing instruction: " . \$_[0]; });
# sgml('entity',sub { die "Unknown external entity: " . \$_[0]->name; });
# sgml('start_subdoc',sub { die "Unknown subdoc entity: " . \$_[0]->name; });
# sgml('end_subdoc','');
# sgml('conforming','');

END
};

# Finish Up
    output("1;\n");
    if($warns > 0){
	$gos = "";
	$gos = $ARGV . ": WARNING -- Number of previous warnings: " 
               . $warns . "\n";
	print STDERR $gos;
	0;
    }
    else{
	1;
    };
});

# Function run in first (root) element processing

sub do_intro {
# Grab the name of the root element
    my $doctype = shift;
    my $os = "";
    if($prevskel ne ""){
	$os = '# End of previous list "' . $prevskel . '"' . "\n";
	$os = $os . "# Skeleton function additions:\n";
    }
    else{
	$os = "# SGMLSPL script\n";
	$os = $os . "use SGMLS;\n";
	$os = $os . "use SGMLS::Output\n\n";
    };
    $os = $os . "# Document Type: " . $doctype . "\n\n";
    output($os);
}

# hprint: to print a hash
# Example usage:  hprint("STDERR", \%sdata);
sub hprint{
    my($handle, $hash) = @_;
    # $hash is a passed reference to a hash
    #   Example: print $hash  -->  HASH(0xcba5c)
    ## print STDERR "hprint: List of passed hash ", $hash, " follows:\n";
    my %th = %$hash;  # this gives "normal" access to the passed hash
    # get keys with: keys(%$hash)  --  extract one with: $$hash{$mykey}
    my @keys = keys(%th);
    ## print $handle "\$#keys for this hash: ", $#keys, "\n";
    if($#keys >= 0){
	foreach $jj (@keys){
	    print $handle "  ", $jj, " = ", $th{$jj}, "\n";
	};
    };
}

1;
