# ---------------------------------------------------------
# Lizenz: d-fsl                                            
# (c) Martin Raspe, Bibliotheca Hertziana, 2004-2006       
# ---------------------------------------------------------
# additional convenience subs for XML::SAX::Base
# and enhancememts for other packages

# --------------------
package XML::SAX::Base;
# --------------------
use strict;

=head1 NAME

SAXPlus - Extension module for XML::SAX::Base

=head1 SYNOPSIS

  use XML::SAX::Base;
  use SAXPlus;

=head1 DESCRIPTION

This module extends XML::SAX::Base by adding several methods. It can be 
combined with other extensions for XML::SAX::Base as long as methods are
not duplicated. Just load it by means of "use" or "require".

This module was created as part of ZUCCARO (= ZOPE-based universally 
configurable classes for academic research online). ZUCCARO is a database
framework for the humanities, especially for Art History. It is developed
at the Bibliotheca Hertziana (Max-Planck-Insitute of Art History) in Rome.

Basically ZUCCARO consists of a set of configurable classes which 
will eventually be represented in XML format. The user interface is being
created in the wab application server ZOPE, using the content management
framework (CMF) Plone. The classes are defined in an UML model, created by
means of a grephical UML tool (Poseidon etc.), from which the code stubs
are generated automatically.

A set of perl modules like this serves to create or transform various input 
date which come from other sources.

=head1 METHODS

Arguments are passed as hash items of the XML::SAX::Base object 
itself (normally the options are passed as key-value pairs to the 
constructor "new" or to the "parse" method).

=over 4

=item startHandler

Hash keys:

* root 

  root element for xml tree (default is <root>)

* encoding_to

  encoding for the xml file (default is 'UTF-8')

* byline

  adds a comment to the xml ['(c) 2004 Martin Raspe, Bibliotheca Hertziana'];

* optionline

  can be used to add a comment with current option settings
  
=item endHandler

Inserts closing root tag

=item startTag($name, @atts)

=item endTag($name)

=item fullTag($name, $data, @atts)

=item text($data)

=item writeHash($hashref, [$elementname])

Takes a hash reference and puts out XML, using keys as elements, inserting values.
If the value is a hash reference, writeHash ist called recursively.
If the value is an array reference, writeArray ist called.
If the element is defined as an attribute, it is inserted as in attribute of the enclosing element (see C<asAtts> method)

=item writeArray($arrayref, [$elementname])

Takes an array reference and puts out XML, optionally using $elementname as enclosing element name.
Each array member is put in an 'item' tag. 'item' can be redefined by setting the {item} value in the XML::Writer instance.
If $elementname is defined as an attribute, it is inserted into the attributes of the enclosing element (see C<asAtts> method)

=item setAtts(@names)

Defines @names to be inserted as attributes into the enclosing element
(instead of rendering them as elements).

=item delAtts()

Removes all Attribute definitions

=item setIdElements($element, $names)

Instead of inserting elements corresponding @$names, inserts $element with the attribute id=$name.
'id' can be redefined by setting the {id} value in the XML::Writer instance.

=item delIdElements()

Removes all IdElement definitions

=back

=head1 PREREQUISITES

L<XML::SAX::BASE>

=head1 AUTHOR

Martin Raspe (raspe@biblhertz.it)

=head1 SEE ALSO

L<XML::SAX::BASE>

=cut
# --------------------
sub startHandler {
# --------------------
my $self = shift;
	$self->{root} ||= 'root'; # need a root tag for XML
	$self->{encoding_to} ||= 'UTF-8';
	$self->{byline} ||= '(c) 2005-2010 Martin Raspe, Bibliotheca Hertziana, Rome, Italy';
	$self->start_document();
	# print "in XML::SAX::BASE::startHandler\n";
	$self->xml_decl( {
		Version		=> '1.0',
		Encoding	=> $self->{encoding_to},
		Standalone	=> 1,
		} );
	$self->comment( { Data => $self->{byline} } );
	$self->comment( { Data => $self->{optionline} } );
	$self->startTag($self->{root}, @_,
		version => sprintf("%s (%s)", $self->{VERSION}, $self->{VERSIONDATE}),
		uldfile => $self->{uld_file},
		ulddate => $self->{ULDDATE},
		xmlfile => $self->{xml_file},
		xmldate => $self->{XMLDATE},
		);
	$self->metaData() if $self->can('metaData');
	}

# --------------------
sub endHandler {
# --------------------
my ($self) = @_;
	$self->endTag($self->{root});
	return $self->end_document();
	}

