# 
# # Copyright (c) 1999 David Schooley.  All rights reserved.  This program is 
# free software; you can redistribute it and/or modify it under the same 
# terms as Perl itself.

# Data structures based on Chris Nandor's modifications to the original aeteconvert.

=head1 NAME

Mac::AETE::Parser - parses Macintosh AETE and AEUT resources.


=head1 SYNOPSIS

     use Mac::AETE::Parser;
     use Mac::AETE::Format::Dictionary;

     $aete = Parser->new($aete_handle, $name);
     $formatter = Dictionary->new;
     $aete->set_format($formatter);
     $aete->read;
     $aete->write;


=head1 DESCRIPTION

The Parser module serves as a base class for the Mac::AETE::App and Mac::AETE::Dialect modules.

=head2 Methods

=over 10

=item new

Example: ($aete_handle is a handle containing a valid AETE resource. $name is the name of the application.)

     use Mac::AETE::Parser;
     use Mac::AETE::Format::Dictionary;

     $aete = Parser->new($aete_handle, $name);

=item read

Reads the data contained in the AETE resource or handle. Example:
     
     $aete->read;
     
     
=item set_format

Sets the output formatter used during by the 'write' subroutine. Example:

     $formatter = Dictionary->new;
     $aete->set_format($formatter);
     

=item copy

Copies all suites from one Parser object into another. Example:
     
     $aete2 = Parser->new($aete_handle2, $another_name);
     $aete->copy($aete2);
     
copies the suites from $aete2 into $aete.

=item merge

Merges suites from one Parser object into another. Only the suites that exist in
both objects will be replaced. Example:

     $aete3 = Parser->new($aete_handle2, $another_name);
     $aete->merge($aete3);

=item write

Prints the contents of the AETE or AEUT resource using the current formatter.

     $aete->write;

=back

=head1 INHERITANCE

Parser does not inherit from any other modules.

=head1 AUTHOR

David Schooley <F<dcschooley@mediaone.net>>

The data structures are adapted from modifications made to the original 
aeteconvert script by Chris Nandor.

=cut

package Mac::AETE::Parser;

use Data::Dumper;
use strict;
use Mac::Memory;
use Carp;

sub new {
    my ($class, $handle, $target, $data) = @_;
    my $self = {};
    bless $self, $class;
    
    croak("Invalid Resource") if !defined $handle || !$handle;
    
    if (ref($handle) eq 'ARRAY') {
        $self->{_handles} = $handle;
    } else {
        $self->{_handles} = [$handle];
    }
    $self->{_target}     = $target;
    $self->{_suite_list} = ();
    $self->{ID}          = $data->{ID};
    $self->{BUNDLE_ID}   = $data->{BUNDLE_ID};
    $self->{APPNAME}     = $data->{APPNAME};
    $self->{VERSION}     = $data->{VERSION};

    return $self;
}

sub set_format
{
    my ($self, $format) = @_;

    $format->{_parser}  = $self;
    $self->{_formatter} = $format;
}


# Copy suites from aete
sub copy
{
    my ($self, $aete) = @_;
    my ($suite_src, $suite_dest);
    
        
    foreach $suite_src (@{$aete->{_suite_list}}) {
        push @{$self->{_suite_list}}, $suite_src;
    }
}

# Replace existing suites with suites from aete2
sub merge
{
    my ($self, $aete) = @_;
    my ($suite_src, $suite_dest);
            
    foreach $suite_src (@{$aete->{_suite_list}}) {
        foreach $suite_dest (@{$self->{_suite_list}}) {
            if ($suite_dest->{_SIZE} == 0 && $suite_src->{_ID} eq $suite_dest->{_ID}) {
                %$suite_dest = %$suite_src;
            }
        }
    }
}


