source: main/trunk/greenstone2/perllib/plugins/GreenstoneXMLPlugin.pm@ 22841

###########################################################################
#
# GreenstoneXMLPlugin.pm
# A component of the Greenstone digital library software
# from the New Zealand Digital Library Project at the 
# University of Waikato, New Zealand.
#
# Copyright (C) 2001 New Zealand Digital Library Project
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
#
###########################################################################

# Processes GreenstoneArchive XML documents. Note that this plugin does no
# syntax checking (though the XML::Parser module tests for
# well-formedness). It's assumed that the GreenstoneArchive files conform
# to their DTD.

package GreenstoneXMLPlugin;

use Encode;

use ReadXMLFile;

use strict;
no strict 'refs'; # allow filehandles to be variables and viceversa

sub BEGIN {
    @GreenstoneXMLPlugin::ISA = ('ReadXMLFile');
}




sub get_default_process_exp {
    my $self = shift (@_);

    return q^(?i)doc\.xml$^;
}

my $arguments =
    [ { 'name' => "process_exp",
    'desc' => "{BasePlugin.process_exp}",
    'type' => "regexp",
    'deft' => &get_default_process_exp(),
    'reqd' => "no" } ];

my $options = { 'name'     => "GreenstoneXMLPlugin",
        'desc'     => "{GreenstoneXMLPlugin.desc}",
        'abstract' => "no",
        'inherits' => "yes",
            'args'     => $arguments };

sub new {
    my ($class) = shift (@_);
    my ($pluginlist,$inputargs,$hashArgOptLists) = @_;
    push(@$pluginlist, $class);

    push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});
    push(@{$hashArgOptLists->{"OptList"}},$options);

    my $self = new ReadXMLFile($pluginlist, $inputargs, $hashArgOptLists);

    $self->{'section'} = "";
    $self->{'section_level'} = 0;
    $self->{'metadata_name'} = "";
    $self->{'metadata_value'} = "";
    $self->{'content'} = "";

#    # Currently used to store information for previous values controls. In
#    # the next contract I'll move to using information directly from Lucene.
#    $self->{'sqlfh'} = 0;
   
    return bless $self, $class;
}

sub xml_start_document {
}

sub xml_end_document {
}

sub get_doctype {
    my $self = shift(@_);
    
    return "(Greenstone)?Archive";
}


sub xml_doctype {
    my $self = shift(@_);

    my ($expat, $name, $sysid, $pubid, $internal) = @_;

    # allow the short-lived and badly named "GreenstoneArchive" files to be processed
    # as well as the "Archive" files which should now be created by import.pl
    die "" if ($name !~ /^(Greenstone)?Archive$/);

    my $outhandle = $self->{'outhandle'};
    print $outhandle "GreenstoneXMLPlugin: processing $self->{'file'}\n" if $self->{'verbosity'} > 1;
    print STDERR "<Processing n='$self->{'file'}' p='GreenstoneXMLPlugin'>\n" if $self->{'gli'};

}


sub xml_start_tag {
    my $self = shift(@_);
    my ($expat, $element) = @_;

    $self->{'element'} = $element;
    if ($element eq "Section") {
    if ($self->{'section_level'} == 0) {
        $self->open_document();
        } else {
        my $doc_obj = $self->{'doc_obj'};
        $self->{'section'} = 
        $doc_obj->insert_section($doc_obj->get_end_child($self->{'section'}));
    }
    
    $self->{'section_level'} ++;
    }
    elsif ($element eq "Metadata") {
    $self->{'metadata_name'} = $_{'name'};
    }
}