# --------------------
sub startTag {
# --------------------
my ($self, $name, @atts) = (@_);
	return $self->start_element( {
		Name => $name, 
		Attributes => {@atts},
		});
	}

# --------------------
sub endTag {
# --------------------
my ($self, $name) = (@_);
	return $self->end_element({
		Name => $name, 
		});
	}

# --------------------
sub fullTag {
# --------------------
# replacement for dataElement, keeps attribute order
my ($self, $name, $data, @atts) = (@_);
	$self->start_element({
		Name => $name, 
		Attributes => {@atts},
		});
	$self->characters({
		Data => $data,
		}) if $data;
	$self->end_element({
		Name => $name,
		});
	}

# -------------------------
sub text {
# -------------------------
my ($self, $data) = @_;
	$self->characters({
		Data => $data,
		});
	}

# -------------------------
sub writeHash {
# -------------------------
my ($self, $hash, $elem) = @_;	
	my @atts;
	($elem, @atts) = $self->_tagNumberToID($elem);
	my $sub = "_$elem";
	return $self->$sub if $self->can($sub); # special routine for elements of this name
	$elem = $self->_startElem($elem, @atts, $self->_getAtts($hash)) if $elem;
	for (sort keys( %$hash )) {
		my $cont = $hash->{$_};
		if    (ref( $cont ) eq "ARRAY") { $self->writeArray($cont, $_) }
		elsif (ref( $cont ) eq "HASH")  { $self->writeHash($cont, $_) }
		else { $self->fullTag($_, $cont) };
		};
	$self->endTag($elem) if $elem;
	}
	
# -------------------------
sub writeArray {
# -------------------------
my ($self, $array, $elem) = @_;	
	my @atts;
	($elem, @atts) = $self->_tagNumberToID($elem);
	my $sub = "_$elem";
	return $self->$sub if $self->can($sub); # special case for element
	$elem = $self->_startElem($elem, @atts) if $elem;
	my $item = $self->{_item} || 'item';
	for (@$array) {
		$self->fullTag($item, $_);
		};
	$self->endTag($elem) if $elem;
	}

# -------------------------
sub _tagNumberToID {
# -------------------------
	my ($self, $elem) = @_;
	return( $elem ) unless ( $elem =~ /^\d/ );	# tag may not start with a number
	my $id = $self->{_id} || 'id';			# id replacement
	my $newelem = $self->{_number} || 'item';	# replacement tag for numbered items
	return ($newelem, $id, $elem);
	}

# -------------------------
sub _startElem {
# -------------------------
	my ($self, $elem, @atts) = @_;
	my $id = $self->{_id} || 'id';
	my $tag;
	if ( exists $self->{_elem}->{$elem} ) { 
		$tag = $self->{_elem}->{$elem};
		$self->startTag( $tag, $id => $elem, @atts);
		}
	else { 	$tag = $elem;
		$self->startTag($tag, @atts) };
	return $tag;
}

# -------------------------
sub _getAtts {
# -------------------------
	my ($self, $hash) = @_;	
	return 
		map { ($_, delete( $hash->{$_} )) } 
		grep { $self->{_atts}->{$_} } 
		keys( %$hash );
	}

# -------------------------
sub setAtts {
# -------------------------
	my ($self, $atts) = @_;
	$self->{_atts}->{$_} = 1 for @$atts;
	}

# -------------------------
sub delAtts {
# -------------------------
	my ($self, $atts) = @_;
	delete( $self->{_atts}->{$_} ) for @$atts;
	}

# -------------------------
sub clearAtts {
# -------------------------
	my $self = shift;
	$self->{_atts} = {};
	}

# -------------------------
sub setIdElements {
# -------------------------
	my ($self, $elem, $names) = @_;
	$self->{_elem}->{$_} = $elem for @$names;
	}
	
# -------------------------
sub delIdElements {
# -------------------------
	my ($self, $names) = @_;
	delete( $self->{_elem}->{$_} ) for @$names;
	}

# -------------------------
sub clearIdElements {
# -------------------------
	my $self = shift;
	$self->{_elem} = {};
	}