sub write {
    my $self = shift;

    croak("You have to assign a formatter before writing!")
        if !defined $self->{_formatter};

    my $form = $self->{_formatter};
    
    $form->write_intro if $form->can('write_intro');
    $form->write_title($self->{_target}) if $form->can('write_title');
    $form->write_version($self->{_version}) if $form->can('write_version');

    foreach my $suite (@{$self->{_suite_list}}) {
        $form->start_suite(@$suite{qw[_NAME _DESC _ID]})
            if $form->can('start_suite');
        
        foreach my $event (@{$suite->{_event_list}}) {
            my $reply = $event->{_REPLY};
            my $dobj = $event->{_DOBJ};

            $form->start_event(@{$event}{qw[_NAME _DESC _CLASS _ID]})
                     if $form->can('start_event');

            $form->write_reply(@{$reply}{qw[_TYPE _DESC _REQ _LIST _ENUM]})
                    if $form->can('write_reply');

            $form->write_dobj(@{$dobj}{qw[_TYPE _DESC _REQ _LIST _ENUM _CHANGE]})
                    if $form->can('write_dobj');

            foreach my $param (@{$event->{_param_list}}) {
                $form->write_param(
                    @{$param}{qw[_NAME _ID _TYPE _DESC _REQ _LIST _ENUM]}
                ) if $form->can('write_param');
            }
            $form->end_event if $form->can('end_event');
        }
        foreach my $class (@{$suite->{_class_list}}) {
            $form->begin_class(@{$class}{qw[_NAME _ID _DESC]})
                if $form->can('begin_class');
            $form->begin_properties if $form->can('begin_properties');
            foreach my $prop (@{$class->{_property_list}}) {
                $form->write_property(
                    @{$prop}{qw[_NAME _ID _CLASS _DESC _LIST _ENUM _RDWR]}
                ) if $form->can('write_property');
            }
            $form->end_properties if $form->can('end_properties');
            foreach my $element (@{$class->{_element_list}}) {
                $form->write_element($element->{_CLASS}, @{$element->{_ID}})
                    if $form->can('write_element');
            }
            $form->end_class if $form->can('end_class');
        }
        foreach my $comp (@{$suite->{_comparison_list}}) {
            $form->write_comparison(@{$comp}{qw[_NAME _ID _DESC]})
                if $form->can('write_comparison');
        }

        foreach my $enumeration (@{$suite->{_enumeration_list}}) {
            $form->begin_enumeration($enumeration->{_ID})
                if $form->can('begin_enumeration');
            foreach my $enum (@{$enumeration->{_enum_list}}) {
                $form->write_enum(@{$enum}{qw[_NAME _ID _COMMENT]})
                    if $form->can('write_enum');
            }
            $form->end_enumeration if $form->can('end_enumeration');
        }
        $form->end_suite if $form->can('end_suite');
    }
    $form->write_finale if $form->can('write_finale');
}

