package Osd;
require 5.000;
require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw(parse_osd parse_attributes output_osd test_output_osd dump_hash test_parse_attributes test_parse_osd test_all);

#!/usr/bin/perl5
# OSD.pl is a simple Perl parser for OSD files
#
# Graham TerMarsch, November 1997
##############################################################################

# Change history
#
# Murray Nesbitt March 12, 1998
# Performace changes:
#   - Moved stripping of carriage returns out of main sub.
#   - Changed 'strip leading whitespace' regex.
# Resulted in an order of magnitude improvement in speed.


my @ELEMSTACK;

###############################################################################
# parses an OSD file recursively, returning a hash.
#
# PARAMETERS: OSD stuff accepted by reference
# LOCAL VARS: hash
# RETURNS   : hash of element and it's sub-elements
###############################################################################
# KNOWN BUGS:
###############################################################################
# use 'push' to put a new element into it's hash-array; it'll simply add it to
# the end of the array.
sub parse_osd (\$)
{
    my ($STUFF) = @_;
    
    # Strip out all carriage returns so we don't have to worry about parsing them.
    $$STUFF =~ s/[\n\r]//g;
    return _parse_osd( $STUFF );
}

sub _parse_osd (\$)
{
    my ($STUFF) = @_;
    my %ELEM;
    my $DONE = 0;

    # while !done
    while (($DONE == 0) and (length($$STUFF) > 0))
    {
        # Strip off any leading whitespace
        $$STUFF =~ s/^\s+//;

        # if an end tag, pop off of stack and check if same.
        if ($$STUFF =~ /^<\/\s*(.*?)\s*>/)
        {
            my $ENDTAG = $1;
            my $STARTTAG = pop( @ELEMSTACK );
            $$STUFF = $';

            if ($STARTTAG ne $ENDTAG)
            {
                print "End tag $ENDTAG doesn't match $STARTTAG from stack.\n";
            }

            last;
        }
        # if a start tag, parse attrs, push onto stack, and recurse
        elsif ($$STUFF =~ /^<\s*(.*?)(?:\s+(.*?))?\s*(\/?)>/)
        {
            my $STARTTAG = $1;
            my $ATTRS = $2;
            my $FINISHED = $3;
            my %NEWELEM;
            $$STUFF = $';

            # If this is a container element, parse it and get back
            # a hash containing it's data and nested elements.
            if ($FINISHED eq '')
            {
                push( @ELEMSTACK, $STARTTAG );
                %NEWELEM = _parse_osd( $STUFF );
            }

            # Get the attributes for this element, be it either a
            # container or a singular element.
            if (defined $ATTRS && $ATTRS ne '')
            {
                my %ATTRHASH = parse_attributes( $ATTRS );
                $NEWELEM{ attr } = \%ATTRHASH;
            }

            # Now that we've got a complete new element, push it
            # onto our stack of elements with this name.
            push( @{ $ELEM{ elem }{ $STARTTAG } }, \%NEWELEM );
        }
        # else must be data, append to hash
        elsif ($$STUFF =~ /^(.*?)(?=<)/)
        {
            my $DATA = $1;
            $$STUFF = $';
# work around for warning in 5.003
            if(defined $ELEM{ data }) {
                $ELEM{ data } .= $DATA;
            }
            else {
                $ELEM{ data } = $DATA;
            }
        }
        # if a comment, parse and throw away
        elsif ($$STUFF =~ /^<!--(.*?)-->/)
        {
            $$STUFF = $';
        }
        else
        {
            print "Don't know how to handle $$STUFF\n";
            last;
        }
    # end while
    }

    return (%ELEM);
}