# --------------------
sub process {
# --------------------
# sets up a pipeline.and processes it 
# Calls parseFile if "Input" is set, or parse,
# or any routine given by the "Parse" argument 
	my $self = shift;
	%{$self} = %{$self->get_options(@_)};
	require XML::SAX::Pipeline;
	require XML::LibXML::SAX::Builder;
	require XML::Handler::PrintEvents; # cannot be used like a Filter
	my $driver = $self->{Driver} || $self;
	$self->{Filters} ||= [];
	my $filters = $self->{Filters};
	my $consumer = $self->{Consumer} || XML::LibXML::SAX::Builder->new();
	$consumer = XML::Handler::PrintEvents->new() if $self->{DEBUG};
	my $pipe = XML::SAX::Pipeline->new(
		$driver,
		@$filters,
		$consumer,
		);
	$pipe->parse();
	my $outfile = $self->{Output};
	return $outfile 
		? $consumer->toFile( $outfile )
		: $consumer->toString();
	}

# --------------------
sub parse {
# --------------------
	my $self = shift;
	%{$self} = %{$self->get_options(@_)};
	$self->startHandler();		#	ns => $self->{ns},
	if ( exists $self->{Input} ) { 
		$self->transformFile(); }
	else {	$self->transform() };
	$self->endHandler();
	}

# --------------------
sub transformFile {
# --------------------
	my $self = shift;
	my $filename = $self->{Input}; 
	open( F , "< $filename" ) or die( __PACKAGE__ . ": Couldn't open '$filename': $!");
	while ( my $line = <F> ) {
		chomp( $line );
		$self->transform( $line );
		};
	close( F );
	}

# --------------------
sub transform {
# --------------------
# default routine
	my ($self, $arg) = @_;
	$arg ||= $self->{Args} || "(None)";
	$self->fullTag('message', 
	"No XML::SAX::BASE::transform routine was set up.\nArguments given: $arg");
	}

# --------------------
package XML::Handler::PrintEvents;
# --------------------
# Don't know if this is correct, but we seem to need a "set_handler" method 
push @XML::Handler::PrintEvents::ISA, "XML::SAX::Machine";

sub toFile
	{ print "End of DEBUG output\n" }

sub toString
	{ print "End of DEBUG output\n" }

# --------------------
package XML::LibXML::SAX::Builder;
# --------------------
# Don't know if this is correct, but we seem to need a "set_handler" method 
push @XML::LibXML::SAX::Builder::ISA, "XML::SAX::Machine";

# -------------------------
sub print {
# -------------------------
my ($self) = @_;
	print $self->toString();
	}

# -------------------------
sub toString {
# -------------------------
my ($self) = @_;
	my $dom = $self->result();
	my $res = $dom->toString(1);
	$self->done();
	return $res;
	}

# -------------------------
sub toFile {
# -------------------------
my ($self, $filename) = @_;
	my $dom = $self->result() or die( __PACKAGE__ . ", file '$filename': No DOM tree to save!");
	print "Saving '$filename'\n";
	$dom->toFile($filename, 1);
	$self->done();
	}

# -------------------------
sub toExist {
# -------------------------
my ($self, $url, $collection, $xmlname) = @_;
	my $dom = $self->result();
	my $xml = $dom->toString(1);
	$self->done();
	require RPC::XML;
	require RPC::XML::Client;
	print "Connecting to $url ... ";
	my $client = RPC::XML::Client->new($url);
	die( "no connection!\n" ) unless $client;
	print "ok.\nStoring '$xmlname' in collection '$collection' ... ";
	my $req = RPC::XML::request->new(
		"parse", 
		RPC::XML::base64->new($xml),
		RPC::XML::string->new("$collection/$xmlname"),
		RPC::XML::int->new(1),
		);
	my $response = $client->send_request($req);
	if ($response->is_fault()) {
		print( "error!\n". $response->string . "\n")
		}
	else { print( "ok.\n") };
	return $response->value();
	}

# --------------------
package ULD::DOMBuilder;
# --------------------
use base "XML::LibXML::SAX::Builder";
# Don't know if this is correct, but we seem to need a "set_handler" method 
use strict;

# -------------------------
sub processing_instruction {
# -------------------------
my $self = shift;
my ($data) = @_;
	# print __PACKAGE__, " PI: ", $data->{Target}, " -> ", $data->{Data}, "\n";
	if ($data->{Target} eq 'subdoc') {
		$self->{_FILE_} = $data->{Data};
		};
	}

# -------------------------
sub end_document {
# -------------------------
my $self = shift;
	# print __PACKAGE__, " File: ", $self->{_FILE_}, "\n";
        $self->SUPER::end_document(); # this line is important!
	$self->toFile( $self->{_FILE_} ) if $self->{_FILE_};
	$self->{_FILE_} = undef;
	}