sub xml_end_tag {
    my $self = shift(@_);
    my ($expat, $element) = @_;

    if ($element eq "Section") {
    $self->{'section_level'} --;
    $self->{'section'} = $self->{'doc_obj'}->get_parent_section ($self->{'section'});
    $self->close_document() if $self->{'section_level'} == 0;
    }
    elsif ($element eq "Metadata") {
    # text read in by XML::Parser is in Perl's binary byte value
    # form ... need to explicitly make it UTF-8

    my $metadata_name = decode("utf-8",$self->{'metadata_name'});
    my $metadata_value = decode("utf-8",$self->{'metadata_value'});

    $self->{'doc_obj'}->add_utf8_metadata($self->{'section'}, 
                          $metadata_name,$metadata_value);

        # Ensure this value is added to the allvalues database in gseditor.
        # Note that the database constraints prevent multiple occurances of the
        # same key-value pair.
        # We write these out to a file, so they can all be commited in one
        # transaction
        #if (!$self->{'sqlfh'})
        #  {
        #    my $sql_file = $ENV{'GSDLHOME'} . "/collect/lld/tmp/gseditor.sql";
        #    # If the file doesn't already exist, open it and begin a transaction
        #    my $sql_fh;
        #    if (!-e $sql_file)
        #      {
        #        open($sql_fh, ">" . $sql_file);
        #        print $sql_fh "BEGIN TRANSACTION;\n";
        #      }
        #    else
        #      {
        #        open($sql_fh, ">>" . $sql_file);
        #      }
        #    print STDERR "Opened SQL log\n";
        #    $self->{'sqlfh'} = $sql_fh;
        #  }

        #my $mvalue = $self->{'metadata_value'};
        #$mvalue =~ s/\'/\'\'/g;
        #$mvalue =~ s/_claimantsep_/ \& /g;

        #my $fh = $self->{'sqlfh'};
        #if ($fh)
        #  {
        #    print $fh "INSERT INTO allvalues (mkey, mvalue) VALUES ('" . $self->{'metadata_name'} . "', '" . $mvalue . "');\n";
        #  }

        # Clean Up
    $self->{'metadata_name'} = "";
    $self->{'metadata_value'} = "";
    }
    elsif ($element eq "Content" && $self->{'content'} ne "") {

    # text read in by XML::Parser is in Perl's binary byte value
    # form ... need to explicitly make it UTF-8
    my $content = decode("utf-8",$self->{'content'});

    $self->{'doc_obj'}->add_utf8_text($self->{'section'}, $content);
    $self->{'content'} = "";
    }
    $self->{'element'} = "";
}

sub xml_text {
    my $self = shift(@_);
    my ($expat) = @_;

    if ($self->{'element'} eq "Metadata") {
    $self->{'metadata_value'} .= $_;
    }
    elsif ($self->{'element'} eq "Content") {
    $self->{'content'} .= $_;
    }
}

sub open_document {
    my $self = shift(@_);

    # create a new document
    $self->{'doc_obj'} = new doc ();
    $self->{'section'} = "";
}

sub close_document {
    my $self = shift(@_);

    # add the associated files
    my $assoc_files = 
    $self->{'doc_obj'}->get_metadata($self->{'doc_obj'}->get_top_section(), "gsdlassocfile");

    # for when "assocfilepath" isn't the same directory that doc.xml is in...
    my $assoc_filepath_list= $self->{'doc_obj'}->get_metadata($self->{'doc_obj'}->get_top_section(), "assocfilepath");

    my $assoc_filepath=shift (@$assoc_filepath_list);

    #rint STDERR "Filename is: " . $self->{'filename'} . "\n";
    #rint STDERR "Initially my assoc_filepath is: $assoc_filepath\n";
    #rint STDERR "Custom archive dir is: " . $self->{'base_dir'} . "\n";
    # Correct the assoc filepath if one is defined
    if (defined ($assoc_filepath))
      {
        # Check whether the assoc_filepath already includes the base dir
        if (index($assoc_filepath, $self->{'base_dir'}) == -1)
          {
            # And if not, append it so as to make this absolute
            $assoc_filepath = &util::filename_cat($self->{'base_dir'}, $assoc_filepath);
          }
      }
    else
      {
    $assoc_filepath = $self->{'filename'};
    $assoc_filepath =~ s/[^\\\/]*$//;
      }
    #rint STDERR "Goned and made it absolute: $assoc_filepath\n";

    foreach my $assoc_file_info (@$assoc_files) {
    my ($assoc_file, $mime_type, $dir) = split (":", $assoc_file_info);
        #rint STDERR "assoc_file: $assoc_file\n";
        #rint STDERR "mime_type: $mime_type\n";
        #rint STDERR "dir: $dir\n";
    my $real_dir = &util::filename_cat($assoc_filepath, $assoc_file),
    my $assoc_dir = (defined $dir && $dir ne "") 
        ? &util::filename_cat($dir, $assoc_file) : $assoc_file;
    $self->{'doc_obj'}->associate_file($real_dir, $assoc_dir, $mime_type);
        #rint STDERR "According to me the real assoc_filepath is: $real_dir\n";
    }
    $self->{'doc_obj'}->delete_metadata($self->{'doc_obj'}->get_top_section(), "gsdlassocfile");

    # process the document
    $self->{'processor'}->process($self->{'doc_obj'}, $self->{'file'});
}


1;