###############################################################################
# parses attributes for an element, returning a hash containing those elements
# If any errors occur, this function returns an empty hash.  Upon any notice of
# an error, this function kicks out and returns.
#
# PARAMETERS: string containing parameters to parse ($STUFF)
# LOCAL VARS: hash (%ATTRS)
# RETURNS   : returns hash of key=value pairs (%ATTRS)
###############################################################################
# KNOWN BUGS: If a value is given of "", it is caught with " as the value
###############################################################################
sub parse_attributes
{
    my ($STUFF) = @_;
    my %ATTRS;

    while (length($STUFF) > 0)
    {
        # Strip off any leading whitespace
        $STUFF =~ s/^\s*(.*?)$/$1/;

        # Parse attributes appropriately, catching the most common errors.
        if ($STUFF =~ /^(\S+?)="(.+?)"/)
        {
            $ATTRS{ $1 } = $2;
            $STUFF = $';
        }
        elsif ($STUFF =~ /^(\S+?)=(?!")/)
        {
            print "Attribute $1 missing a starting quote for it's value.\n";
            last;
        }
        elsif ($STUFF =~ /^(\S+?)="(.+)(?!")/)
        {
            print "Attribute $1=$2 missing an ending quote.\n";
            last;
        }
        elsif ($STUFF =~ /^(\S+?)="$/)
        {
            print "Attribute $1 given without a value.\n";
            last;
        }
        elsif ($STUFF =~ /^=/)
        {
            print "Attribute given without a name.\n";
            last;
        }
        elsif ($STUFF ne '')
        {
            print "Don't know how to handle '$STUFF'.\n";
            last;
        }
    }

    return (%ATTRS);
}

###############################################################################
# Output an OSD hash structure recursively.
#
# PARAMETERS: hash structure to output
###############################################################################
sub output_osd
{
    my (%ELEM, $MYNAME) = @_;
    my @ELEMS = keys( %{ $ELEM{elem} } );
    my @ATTRS = keys( %{ $ELEM{attr} } );
    my $NESTED;

    # Output the starting element tag with any attributes
    if ($MYNAME ne '')
    {
        my $ATTR;
        print "<$MYNAME";
        foreach $ATTR (@ATTRS)
        {
            print ' ' . $ATTR . '="' . $ELEM{attr}{$ATTR} . '"';
        }
        print ">\n";

        # Output any data for this element
        if ($ELEM{data} ne '')
        {
            print $ELEM{data} . "\n"; 
        }
    }

    # If we have nested elements, recurse on each one
    foreach $NESTED (@ELEMS)
    {
        my $DUH;
        for $DUH (0 .. $#{ $ELEM{elem}{$NESTED} })
        {
            output_osd( %{ $ELEM{elem}{$NESTED}[$DUH] }, $NESTED );
        }
    }

    # Output the closing element tag
    if ($MYNAME ne '') { print "</$MYNAME>\n"; }
}

1;

__END__

###############################################################################
# Test function for the output_osd() fcn.
###############################################################################
sub test_output_osd
{
    my %ELEM;

    $ELEM{ elem }{ 'SOFTPKG' }[ 0 ]{ attr }{ 'NAME' } = 'com.foobar.www.Solitaire';
    $ELEM{ elem }{ 'SOFTPKG' }[ 0 ]{ attr }{ 'VERSION' } = '1,0,0,0';
    $ELEM{ elem }{ 'SOFTPKG' }[ 0 ]{ data } = 'Some data for SOFTPKG.';
    $ELEM{ elem }{ 'SOFTPKG' }[ 0 ]{ elem }{ 'TITLE' }[ 0 ]{ data } = 'Solitaire';

    output_osd( %ELEM );
}

###############################################################################
# Driver test fcn to dump all elements of a hash
sub dump_hash
{
    my (%HASH) = @_;
    my $KEY;
    foreach $KEY (keys %HASH)
    {
        print "$KEY -> $HASH{$KEY}\n";
    }
}

###############################################################################
# Driver to test  the parse_attributes() fcn.
###############################################################################
sub test_parse_attributes
{
    print "Two attributes: NAME, VERSION\n";
    dump_hash(
        parse_attributes( 'NAME="com.foobar.www.Solitaire" VERSION="1,0,0,0"' )
        );

    print "\nOne attribute: VALUE\n";
    dump_hash(
        parse_attributes( 'VALUE="WinNT"' )
        );

    print "\nSecond ttribute with missing start quote.\n";
    dump_hash(
        parse_attributes( 'NAME="com.foobar.www.Solitaire" VALUE=choke"' )
        );

    print "\nFirst Attribute with missing end quote.\n";
    dump_hash(
        parse_attributes( 'VALUE="chokeagain NAME="com.foobar.www.Solitaire"' )
        );

    print "\nSecond attribute without name.\n";
    dump_hash(
        parse_attributes( 'NAME="foo" ="barf"' )
        );

    print "\nFirst attribute without name.\n";
    dump_hash(
        parse_attributes( '=barf" NAME="foo"' )
        );

    print "\nAttribute without name.\n";
    dump_hash(
        parse_attributes( '="barf' )
        );

    print "\nAttribute without a value.\n";
    dump_hash(
        parse_attributes( 'BARF=""' )
        );

    print "\nAttribute with missing end quote / without a value.\n";
    dump_hash(
        parse_attributes( 'BARF="' )
        );

    print "\nEmpty string given, should return empty.\n";
    dump_hash(
        parse_attributes( '  ' )
        );
}

###############################################################################
# Test function for the parse_osd() fcn.
###############################################################################
sub test_parse_osd
{
    my $CONTENTS = join( '', <> );
    my %DOC = parse_osd( $CONTENTS );
}

###############################################################################
# Test parse -> output.
###############################################################################
sub test_all
{
    my $CONTENTS = join( '', <> );
    my %DOC = parse_osd( $CONTENTS );
    output_osd( %DOC );
}

###############################################################################
# Test driver.
###############################################################################
#test_parse_attributes();
#test_parse_osd();
#test_output_osd();
test_all();

__END__

###############################################################################
# Documentation
###############################################################################

=head1 NAME

OSD - Simple parser for OSD files in XML format

=head1 SYNOPSIS

use OSD;

=head1 DESCRIPTION

Note that this file does B<not> yet contain all of the functionality defined
in this documentation.

This perl library uses perl5 objects to make it easy to read in, validate, and
output OSD files.  This package defines an OSD object and some utility functions
to allow for the use of the object to describe the software package that the OSD
object refers to and any other software it may be dependant upon.

As the OSD file is read in and parsed, information contained is stored in a
recursive hash structure that allows for access to the data, attributes, and
nested elements of any given element.  Access to the structure is as follows:

=head2 Data found for an element

$element{ data }

Data found for an element is simply appended to this scalar value.

=head2 Attributes for the element

$element{ attr }{ NAME }

Attributes found for a given element are stored in a hash of NAME->VALUE pairs.

=head2 Nested elements

$element{ elem }[ offset ]

Nested elements are stored in a hash/array of identical structure to $element.
The array offset is used to account for elements at this level of nesting
that have the same name (e.g. a package may be applicable to several OS
platforms in a single distribution format, and many OS tags would be found
at the same level of nesting).

Each nested 'elem' found within the given element is held in the same
structure of [ offset ]{ data/elem/attr }.  So yes, it can get ugly if
you're trying to access nested elements.  For example:

$element{foo}[0]{elem}{bar}[0]{attr}{'NAME'} = 'bleargh';

would set the NAME attribute of the first 'bar' element nested within the
first 'foo' element to 'bleargh'.  Eeek! Don't fret though, the structure is 
entirely recursive and if dealt with in such a manner should not be any trouble
to work with.

=head1 EXAMPLES

=head1 DIAGNOSTICS

=head1 FILES

=head1 REQUIREMENTS

=head1 NOTES

=head2 Storage of multiple elements with the same name

Any elements that are parsed at the same nesting level are stored in the {elem}
array in the order in which they are parsed.

=head2 Singular elements output as containers

All singular elements found within the OSD file are output as container
elements in the output.  This means that any elements found such as:

<IMPLTYPE VALUE="Perl" />

are output as

<IMPLTYPE VALUE="Perl"></IMPLTYPE>

From what I recall of the specification this shouldn't be a problem but I will
need to verify this against a more recent version of the XML spec.

=head1 RESTRICTIONS

=head2 No support for Unicode

Being that Perl doesn't yet properly support Unicode internally, this library
does not have any support for Unicode.  As such, this module can B<only>
process OSD files that are given in standard ASCII text format.

=head2 Output of data for elements isn't the same as was input

All data for an element is appended to the {data} scalar when parsed.  This
does result in any output of an OSD to have all of the data out of order in
relation to the other elements that were stored within the OSD file.

=head2 Output of OSD object is not the same as the input

As this OSD parser uses hashes to store information on the elements parsed
from the OSD object, there is B<no> guarantee that the output from the data
parsed will be in the same order that it was read in.  Nesting levels are
preserved but order is not.  For some elements that require that they follow
or be followed by a particular element, this will cause problems.

=head2 Comments are thrown away when parsed

All comments parsed by this object are simply thrown away and are not output
when the OSD object is output again.

=head1 KNOWN BUGS

=head2 Empty attribute values

parse_attributes() doesn't properly handle empty attribute values.  Currently,
parse_attributes() reads in any attributes with a value of "" and deems the
second quote to be the actual value of the attribute.

=head2 No support for multiple attribute list declarations

Currently, this module has no support for multiple attribute list declarations.
As of this moment, multiple declarations are read in as nested elements whose
name happens to be 'attribute'.


=head1 AUTHOR

Graham TerMarsch <graham@dotcom.bc.ca>

=head1 HISTORY

November 23, 1997; Initial version, got parse_attributes() finished except
for a few small bugs relating to parsing of attributes with empty values.
Also finished first whack at the parse_osd() and output_osd() functions
and have provided test drivers within this file.

=cut

1;