# --------------------
package ULD::Writer;
# --------------------
use base "XML::Handler::YAWriter";
# Don't know if this is correct, but we seem to need a "set_handler" method 
push @ULD::Writer::ISA, "XML::SAX::Base";
use strict;

# --------------------
sub end_element { # replaces original method
# --------------------
    my ($self, $element) = @_;
    my $name   = $element->{Name};

    $self->{'Counter'}--;
    if ($self->{'Pretty'}{'catchemptyelement'} &&
        ($self->{Sendbuf} =~ /^$name/ ) &&
        ($self->{Sendleft} eq "<") &&
        ($self->{Sendright} eq ">") ) {
        $self->{Sendright} = "/>";
    } elsif (!$self->{Sendleft}) {
        $self->print(undef, "</$name", ">") # no newline after characters
    } else {
        $self->print("</", $name, ">")
    };
}

# --------------------
sub end_document { # replaces original method
# --------------------
    my ($self, @data) = @_;
    $self->SUPER::end_document( @data );
    my ($package, $filename, $line) = caller();
    print STDERR "$package:$line, ", $self->{Filename}, " written\n";
}

# --------------------
package XML::SAX::DEBUG;
# --------------------

# gibt SAX events diagnostisch aus

use base qw(XML::SAX::Base);
# Don't know if this is correct, but we seem to need a "set_handler" method 
push @XML::SAX::DEBUG::ISA, "XML::SAX::Machine";
use XML::Filter::SAXT;
use IO::File;

# use SAXPlus;	# extended SAX driver commands

use strict;
use locale;

# --------------------
sub print_event {
# --------------------
	my ($self, $event_name, $params) = @_;
	my $fh = $self->{F} || \*STDOUT; 
	$fh->print( sprintf("%-22s", $event_name));
	$self->{_INDENT_}-- if $event_name eq "end_element";
	if (defined $params) {
		my $indent = "  " x $self->{_INDENT_};
		my $atts = $params->{Attributes};
		$fh->print( "$indent<", ) if $params->{Name};
		$fh->print( "/", ) if $event_name eq "end_element";
		$fh->print( $params->{Name}, ) if $params->{Name};
		if ($atts) {
				for my $att (keys %$atts) {
				$fh->print( " $att=\"", $atts->{$att}, "\"");
				};
			};
		$fh->print(">") if $params->{Name};
		$fh->print("\n");
		for my $key (keys %$params) {
			$fh->print( "\t$key =\t", $params->{$key}, "\n" ) 
				unless $key =~ /^(Name|Attributes)/;;
			}
		}
	else {
		$fh->print( "\n" );
		};
	$self->{_INDENT_}++ if $event_name eq "start_element";
	# $fh->print("-------------------------\n");
	my $super = "SUPER::" . $event_name;
	$self->$super( $params ); # further processing of event
}

# This generates the PerlSAX handler methods for PrintEvents.
# They basically forward the event to print_event() while adding the callback
# (event) name.

my @EXTRA_HANDLERS = ( 'ignorable_whitespace' );
my @handlers = (@EXTRA_HANDLERS, map { @{$_} } values %XML::Filter::SAXT::SAX_HANDLERS);
for my $handler (@handlers) {
	next if $handler eq "start_document";
	next if $handler eq "end_document";
	eval "sub $handler { shift->print_event ('$handler', \@_) }";
}

# --------------------
sub start_document {
# --------------------
	my ($self) = shift;
	$self->{Filename} ||= "debug.txt";	#  STDOUT
	# $self->{F} = IO::File->new($self->{Filename}, 'a'); # für Einzeldokumente, Option checken!!!
	$self->{F} = IO::File->new("EVENTS-" . $self->{Filename}, 'w');
	die(__PACKAGE__ . ": Cannot write events to file '$self->{Filename}'!\n") unless defined( $self->{F} );
	print STDERR __PACKAGE__ . ": Start redirecting events to '$self->{Filename}'.\n";
	return $self->print_event('start_document', @_);
	}

# --------------------
sub end_document {
# --------------------
	my ($self) = shift;
	$self->print_event('end_document', @_);
	$self->{F}->close();
	print STDERR __PACKAGE__ . ": stop redirecting events to '$self->{Filename}'.\n";
	}

# -------------------------
sub toFile {
# -------------------------
	print STDERR __PACKAGE__ . ": toFile() called\n";
}

# -------------------------
sub toString {
# -------------------------
	print STDERR __PACKAGE__ . ": toString() called\n";
}

__FILE__