sub read {
    my $self = shift;

    for my $handle (@{$self->{_handles}}) {

        $self->{_handle} = $handle;
        $self->{_handle_index} = 0;

        my $header_data = $self->_scan(8);
        my($version, $subVersion, $language, $script, $suiteCount)
            = unpack("C C S S S", $header_data);
    
        $self->{_version}     = "$version.$subVersion"
            unless exists $self->{_version};
        $self->{_language}    = $language unless exists $self->{_language};
        $self->{_script}      = $script unless exists $self->{_script};
        $self->{_suite_count} += $suiteCount;

        for (my $i = 1; $i <= $suiteCount; $i++) {
            my($flags, %suite);
            my($suite_name, $suite_description) = $self->_get_paired_string;

            # Get the rest of the suite information
            my $suiteInfo = $self->_scan(8);
            my($suiteID, $suiteVersion, $suiteMinor) = unpack("A4 S S", $suiteInfo);

            @suite{qw[_NAME _DESC _ID _VERSION _SIZE
                _event_list _class_list _comparison_list _enum_list]} = (
                $suite_name, $suite_description, $suiteID,
                "$suiteVersion.$suiteMinor", 0
            );

            # Get the events
            my $event_count = unpack("S", $self->_scan(2));
            for (my $i = 1; $i <= $event_count; $i++) {
                my(%event, %reply, %dobj);

                $event{_param_list} = ();
                my($event_name, $event_description) = $self->_get_paired_string;

                # Get the rest of the event info
                @event{qw[_NAME _DESC _CLASS _ID]} = (
                    $event_name, $event_description, $self->_get_ID,
                    $self->_get_ID
                );
                @reply{qw[_TYPE _DESC]} = (
                    $self->_get_ID, $self->_get_string
                );

                $flags = $self->_get_binary;
                @reply{qw[_REQ _LIST _ENUM]} = (
                    ($flags & 0x8000 ? 0 : 1),
                    ($flags & 0x4000 ? 1 : 0),
                    ($flags & 0x2000 ? 1 : 0)
                );

                $event{_REPLY} = \%reply;

                # Direct object data
                @dobj{qw[_TYPE _DESC]} = (
                    $self->_get_ID, $self->_get_string
                );

                $flags = $self->_get_binary;
                @dobj{qw[_REQ _LIST _ENUM _CHANGE]} = (
                    ($flags & 0x8000 ? 0 : 1),
                    ($flags & 0x4000 ? 1 : 0),
                    ($flags & 0x2000 ? 1 : 0),
                    ($flags & 0x1000 ? 1 : 0)
                );

                $event{_DOBJ} = \%dobj;

                # Other parameter data
                my $other_count = $self->_get_item_count;
                for (my $i = 1; $i <= $other_count; $i++) {
                    my %param;

                    @param{qw[_NAME _ID _TYPE _DESC]} = (
                        $self->_get_string, $self->_get_ID,
                        $self->_get_ID, $self->_get_string
                    );

                    $flags = $self->_get_binary;
                    @param{qw[_REQ _LIST _ENUM]} = (
                        ($flags & 0x8000 ? 0 : 1),
                        ($flags & 0x4000 ? 1 : 0),
                        ($flags & 0x2000 ? 1 : 0)
                    );

                    push @{$event{_param_list}}, \%param;
                }

                push @{$suite{_event_list}}, \%event;
            }

            # Get the classes and properties
            my $class_count = $self->_get_item_count;
            for (my $i = 1; $i <= $class_count; $i++) {
                my %class;

                @class{qw[_NAME _ID _DESC
                    _property_list _element_list]} = (
                    $self->_get_string, $self->_get_ID,
                    $self->_get_string
                );

                # properties
                my $property_count = $self->_get_item_count;
                for (my $i = 1; $i <= $property_count; $i++) {
                    my %property;

                    @property{qw[_NAME _ID _CLASS _DESC]} = (
                        $self->_get_string, $self->_get_ID,
                        $self->_get_ID, $self->_get_string
                    );

                    $flags = $self->_get_binary;
                    @property{qw[_LIST _ENUM _RDWR]} = (
                        ($flags & 0x4000 ? 1 : 0),
                        ($flags & 0x2000 ? 1 : 0),
                        ($flags & 0x1000 ? 1 : 0)
                    );

                    push @{$class{_property_list}}, \%property;
                }
                
                # elements
                my $element_count = $self->_get_item_count;
                for (my $i = 1; $i <= $element_count; $i++) {
                    my(%element, @kforms);

                    $element{_CLASS} = $self->_get_ID;
                    my $kform_count = $self->_get_item_count;
                    for (my $i = 1; $i <= $kform_count; $i++) {
                        push @kforms, $self->_get_ID;
                    }
                    $element{_ID} = \@kforms;

                    push @{$class{_element_list}}, \%element;
                }

                push @{$suite{_class_list}}, \%class;
            }
        
            #comparisons
            my $compare_count = $self->_get_item_count;
            for (my $i = 1; $i <= $compare_count; $i++) {
                my %comparison;

                @comparison{qw[_NAME _ID _DESC]} = (
                    $self->_get_string, $self->_get_ID,
                    $self->_get_string
                );

                push @{$suite{_comparison_list}}, \%comparison;
            }

            #enumerations
            my $enum_count = $self->_get_item_count;
            for (my $i = 1; $i <= $enum_count; $i++) {
                my %enumeration;

                $enumeration{_ID} = $self->_get_ID;
                $enumeration{_enum_list} = ();
                my $eenum_count = $self->_get_item_count;
                for (my $i = 1; $i <= $eenum_count; $i++) {
                    my %enum;

                    @enum{qw[_NAME _ID _COMMENT]} = (
                        $self->_get_string, $self->_get_ID, 
                        $self->_get_string
                    );

                    push @{$enumeration{_enum_list}}, \%enum;
                }

                push @{$suite{_enumeration_list}}, \%enumeration;
            }

            $suite{_SIZE} += $event_count + $class_count +
                $compare_count + $enum_count;
            push @{$self->{_suite_list}}, \%suite;
        }
    }
}


#
#############################################################################
#                         Private Subroutines                               #                         
#############################################################################

sub _get_binary() {
    my $self = shift;
    my $binary = $self->_scan(2);
    $binary = hex(unpack('H4', $binary));
}

sub _get_ID() {
    my $self = shift;
    my $myID = pack 'N', unpack 'L', $self->_scan(4);
    $myID;
}

sub _get_item_count() {
    my $self = shift;
    my $count = $self->_scan(2);
    $count = unpack("S", $count);
}


sub _get_string() {
    my $self = shift;
    my $length;
    $length = $self->_scan(1);
    $length = unpack("C", $length);
    my $string = $self->_scan($length);
    # Take care of alignment
    if ($self->{_handle_index} % 2 == 1) { 
        $self->{_handle_index} += 1;
    }
    $string;
}

sub _get_paired_string() {
    my $self = shift;
    my $length;
    $length = $self->_scan(1);
    $length = unpack("C", $length);
    my $string1 = $self->_scan($length);
    $length = $self->_scan(1);
    $length = unpack("C", $length);
    my $string2 = $self->_scan($length);
    # Take care of alignment
    if ($self->{_handle_index} % 2 == 1) { 
        $self->{_handle_index} += 1;
    }
    ($string1, $string2);
}

sub _scan {
    my($self, $byte_count) = @_;
    my $handle = $self->{_handle};
    my $result = $handle->get($self->{_handle_index}, $byte_count);
    $self->{_handle_index} += $byte_count;
    $result;
}

1;

__END__