root/gsdl/trunk/perllib/plugins/BasPlug.pm @ 15607

Revision 15607, 49.8 KB (checked in by ak19, 11 years ago)

Dr Bainbridge corrected call to encodings::encodings (previously encodings::encoding which was not correct)

  • Property svn:keywords set to Author Date Id Revision
Line 
1###########################################################################
2#
3# BasPlug.pm -- base class for all the import plugins
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999-2005 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26package BasPlug;
27
28BEGIN {
29    die "GSDLHOME not set\n" unless defined $ENV{'GSDLHOME'};
30}
31
32eval {require bytes};
33
34# suppress the annoying "subroutine redefined" warning that various
35# plugins cause under perl 5.6
36$SIG{__WARN__} = sub {warn($_[0]) unless ($_[0] =~ /Subroutine\s+\S+\sredefined/)};
37
38use strict;
39no strict 'subs';
40no strict 'refs'; # allow filehandles to be variables and viceversa
41
42use File::Basename;
43
44use Kea;
45use multiread;
46use encodings;
47use unicode;
48use cnseg;
49use acronym;
50use textcat;
51use doc;
52eval "require diagnostics"; # some perl distros (eg mac) don't have this
53use DateExtract;
54use ghtml;
55use gsprintf 'gsprintf';
56use printusage;
57use parse2;
58
59
60use GISBasPlug;
61
62@BasPlug::ISA = ( GISBasPlug );
63
64my $unicode_list =
65    [ { 'name' => "ascii",
66    'desc' => "{BasPlug.input_encoding.ascii}" },
67      { 'name' => "utf8",
68    'desc' => "{BasPlug.input_encoding.utf8}" },
69      { 'name' => "unicode",
70    'desc' => "{BasPlug.input_encoding.unicode}" } ];
71
72my $auto_unicode_list =
73    [ { 'name' => "auto",
74    'desc' => "{BasPlug.input_encoding.auto}" } ];
75
76my $e = $encodings::encodings;
77foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e))
78{
79    my $hashEncode =
80    {'name' => $enc,
81     'desc' => $e->{$enc}->{'name'}};
82   
83    push(@{$unicode_list},$hashEncode);
84}
85
86push(@{$auto_unicode_list},@{$unicode_list});
87
88my $arguments =
89    [ { 'name' => "process_exp",
90    'desc' => "{BasPlug.process_exp}",
91    'type' => "regexp",
92    'deft' => "",
93    'reqd' => "no" },
94      { 'name' => "block_exp",
95    'desc' => "{BasPlug.block_exp}",
96    'type' => "regexp",
97    'deft' => "",
98    'reqd' => "no" },
99      { 'name' => "smart_block",
100    'desc' => "{BasPlug.smart_block}",
101    'type' => "flag",
102    'reqd' => "no" },
103      { 'name' => "associate_ext",
104    'desc' => "{BasPlug.associate_ext}",
105    'type' => "string",
106    'reqd' => "no" },
107      { 'name' => "associate_tail_re",
108    'desc' => "{BasPlug.associate_tail_re}",
109    'type' => "string",
110    'reqd' => "no" },
111      { 'name' => "use_as_doc_identifier",
112    'desc' => "{BasPlug.use_as_doc_identifier}",
113    'type' => "string",
114    'reqd' => "no" ,
115    'deft' => "" } ,
116      { 'name' => "input_encoding",
117    'desc' => "{BasPlug.input_encoding}",
118    'type' => "enum",
119    'list' => $auto_unicode_list,
120    'reqd' => "no" ,
121    'deft' => "auto" } ,
122      { 'name' => "default_encoding",
123    'desc' => "{BasPlug.default_encoding}",
124    'type' => "enum",
125    'list' => $unicode_list,
126    'reqd' => "no",
127        'deft' => "utf8" },
128      { 'name' => "extract_language",
129    'desc' => "{BasPlug.extract_language}",
130    'type' => "flag",
131    'reqd' => "no" },
132      { 'name' => "default_language",
133    'desc' => "{BasPlug.default_language}",
134    'type' => "string",
135    'deft' => "en",
136    'reqd' => "no" },
137      { 'name' => "extract_acronyms",
138    'desc' => "{BasPlug.extract_acronyms}",
139    'type' => "flag",
140    'reqd' => "no" },
141      { 'name' => "markup_acronyms",
142    'desc' => "{BasPlug.markup_acronyms}",
143    'type' => "flag",
144    'reqd' => "no" },
145      { 'name' => "extract_keyphrases",
146    'desc' => "{BasPlug.extract_keyphrases}",
147    'type' => "flag",
148    'reqd' => "no" },
149      { 'name' => "extract_keyphrases_kea4",
150    'desc' => "{BasPlug.extract_keyphrases_kea4}",
151    'type' => "flag",
152    'reqd' => "no" },
153      { 'name' => "extract_keyphrase_options",
154    'desc' => "{BasPlug.extract_keyphrase_options}",
155    'type' => "string",
156    'deft' => "",
157    'reqd' => "no" },
158      { 'name' => "first",
159    'desc' => "{BasPlug.first}",
160    'type' => "string",
161    'reqd' => "no" },
162      { 'name' => "extract_email",
163    'desc' => "{BasPlug.extract_email}",
164    'type' => "flag",
165    'reqd' => "no" },
166      { 'name' => "extract_historical_years",
167    'desc' => "{BasPlug.extract_historical_years}",
168    'type' => "flag",
169    'reqd' => "no" },
170      { 'name' => "maximum_year",
171    'desc' => "{BasPlug.maximum_year}",
172    'type' => "int",
173    'deft' => (localtime)[5]+1900,
174    'char_length' => "4",
175    #'range' => "2,100",
176    'reqd' => "no"},
177      { 'name' => "maximum_century",
178    'desc' => "{BasPlug.maximum_century}",
179    'type' => "string",
180    'deft' => "-1",
181    'reqd' => "no" },
182      { 'name' => "no_bibliography",
183    'desc' => "{BasPlug.no_bibliography}",
184    'type' => "flag",
185    'reqd' => "no"},
186      { 'name' => "no_cover_image",
187    'desc' => "{BasPlug.no_cover_image}",
188    'type' => "flag",
189    'reqd' => "no" },
190      { 'name' => "separate_cjk",
191    'desc' => "{BasPlug.separate_cjk}",
192    'type' => "flag",
193    'reqd' => "no",
194    'hiddengli' => "yes" },
195      { 'name' => "new_extract_email",
196    'desc' => "",
197    'type' => "flag",
198    'reqd' => "no",
199    'hiddengli' => "yes" } ];
200
201my $gis_arguments =
202    [ { 'name' => "extract_placenames",
203    'desc' => "{GISBasPlug.extract_placenames}",
204    'type' => "flag",
205    'reqd' => "no" },
206      { 'name' => "gazetteer",
207    'desc' => "{GISBasPlug.gazetteer}",
208    'type' => "string",
209    'reqd' => "no" },
210      { 'name' => "place_list",
211    'desc' => "{GISBasPlug.place_list}",
212    'type' => "flag",
213    'reqd' => "no" } ];
214
215
216my $options = { 'name'     => "BasPlug",
217        'desc'     => "{BasPlug.desc}",
218        'abstract' => "yes",
219        'inherits' => "no",
220        'args'     => $arguments };
221
222
223sub set_incremental {
224    my $self = shift(@_);
225    my ($incremental) = @_;
226
227    $self->{'incremental'} = $incremental;
228}
229
230sub get_arguments
231{
232    my $self = shift(@_);
233    my $optionlistref = $self->{'option_list'};
234    my @optionlist = @$optionlistref;
235    my $pluginoptions = pop(@$optionlistref);
236    my $pluginarguments = $pluginoptions->{'args'};
237    return $pluginarguments;
238}
239
240
241sub print_xml_usage
242{
243    my $self = shift(@_);
244    my $header = shift(@_);
245    my $high_level_information_only = shift(@_);
246   
247    # XML output is always in UTF-8
248    gsprintf::output_strings_in_UTF8;
249
250    if ($header) {
251    &PrintUsage::print_xml_header("plugin");
252    }
253    $self->print_xml($high_level_information_only);
254}
255
256
257sub print_xml
258{
259    my $self = shift(@_);
260    my $high_level_information_only = shift(@_);
261
262    my $optionlistref = $self->{'option_list'};
263    my @optionlist = @$optionlistref;
264    my $pluginoptions = shift(@$optionlistref);
265    return if (!defined($pluginoptions));
266
267    # Find the process and block default expressions in the plugin arguments
268    my $process_exp = "";
269    my $block_exp = "";
270    if (defined($pluginoptions->{'args'})) {
271    foreach my $option (@{$pluginoptions->{'args'}}) {
272        if ($option->{'name'} eq "process_exp") {
273        $process_exp = $option->{'deft'};
274        }
275        if ($option->{'name'} eq "block_exp") {
276        $block_exp = $option->{'deft'};
277        }
278    }
279    }
280
281    gsprintf(STDERR, "<PlugInfo>\n");
282    gsprintf(STDERR, "  <Name>$pluginoptions->{'name'}</Name>\n");
283    my $desc = gsprintf::lookup_string($pluginoptions->{'desc'});
284    $desc =~ s/</&amp;lt;/g; # doubly escaped
285    $desc =~ s/>/&amp;gt;/g;
286    gsprintf(STDERR, "  <Desc>$desc</Desc>\n");
287    gsprintf(STDERR, "  <Abstract>$pluginoptions->{'abstract'}</Abstract>\n");
288    gsprintf(STDERR, "  <Inherits>$pluginoptions->{'inherits'}</Inherits>\n");
289    gsprintf(STDERR, "  <Processes>$process_exp</Processes>\n");
290    gsprintf(STDERR, "  <Blocks>$block_exp</Blocks>\n");
291    gsprintf(STDERR, "  <Explodes>" . ($pluginoptions->{'explodes'} || "no") . "</Explodes>\n");
292    # adding new option that works with replace_srcdoc_with_html.pl
293    gsprintf(STDERR, "  <SourceReplaceable>" . ($pluginoptions->{'srcreplaceable'} || "no") . "</SourceReplaceable>\n");
294    unless (defined($high_level_information_only)) {
295    gsprintf(STDERR, "  <Arguments>\n");
296    if (defined($pluginoptions->{'args'})) {
297        &PrintUsage::print_options_xml($pluginoptions->{'args'});
298    }
299    gsprintf(STDERR, "  </Arguments>\n");
300
301    # Recurse up the plugin hierarchy
302    $self->print_xml();
303    }
304    gsprintf(STDERR, "</PlugInfo>\n");
305}
306
307
308sub print_txt_usage
309{
310    my $self = shift(@_);
311    # Print the usage message for a plugin (recursively)
312    my $descoffset = $self->determine_description_offset(0);
313    $self->print_plugin_usage($descoffset, 1);
314}
315
316
317sub determine_description_offset
318{
319    my $self = shift(@_);
320    my $maxoffset = shift(@_);
321
322    my $optionlistref = $self->{'option_list'};
323    my @optionlist = @$optionlistref;
324    my $pluginoptions = shift(@$optionlistref);
325    return $maxoffset if (!defined($pluginoptions));
326
327    # Find the length of the longest option string of this plugin
328    my $pluginargs = $pluginoptions->{'args'};
329    if (defined($pluginargs)) {
330    my $longest = &PrintUsage::find_longest_option_string($pluginargs);
331    if ($longest > $maxoffset) {
332        $maxoffset = $longest;
333    }
334    }
335
336    # Recurse up the plugin hierarchy
337    $maxoffset = $self->determine_description_offset($maxoffset);
338    $self->{'option_list'} = \@optionlist;
339    return $maxoffset;
340}
341
342
343sub print_plugin_usage
344{
345    my $self = shift(@_);
346    my $descoffset = shift(@_);
347    my $isleafclass = shift(@_);
348
349    my $optionlistref = $self->{'option_list'};
350    my @optionlist = @$optionlistref;
351    my $pluginoptions = shift(@$optionlistref);
352    return if (!defined($pluginoptions));
353
354    my $pluginname = $pluginoptions->{'name'};
355    my $pluginargs = $pluginoptions->{'args'};
356    my $plugindesc = $pluginoptions->{'desc'};
357
358    # Produce the usage information using the data structure above
359    if ($isleafclass) {
360    if (defined($plugindesc)) {
361        gsprintf(STDERR, "$plugindesc\n\n");
362    }
363    gsprintf(STDERR, " {common.usage}: plugin $pluginname [{common.options}]\n\n");
364    }
365
366    # Display the plugin options, if there are some
367    if (defined($pluginargs)) {
368    # Calculate the column offset of the option descriptions
369    my $optiondescoffset = $descoffset + 2;  # 2 spaces between options & descriptions
370
371    if ($isleafclass) {
372        gsprintf(STDERR, " {common.specific_options}:\n");
373    }
374    else {
375        gsprintf(STDERR, " {common.general_options}:\n", $pluginname);
376    }
377
378    # Display the plugin options
379    &PrintUsage::print_options_txt($pluginargs, $optiondescoffset);
380    }
381
382    # Recurse up the plugin hierarchy
383    $self->print_plugin_usage($descoffset, 0);
384    $self->{'option_list'} = \@optionlist;
385}
386
387
388sub new {
389    # Set Encodings to the list!!
390
391
392    # Start the BasPlug Constructor
393    my $class = shift (@_);
394    my ($pluginlist,$args,$hashArgOptLists) = @_;
395    push(@$pluginlist, $class);
396    my $plugin_name = (defined $pluginlist->[0]) ? $pluginlist->[0] : $class;
397
398    if(defined $arguments){ push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});}
399    if(defined $options) { push(@{$hashArgOptLists->{"OptList"}},$options)};
400
401    if (GISBasPlug::has_mapdata()) {
402    push(@$arguments,@$gis_arguments);
403    }
404   
405    my $self = {};
406    $self->{'outhandle'} = STDERR;
407    $self->{'option_list'} = $hashArgOptLists->{"OptList"};
408    $self->{"info_only"} = 0;
409
410    # Check if gsdlinfo is in the argument list or not - if it is, don't parse
411    # the args, just return the object. 
412    foreach my $strArg (@{$args})
413    {
414    if($strArg eq "-gsdlinfo")
415    {
416        $self->{"info_only"} = 1;
417        return bless $self, $class;
418    }
419    }
420
421    if(parse2::parse($args,$hashArgOptLists->{"ArgList"},$self) == -1)
422    {
423    my $classTempClass = bless $self, $class;
424    print STDERR "<BadPlugin p=$plugin_name>\n";
425    &gsprintf(STDERR, "\n{BasPlug.bad_general_option}\n", $plugin_name);
426    $classTempClass->print_txt_usage("");  # Use default resource bundle
427    die "\n";
428    }
429
430
431    delete $self->{"info_only"};
432    # else parsing was successful.
433
434    $self->{'plugin_type'} = $plugin_name;
435    #$self->{'outhandle'} = STDERR;
436    $self->{'num_processed'} = 0;
437    $self->{'num_not_processed'} = 0;
438    $self->{'num_blocked'} = 0;
439    $self->{'num_archives'} = 0;
440    $self->{'cover_image'} = 1; # cover image is on by default
441    $self->{'cover_image'} = 0 if ($self->{'no_cover_image'});
442    #$self->{'option_list'} = $hashArgOptLists->{"OptList"};
443   
444    my $associate_ext = $self->{'associate_ext'};
445    if ((defined $associate_ext) && ($associate_ext ne "")) {
446
447    my $associate_tail_re = $self->{'associate_tail_re'};
448    if ((defined $associate_tail_re) && ($associate_tail_re ne "")) {
449        my $outhandle = $self->{'outhandle'};
450        print $outhandle "Warning: can only specify 'associate_ext' or 'associate_tail_re'\n";
451        print $outhandle "         defaulting to 'associate_tail_re'\n";
452    }
453    else {
454        my @exts = split(/,/,$associate_ext);
455
456        my @exts_bracketed = map { $_ = "(?:\\.$_)" } @exts;
457        my $associate_tail_re = join("|",@exts_bracketed);
458        $self->{'associate_tail_re'} = $associate_tail_re;
459    }
460
461    delete $self->{'associate_ext'};
462    }
463
464    $self->{'shared_fileroot'} = {};
465    $self->{'file_blocks'} = {};
466
467    if ($self->{'extract_placenames'}) {
468
469    my $outhandle = $self->{'outhandle'};
470   
471    my $places_ref
472        = GISBasPlug::loadGISDatabase($outhandle,$self->{'gazetteer'});
473   
474    if (!defined $places_ref) {
475        print $outhandle "Warning: Error loading mapdata gazetteer \"$self->{'gazetteer'}\"\n";
476        print $outhandle "         No placename extraction will take place.\n";
477        $self->{'extract_placenames'} = undef;
478    }
479    else {
480        $self->{'places'} = $places_ref;
481    }
482    }
483
484    return bless $self, $class;
485   
486}
487
488# initialize BasPlug options
489# if init() is overridden in a sub-class, remember to call BasPlug::init()
490sub init {
491    my $self = shift (@_);
492    my ($verbosity, $outhandle, $failhandle) = @_;
493
494    # verbosity is passed through from the processor
495    $self->{'verbosity'} = $verbosity;
496
497    # as are the outhandle and failhandle
498    $self->{'outhandle'} = $outhandle if defined $outhandle;
499    $self->{'failhandle'} = $failhandle;
500
501    # set process_exp and block_exp to defaults unless they were
502    # explicitly set
503
504    if ((!$self->is_recursive()) and
505    (!defined $self->{'process_exp'}) || ($self->{'process_exp'} eq "")) {
506
507    $self->{'process_exp'} = $self->get_default_process_exp ();
508    if ($self->{'process_exp'} eq "") {
509        warn ref($self) . " Warning: Non-recursive plugin has no process_exp\n";
510    }
511    }
512
513    if ((!defined $self->{'block_exp'}) || ($self->{'block_exp'} eq "")) {
514    $self->{'block_exp'} = $self->get_default_block_exp ();
515    }
516
517}
518
519sub begin {
520    my $self = shift (@_);
521    my ($pluginfo, $base_dir, $processor, $maxdocs) = @_;
522
523   #my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(0);
524   #print STDERR "Calling method; $cfilename:$cline $cpackage->$csubr\n";
525
526    $self->initialise_extractors();
527}
528
529sub end {
530    # potentially called at the end of each plugin pass
531    # import.pl only has one plugin pass, but buildcol.pl has multiple ones
532
533    my ($self) = @_;
534    $self->finalise_extractors();
535}
536
537sub deinit {
538    # called only once, after all plugin passes have been done
539
540    my ($self) = @_;
541}
542
543# this function should be overridden to return 1
544# in recursive plugins
545sub is_recursive {
546    my $self = shift (@_);
547
548    return 0;
549}
550
551sub get_default_block_exp {
552    my $self = shift (@_);
553
554    return "";
555}
556
557sub get_default_process_exp {
558    my $self = shift (@_);
559
560    return "";
561}
562
563# default implementation is to do nothing.
564sub store_block_files
565{
566    my $self =shift (@_);
567    my ($filename) = @_;
568    return;
569}
570
571#default implementation is to block a file with same name as this, but extension jpg or JPG, if cover_images is on.
572sub block_cover_image
573{
574    my $self =shift;
575    my $filename = shift;
576
577    if ($self->{'cover_image'}) {
578    my $coverfile = $filename;
579    $coverfile =~ s/\.[^\\\/\.]+$/\.jpg/;
580    if (!-e $coverfile) {
581        $coverfile =~ s/jpg$/JPG/;
582    }   
583    if (-e $coverfile) {
584        $self->{'file_blocks'}->{$coverfile} = 1;
585    }
586    }
587
588    return;
589}
590
591sub root_ext_split
592{
593    my $self = shift (@_);
594    my ($filename,$tail_re) = @_;
595   
596    my ($file_prefix,$file_ext) = ($filename =~ m/^(.*?)($tail_re)$/);
597
598    if ((!defined $file_prefix) || (!defined $file_ext)) {
599    ($file_prefix,$file_ext) = ($filename =~ m/^(.*)(\..*?)$/);
600    }
601
602    return ($file_prefix,$file_ext);
603}
604
605sub metadata_read {
606    my $self = shift (@_); 
607    my ($pluginfo, $base_dir, $file, $metadata, $extrametakeys, $extrametadata, $processor, $maxdocs, $gli) = @_;
608    # Keep track of filenames with same root but different extensions
609    # Used to support -associate_ext and the more generalised
610    # -associate_tail_re
611
612    my $associate_tail_re = $self->{'associate_tail_re'};
613    if ((defined $associate_tail_re) && ($associate_tail_re ne "")) {
614
615    my ($file_prefix,$file_ext)
616        = $self->root_ext_split($file,$associate_tail_re);
617
618    if ((defined $file_prefix) && (defined $file_ext)) {
619
620        my $shared_fileroot = $self->{'shared_fileroot'};
621        if (!defined $shared_fileroot->{$file_prefix}) {
622        my $file_prefix_rec = { 'tie_to'  => undef,
623                        'exts'    => {} };
624        $shared_fileroot->{$file_prefix} = $file_prefix_rec;
625        }
626       
627        my $file_prefix_rec = $shared_fileroot->{$file_prefix};
628
629        my $process_exp = $self->{'process_exp'};
630
631        if ($file =~ m/$process_exp/) {
632        # This is the document the others should be tied to
633        $file_prefix_rec->{'tie_to'} = $file_ext;
634        }
635        else {
636        if ($file_ext =~ m/$associate_tail_re$/) {
637            $file_prefix_rec->{'exts'}->{$file_ext} = 1;
638        }
639        }
640
641    }
642    }
643
644    # now check whether we are actually processing this
645    my $filename = $file;
646    $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
647    if ($self->{'process_exp'} eq "" || $filename !~ /$self->{'process_exp'}/ || !-f $filename) {
648    return undef; # can't recognise
649    }
650
651    # do smart blocking if appropriate
652    if ($self->{'smart_block'}) {
653    $self->store_block_files($filename);
654    }
655    # block the cover image if there is one
656    if ($self->{'cover_image'}) {
657    $self->block_cover_image($filename);
658    }
659       
660    return 1;
661}
662
663sub tie_to_filename
664{
665    my $self = shift (@_); 
666 
667    my ($file_ext,$file_prefix_rec) = @_;
668
669    if (defined $file_prefix_rec) {
670    my $tie_to = $file_prefix_rec->{'tie_to'};
671
672    if (defined $tie_to) {
673        if ($tie_to eq $file_ext) {
674        return 1;
675        }
676    }
677    }
678
679    return 0;
680}
681
682sub tie_to_assoc_file
683{
684    my $self = shift (@_);   
685    my ($file_ext,$file_prefix_rec) = @_;
686
687    if (defined $file_prefix_rec) {
688    my $tie_to = $file_prefix_rec->{'tie_to'};
689    if (defined $tie_to) {
690
691        my $exts = $file_prefix_rec->{'exts'};
692
693        my $has_file_ext = $exts->{$file_ext};
694
695        if ($has_file_ext) {
696        return 1;
697        }
698    }
699    }
700
701    return 0;
702}
703
704
705sub associate_with
706{
707    my $self = shift (@_);   
708    my ($file, $filename, $metadata) = @_;
709
710    my $associate_tail_re = $self->{'associate_tail_re'};
711    return 0 if (!$associate_tail_re);
712
713    # If file, see if matches with "tie_to" doc or is one of the
714    # associated filename extensions.
715
716    my ($file_prefix,$file_ext) = $self->root_ext_split($file,$associate_tail_re);
717
718    if ((defined $file_prefix) && (defined $file_ext)) {
719
720    my $file_prefix_rec = $self->{'shared_fileroot'}->{$file_prefix};
721   
722    if ($self->tie_to_filename($file_ext,$file_prefix_rec)) {
723
724        # Set up gsdlassocfile_tobe
725
726        my $exts = $file_prefix_rec->{'exts'};
727       
728        if (!defined $metadata->{'gsdlassocfile_tobe'}) {
729        $metadata->{'gsdlassocfile_tobe'} = [];
730        }
731
732        my $assoc_tobe = $metadata->{'gsdlassocfile_tobe'};
733           
734        my ($full_prefix) = ($filename =~ m/^(.*)\..*?$/);
735        foreach my $e (keys %$exts) {       
736        my $assoc_file = "$full_prefix$e";
737        print STDERR "  $self->{'plugin_type'}: Associating $file_prefix$e with $file_prefix_rec->{'tie_to'} version\n";
738        my $mime_type = ""; # let system auto detect this
739        push(@$assoc_tobe,"$assoc_file:$mime_type:");
740        }
741
742    }
743    elsif ($self->tie_to_assoc_file($file_ext,$file_prefix_rec)) {
744
745
746        # a form of smart block     
747        return 1;
748    }
749    }
750
751    return 0;
752}
753
754
755sub read_block {
756    my $self = shift (@_); 
757 
758    my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
759
760
761    my $filename = $file;
762    $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
763
764    if ($self->associate_with($file,$filename,$metadata)) {
765    # a form of smart block
766    $self->{'num_blocked'} ++;
767    return (0,undef); # blocked
768    }
769
770    my $smart_block = $self->{'smart_block'};
771    my $smart_block_BN = $self->{'smart_block_BN'};
772   
773    if ($smart_block || $smart_block_BN) {
774    if (defined $self->{'file_blocks'}->{$filename} && $self->{'file_blocks'}->{$filename} == 1){
775        $self->{'num_blocked'} ++;
776        return (0,undef); # blocked
777    }
778    } else {
779    if ($self->{'block_exp'} ne "" && $filename =~ /$self->{'block_exp'}/) {
780        $self->{'num_blocked'} ++;
781        return (0,undef); # blocked
782    }
783    if ($self->{'cover_image'}) {
784        if (defined $self->{'file_blocks'}->{$filename} && $self->{'file_blocks'}->{$filename} == 1){
785        $self->{'num_blocked'} ++;
786        return (0,undef); # blocked
787        }
788    }
789    }
790
791    if ($filename !~ /$self->{'process_exp'}/ || !-f $filename) {
792    return (undef,undef); # can't recognise
793    }
794   
795    return (1,$filename);
796}
797
798sub read_tidy_file {
799
800    my $self = shift (@_); 
801 
802    my ($file) = @_;
803
804    $file =~ s/^[\/\\]+//; # $file often begins with / so we'll tidy it up
805
806    return $file;
807}
808
809
810sub filename_to_metadata
811{
812    my $self = shift (@_); 
813    my ($file, $encoding) = @_;
814
815    my $outhandle = $self->{'outhandle'};
816
817    my $filesystem_encoding = undef;
818
819    eval {
820    use POSIX qw(locale_h);
821
822    # With only one parameter, setlocale retrieves the current value
823    my $current_locale = setlocale(LC_CTYPE);
824
825    if ($current_locale =~ m/^.*\.(.*?)$/) {
826        my $char_encoding = lc($1);
827        if ($char_encoding =~ m/^(iso)(8859)(\d{1,2})$/) {
828        $char_encoding = "$1\_$2\_$3";
829        }
830
831        $char_encoding =~ s/-/_/g;
832        $char_encoding =~ s/^utf_8$/utf8/;
833
834        if ($char_encoding =~ m/^\d+$/) {
835        if (defined $encodings::encodings->{"windows_$char_encoding"}) {
836            $char_encoding = "windows_$char_encoding";
837        }
838        elsif (defined $encodings::encodings->{"dos_$char_encoding"}) {
839            $char_encoding = "dos_$char_encoding";
840        }
841        }
842
843        if (($char_encoding =~ m/(?:ascii|utf8|unicode)/)
844        || (defined $encodings::encodings->{$char_encoding})) {
845        $filesystem_encoding = $char_encoding;
846        }
847        else {
848        print $outhandle "Warning: Unsupported character encoding '$char_encoding' from locale '$current_locale'\n";
849        }
850    }
851
852
853    };
854    if ($@) {
855    print $outhandle "$@\n";
856    print $outhandle "Warning: Unable to establish locale.  Will assume filesytem is UTF-8\n";
857   
858    }
859   
860    my ($filemeta) = $file =~ /([^\\\/]+)$/;
861   
862    # how do we know what encoding the filename is in?
863    # => one answer is to check the locale
864
865    if (defined $filesystem_encoding) {
866    if ($filesystem_encoding !~ /(?:ascii|utf8|unicode)/) {
867        $filemeta = unicode::unicode2utf8(
868            unicode::convert2unicode($filesystem_encoding, \$filemeta)
869              );
870    }
871    }
872    # assume it is in the same encoding as its contents
873    elsif ((defined $encoding) && ($encoding !~ /(?:ascii|utf8|unicode)/)) {
874    $filemeta = unicode::unicode2utf8(
875        unicode::convert2unicode($encoding, \$filemeta)
876    );
877    }
878   
879    my $dmsafe_filemeta = &ghtml::dmsafe($filemeta);
880
881    return $dmsafe_filemeta;
882}
883
884
885sub add_OID
886{
887    my $self = shift (@_); 
888    my ($doc_obj) = @_;
889
890    # See if a metadata field is specified as the field
891    if ((defined $self->{'use_as_doc_identifier'}) && ($self->{'use_as_doc_identifier'} ne "")) {
892    my $metadata_doc_id = $self->{'use_as_doc_identifier'};
893
894    # Consider "tidying" up metadata_doc_id to be something
895    # suitable in a URL
896    # Could even support a user specified plugin RE for this.
897
898    my $top_section = $doc_obj->get_top_section();
899    my $oid = $doc_obj->get_metadata_element($top_section,$metadata_doc_id);
900##  print STDERR "**** oid = $oid\n";
901        $doc_obj->set_OID($oid);
902    }
903    # See if there is a plugin-specific set_OID function...
904    elsif (defined ($self->can('set_OID'))) {
905    # it will need $doc_obj to set the Identifier metadata...
906    $self->set_OID(@_); # pass through any extra arguments supplied
907    } else {
908    # use the default set_OID() in doc.pm
909    $doc_obj->set_OID();
910    }
911}
912
913# The BasPlug read_into_doc_obj() function. This function does all the
914# right things to make general options work for a given plugin.  It reads in
915# a file and sets up a slew of metadata all saved in doc_obj, which
916# it then returns as part of a tuple (process_status,doc_obj)
917#
918# Much of this functionality used to reside in read, but it was broken
919# down into a supporting routine to make the code more flexible. 
920#
921# recursive plugins (e.g. RecPlug) and specialized plugins like those
922# capable of processing many documents within a single file (e.g.
923# GMLPlug) will normally want to implement their own version of
924# read_into_doc_obj()
925#
926# Note that $base_dir might be "" and that $file might
927# include directories
928sub read_into_doc_obj {
929    my $self = shift (@_); 
930    my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
931
932    if ($self->is_recursive()) {
933    gsprintf(STDERR, "{BasPlug.read_must_be_implemented}") && die "\n";
934    }
935
936    my $outhandle   = $self->{'outhandle'};
937
938    my ($block_status,$filename) = $self->read_block(@_);   
939    return $block_status if ((!defined $block_status) || ($block_status==0));
940    $file = $self->read_tidy_file($file);
941
942    # Do encoding stuff
943    my ($language, $encoding) = $self->textcat_get_language_encoding ($filename);
944    if ($self->{'verbosity'} > 2) {
945    print $outhandle "BasPlug: reading $file as ($encoding,$language)\n";
946    }
947
948    # create a new document
949    my $doc_obj = new doc ($filename, "indexed_doc");
950    my $top_section = $doc_obj->get_top_section();
951
952    $doc_obj->set_OIDtype ($processor->{'OIDtype'}, $processor->{'OIDmetadata'});
953    $doc_obj->add_utf8_metadata($top_section, "Language", $language);
954    $doc_obj->add_utf8_metadata($top_section, "Encoding", $encoding);
955    $doc_obj->add_utf8_metadata($top_section, "Plugin", "$self->{'plugin_type'}");
956    $doc_obj->add_utf8_metadata($top_section, "FileSize", (-s $filename));
957
958    my $filemeta = $self->filename_to_metadata($file,$encoding);
959    $doc_obj->add_utf8_metadata($top_section, "Source", $filemeta);
960    if ($self->{'cover_image'}) {
961    $self->associate_cover_image($doc_obj, $filename);
962    }
963   
964    # read in file ($text will be in utf8)
965    my $text = "";
966    $self->read_file ($filename, $encoding, $language, \$text);
967
968    if (!length ($text)) {
969    my $plugin_name = ref ($self);
970    if ($gli) {
971        print STDERR "<ProcessingError n='$file' r='File contains no text'>\n";
972    }
973    gsprintf($outhandle, "$plugin_name: {BasPlug.file_has_no_text}\n", $filename) if $self->{'verbosity'};
974
975    my $failhandle = $self->{'failhandle'};
976    gsprintf($failhandle, "$file: " . ref($self) . ": {BasPlug.empty_file}\n");
977    # print $failhandle "$file: " . ref($self) . ": file contains no text\n";
978    $self->{'num_not_processed'} ++;
979
980    return (0,undef); # what should we return here?? error but don't want to pass it on
981    }
982   
983    # include any metadata passed in from previous plugins
984    # note that this metadata is associated with the top level section
985
986    my $associate_tail_re = $self->{'associate_tail_re'};
987
988    $self->extra_metadata ($doc_obj, $doc_obj->get_top_section(), $metadata);
989
990    # do plugin specific processing of doc_obj
991    unless (defined ($self->process (\$text, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli))) {
992    $text = '';
993    undef $text;
994    print STDERR "<ProcessingError n='$file'>\n" if ($gli);
995    return (-1,undef);
996    }
997    $text='';
998    undef $text;
999   
1000    # do any automatic metadata extraction
1001    $self->auto_extract_metadata ($doc_obj);
1002
1003    $self->add_OID($doc_obj);
1004   
1005    return (1,$doc_obj);
1006}
1007
1008
1009# The BasPlug read() function. This function calls read_into_doc_obj()
1010# to ensure all the right things to make general options work for a
1011# given plugin are done. It then calls the process() function which
1012# does all the work specific to a plugin (like the old read functions
1013# used to do). Most plugins should define their own process() function
1014# and let this read() function keep control. 
1015#
1016# recursive plugins (e.g. RecPlug) and specialized plugins like those
1017# capable of processing many documents within a single file (e.g.
1018# GMLPlug) might want to implement their own version of read(), but
1019# more likely need to implement their own version of read_into_doc_obj()
1020#
1021# Return number of files processed, undef if can't recognise, -1 if can't
1022# process
1023
1024sub read {
1025    my $self = shift (@_); 
1026    my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
1027
1028    my ($process_status,$doc_obj) = $self->read_into_doc_obj(@_);
1029   
1030    if ((defined $process_status) && ($process_status == 1)) {
1031    # process the document
1032    $processor->process($doc_obj);
1033   
1034    if(defined($self->{'places_filename'})){
1035        &util::rm($self->{'places_filename'});
1036        $self->{'places_filename'} = undef;
1037    }
1038   
1039    $self->{'num_processed'} ++;
1040    undef $doc_obj;
1041    }
1042
1043    # if process_status == 1, then the file has been processed.
1044    return $process_status;
1045
1046}
1047
1048# returns undef if file is rejected by the plugin
1049sub process {
1050    my $self = shift (@_);
1051    my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli) = @_;
1052
1053    gsprintf(STDERR, "BasPlug::process {common.must_be_implemented}\n") && die "\n";
1054    # die "Basplug::process function must be implemented in sub-class\n";
1055
1056    return undef; # never gets here
1057}
1058
1059# uses the multiread package to read in the entire file pointed to
1060# by filename and loads the resulting text into $$textref. Input text
1061# may be in any of the encodings handled by multiread, output text
1062# will be in utf8
1063sub read_file {
1064    my $self = shift (@_);
1065    my ($filename, $encoding, $language, $textref) = @_;
1066
1067    if (!-r $filename)
1068    {
1069    my $outhandle = $self->{'outhandle'};
1070    gsprintf($outhandle, "{BasPlug.read_denied}\n", $filename) if $self->{'verbosity'};
1071    # print $outhandle "Read permission denied for $filename\n" if $self->{'verbosity'};
1072    return;
1073    }
1074    $$textref = "";
1075    if (!open (FILE, $filename)) {
1076    gsprintf(STDERR, "BasPlug::read_file {BasPlug.could_not_open_for_reading} ($!)\n", $filename);
1077    die "\n";
1078    }
1079     
1080    if ($encoding eq "ascii") {
1081    undef $/;
1082    $$textref = <FILE>;
1083    $/ = "\n";
1084    } else {
1085    my $reader = new multiread();
1086    $reader->set_handle ('BasPlug::FILE');
1087    $reader->set_encoding ($encoding);
1088    $reader->read_file ($textref);
1089        #Now segments chinese if the separate_cjk option is set
1090    if ($self->{'separate_cjk'}) {
1091        # segment the Chinese words
1092        $$textref = &cnseg::segment($$textref);
1093    }
1094    }
1095    close FILE;
1096}
1097
1098# write_file -- used by ConvertToPlug, for example in post processing
1099#
1100sub utf8_write_file {
1101    my $self = shift (@_);
1102    my ($textref, $filename) = @_;
1103   
1104    if (!open (FILE, ">$filename")) {
1105    gsprintf(STDERR, "ConvertToPlug::write_file {ConvertToPlug.could_not_open_for_writing} ($!)\n", $filename);
1106     die "\n";
1107     }
1108    print FILE $$textref;
1109   
1110    close FILE;
1111}
1112
1113
1114sub filename_based_title
1115{
1116    my $self = shift (@_);
1117    my ($file) = @_;
1118
1119    my $file_derived_title = $file;
1120    $file_derived_title =~ s/_/ /g;
1121    $file_derived_title =~ s/\..*?$//;
1122
1123    return $file_derived_title;
1124}
1125
1126
1127sub title_fallback
1128{
1129    my $self = shift (@_);
1130    my ($doc_obj,$section,$file) = @_;
1131
1132    if (!defined $doc_obj->get_metadata_element ($section, "Title")) {
1133
1134    my $file_derived_title = $self->filename_based_title($file);
1135   
1136    $doc_obj->add_utf8_metadata ($section, "Title", $self->filename_to_metadata($file_derived_title));
1137    }
1138}
1139
1140sub textcat_get_language_encoding {
1141    my $self = shift (@_);
1142    my ($filename) = @_;
1143
1144   
1145    my ($language, $encoding, $extracted_encoding);
1146    if ($self->{'input_encoding'} eq "auto") {
1147        # use textcat to automatically work out the input encoding and language
1148        ($language, $encoding) = $self->get_language_encoding ($filename);
1149    } elsif ($self->{'extract_language'}) {
1150        # use textcat to get language metadata
1151        ($language, $extracted_encoding) = $self->get_language_encoding ($filename);
1152        $encoding = $self->{'input_encoding'};
1153    # don't print this message for english... english in utf8 is identical
1154    # to english in iso-8859-1 (except for some punctuation). We don't have
1155    # a language model for en_utf8, so textcat always says iso-8859-1!
1156        if ($extracted_encoding ne $encoding && $language ne "en"
1157        && $self->{'verbosity'}) {
1158        my $plugin_name = ref ($self);
1159        my $outhandle = $self->{'outhandle'};
1160        gsprintf($outhandle, "$plugin_name: {BasPlug.wrong_encoding}\n", $filename, $encoding, $extracted_encoding);
1161        }
1162    } else {
1163        $language = $self->{'default_language'};
1164        $encoding = $self->{'input_encoding'};
1165    }
1166
1167    return ($language, $encoding);
1168}
1169
1170# Uses textcat to work out the encoding and language of the text in
1171# $filename. All html tags are removed before processing.
1172# returns an array containing "language" and "encoding"
1173sub get_language_encoding {
1174    my $self = shift (@_);
1175    my ($filename) = @_;
1176    my $outhandle = $self->{'outhandle'};
1177    my $unicode_format = "";
1178    my $best_language = "";
1179    my $best_encoding = "";
1180   
1181    # read in file
1182    if (!open (FILE, $filename)) {
1183    gsprintf(STDERR, "BasPlug::get_language_encoding {BasPlug.could_not_open_for_reading} ($!)\n", $filename);
1184    # this is a pretty bad error, but try to continue anyway
1185    return ($self->{'default_language'}, $self->{'input_encoding'});
1186    }
1187    undef $/;
1188    my $text = <FILE>;
1189    $/ = "\n";
1190    close FILE;
1191
1192    # check if first few bytes have a Byte Order Marker
1193    my $bom=substr($text,0,2); # check 16bit unicode
1194    if ($bom eq "\xff\xfe") { # little endian 16bit unicode
1195    $unicode_format="unicode";
1196    } elsif ($bom eq "\xfe\xff") { # big endian 16bit unicode
1197    $unicode_format="unicode";
1198    } else {
1199    $bom=substr($text,0,3); # check utf-8
1200    if ($bom eq "\xef\xbb\xbf") { # utf-8 coded FEFF bom
1201        $unicode_format="utf8";
1202#   } elsif ($bom eq "\xef\xbf\xbe") { # utf-8 coded FFFE bom. Error!?
1203#       $unicode_format="utf8";
1204    }
1205    }
1206   
1207
1208    # handle html files specially
1209    # XXX this doesn't match plugins derived from HTMLPlug (except ConvertTo)
1210    if (ref($self) eq 'HTMLPlug' ||
1211    (exists $self->{'converted_to'} && $self->{'converted_to'} eq 'HTML')){
1212
1213    # remove <title>stuff</title> -- as titles tend often to be in English
1214    # for foreign language documents
1215    $text =~ s!<title>.*?</title>!!si;
1216
1217    # see if this html file specifies its encoding
1218    if ($text =~ /^<\?xml.*encoding="(.+?)"/) {
1219        $best_encoding = $1;
1220    } elsif ($text =~ /<meta http-equiv.*content-type.*charset=(.+?)"/i) {#"
1221        $best_encoding = $1;
1222    }
1223    if ($best_encoding) { # we extracted an encoding
1224        $best_encoding =~ s/-+/_/g;
1225        $best_encoding = lc($best_encoding); # lowercase
1226        if ($best_encoding eq "utf_8") { $best_encoding = "utf8" }
1227        $self->{'input_encoding'} = $best_encoding;
1228    }
1229       
1230    # remove all HTML tags
1231    $text =~ s/<[^>]*>//sg;
1232    }
1233
1234    # get the language/encoding
1235    $self->{'textcat'} = new textcat() if (!defined($self->{'textcat'}));
1236    my $results = $self->{'textcat'}->classify(\$text);
1237
1238    # if textcat returns 3 or less possibilities we'll use the
1239    # first one in the list - otherwise use the defaults
1240    if (scalar @$results > 3) {
1241    if ($unicode_format) { # in case the first had a BOM
1242        $best_encoding=$unicode_format;
1243    } else {
1244        my %guessed_encodings = ();
1245        foreach my $result (@$results) {
1246        $result =~ /([^\-]+)$/;
1247        my $enc=$1;
1248        if (!defined($guessed_encodings{$enc})) {
1249            $guessed_encodings{$enc}=0;
1250        }
1251        $guessed_encodings{$enc}++;
1252        }
1253
1254        $guessed_encodings{""}=-1; # for default best_encoding of ""
1255        foreach my $enc (keys %guessed_encodings) {
1256        if ($guessed_encodings{$enc} >
1257            $guessed_encodings{$best_encoding}){
1258            $best_encoding=$enc;
1259        }
1260        }
1261    }
1262
1263    if ($self->{'input_encoding'} ne 'auto') {
1264        if ($self->{'extract_language'} && ($self->{'verbosity'}>2)) {
1265        gsprintf($outhandle,
1266             "BasPlug: {BasPlug.could_not_extract_language}\n",
1267             $filename, $self->{'default_language'});
1268        }       
1269        $best_language = $self->{'default_language'};
1270        $best_encoding = $self->{'input_encoding'};
1271
1272    } else {
1273        if ($self->{'verbosity'}>2) {
1274        gsprintf($outhandle,
1275             "BasPlug: {BasPlug.could_not_extract_language}\n",
1276             $filename, $self->{'default_language'});
1277        }
1278        $best_language = $self->{'default_language'};
1279    }
1280    } else { # <= 3 suggestions
1281    my ($language, $encoding) = $results->[0] =~ /^([^-]*)(?:-(.*))?$/;
1282    if (!defined $language) {
1283        if ($self->{'verbosity'}>2) {
1284        gsprintf($outhandle,
1285            "BasPlug: {BasPlug.could_not_extract_language}\n",
1286            $filename, $self->{'default_language'});
1287        }
1288        $language = $self->{'default_language'};
1289    }
1290    if (!defined $encoding) {
1291        if ($self->{'verbosity'}>2) {
1292        gsprintf($outhandle,
1293            "BasPlug: {BasPlug.could_not_extract_encoding}\n",
1294            $filename, $self->{'default_encoding'});
1295        }
1296        $encoding = $self->{'default_encoding'};
1297    }
1298    $best_language = $language;
1299    if (! $best_encoding ) { # may already be set... eg from html meta tag
1300        $best_encoding = $encoding;
1301    }
1302    }
1303
1304    my $text_copy = $text;
1305    if ($best_encoding =~ /^iso_8859/ && unicode::ensure_utf8(\$text_copy)==0) {
1306    # the text is valid utf8, so assume that's the real encoding
1307    # (since textcat is based on probabilities)
1308    $best_encoding = 'utf8';
1309    }
1310
1311    # check for equivalents where textcat doesn't have some encodings...
1312    # eg MS versions of standard encodings
1313    if ($best_encoding =~ /^iso_8859_(\d+)/) {
1314    my $iso = $1; # which variant of the iso standard?
1315    # iso-8859 sets don't use chars 0x80-0x9f, windows codepages do
1316    if ($text =~ /[\x80-\x9f]/) {
1317        # Western Europe
1318        if ($iso == 1 or $iso == 15) { $best_encoding = 'windows_1252' }
1319        elsif ($iso == 2) {$best_encoding = 'windows_1250'} # Central Europe
1320        elsif ($iso == 5) {$best_encoding = 'windows_1251'} # Cyrillic
1321        elsif ($iso == 6) {$best_encoding = 'windows_1256'} # Arabic
1322        elsif ($iso == 7) {$best_encoding = 'windows_1253'} # Greek
1323        elsif ($iso == 8) {$best_encoding = 'windows_1255'} # Hebrew
1324        elsif ($iso == 9) {$best_encoding = 'windows_1254'} # Turkish
1325    }
1326    }
1327
1328    if ($best_encoding !~ /^(ascii|utf8|unicode)$/ &&
1329    !defined $encodings::encodings->{$best_encoding}) {
1330    if ($self->{'verbosity'}) {
1331        gsprintf($outhandle, "BasPlug: {BasPlug.unsupported_encoding}\n",
1332             $filename, $best_encoding, $self->{'default_encoding'});
1333    }
1334    $best_encoding = $self->{'default_encoding'};
1335    }
1336
1337    return ($best_language, $best_encoding);
1338}
1339
1340# add any extra metadata that's been passed around from one
1341# plugin to another.
1342# extra_metadata uses add_utf8_metadata so it expects metadata values
1343# to already be in utf8
1344sub extra_metadata {
1345    my $self = shift (@_);
1346    my ($doc_obj, $cursection, $metadata) = @_;
1347
1348    my $associate_tail_re = $self->{'associate_tail_re'};
1349
1350    foreach my $field (keys(%$metadata)) {
1351    # $metadata->{$field} may be an array reference
1352    if ($field eq "gsdlassocfile_tobe") {
1353        # 'gsdlassocfile_tobe' is artificially introduced metadata
1354        # that is used to signal that certain additional files should
1355        # be tied to this document.  Useful in situations where a
1356        # metadata pass in the plugin pipeline works out some files
1357        # need to be associated with a document, but the document hasn't
1358        # been formed yet.
1359       
1360        my $equiv_form = "";
1361        foreach my $gaf (@{$metadata->{$field}}) {
1362        my ($full_filename,$mimetype) = ($gaf =~ m/^(.*):(.*):$/);
1363        my ($tail_filename) = ($full_filename =~ /^.*[\/\\](.+?)$/);
1364        my $filename = $full_filename;
1365                 
1366        $doc_obj->associate_file($full_filename,$tail_filename,$mimetype);
1367
1368        # work out extended tail extension (i.e. matching tail re)
1369
1370        my ($file_prefix,$file_extended_ext)
1371            = $self->root_ext_split($tail_filename,$associate_tail_re);
1372        my ($pre_doc_ext) = ($file_extended_ext =~ m/^(.*)\..*$/);
1373
1374        my ($doc_ext) = ($tail_filename =~ m/^.*\.(.*)$/);
1375        my $start_doclink = "<a href=\"_httpprefix_/collect/[collection]/index/assoc/{Or}{[parent(Top):archivedir],[archivedir]}/$tail_filename\">";
1376        my $srcicon = "_icon".$doc_ext."_";
1377        my $end_doclink = "</a>";
1378
1379        my $assoc_form = "$start_doclink\{If\}{$srcicon,$srcicon,$doc_ext\}$end_doclink";
1380
1381        if (defined $pre_doc_ext) {
1382            # for metadata such as [mp3._edited] [mp3._full] ...
1383            $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.$pre_doc_ext", $assoc_form);
1384        }
1385
1386        # for multiple metadata such as [mp3.assoclink]
1387        $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.assoclink", $assoc_form);
1388       
1389        $equiv_form .= " $assoc_form"; 
1390        }
1391        $doc_obj->add_utf8_metadata ($cursection, "equivlink", $equiv_form);
1392    }
1393    elsif (ref ($metadata->{$field}) eq "ARRAY") {
1394        map {
1395        $doc_obj->add_utf8_metadata ($cursection, $field, $_);
1396        } @{$metadata->{$field}};
1397    } else {
1398        $doc_obj->add_utf8_metadata ($cursection, $field, $metadata->{$field});
1399    }
1400    }
1401}
1402
1403# initialise metadata extractors
1404sub initialise_extractors {
1405    my $self = shift (@_);
1406
1407    if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1408    &acronym::initialise_acronyms();
1409    }
1410}
1411
1412# finalise metadata extractors
1413sub finalise_extractors {
1414    my $self = shift (@_);
1415
1416    if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1417    &acronym::finalise_acronyms();
1418    }
1419}
1420
1421# FIRSTNNN: extract the first NNN characters as metadata
1422sub extract_first_NNNN_characters {
1423    my $self = shift (@_);
1424    my ($textref, $doc_obj, $thissection) = @_;
1425   
1426    foreach my $size (split /,/, $self->{'first'}) {
1427    my $tmptext =  $$textref;
1428    $tmptext =~ s/^\s+//;
1429    $tmptext =~ s/\s+$//;
1430    $tmptext =~ s/\s+/ /gs;
1431    $tmptext = substr ($tmptext, 0, $size);
1432    $tmptext =~ s/\s\S*$/&#8230;/;
1433    $doc_obj->add_utf8_metadata ($thissection, "First$size", $tmptext);
1434    }
1435}
1436
1437sub extract_email {
1438    my $self = shift (@_);
1439    my ($textref, $doc_obj, $thissection) = @_;
1440    my $outhandle = $self->{'outhandle'};
1441
1442    gsprintf($outhandle, " {BasPlug.extracting_emails}...\n")
1443    if ($self->{'verbosity'} > 2);
1444   
1445    my @email = ($$textref =~ m/([-a-z0-9\.@+_=]+@(?:[-a-z0-9]+\.)+(?:com|org|edu|mil|int|net|[a-z][a-z]))/g);
1446    @email = sort @email;
1447   
1448#    if($self->{"new_extract_email"} == 0)
1449#    {
1450#    my @email2 = ();
1451#    foreach my $address (@email)
1452#   {
1453#   if (!(join(" ",@email2) =~ m/(^| )$address( |$)/ ))
1454#       {
1455#       push @email2, $address;
1456#       $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1457#       # print $outhandle "  extracting $address\n"
1458#       &gsprintf($outhandle, "  {BasPlug.extracting} $address\n")
1459#           if ($self->{'verbosity'} > 3);
1460#       }
1461#   }
1462#    }
1463#    else
1464#    {
1465    my $hashExistMail = {};
1466    foreach my $address (@email) {
1467    if (!(defined $hashExistMail->{$address}))
1468    {
1469        $hashExistMail->{$address} = 1;
1470        $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1471        gsprintf($outhandle, "  {BasPlug.extracting} $address\n")
1472        if ($self->{'verbosity'} > 3);
1473    }
1474    }
1475    gsprintf($outhandle, " {BasPlug.done_email_extract}\n")
1476    if ($self->{'verbosity'} > 2);
1477}
1478
1479# extract metadata
1480sub auto_extract_metadata {
1481
1482    my $self = shift (@_);
1483    my ($doc_obj) = @_;
1484   
1485    if ($self->{'extract_email'}) {
1486    my $thissection = $doc_obj->get_top_section();
1487    while (defined $thissection) {
1488        my $text = $doc_obj->get_text($thissection);
1489        $self->extract_email (\$text, $doc_obj, $thissection) if $text =~ /./;
1490        $thissection = $doc_obj->get_next_section ($thissection);
1491    }
1492    }
1493    if ($self->{'extract_placenames'}) {
1494    my $thissection = $doc_obj->get_top_section();
1495    while (defined $thissection) {
1496        my $text = $doc_obj->get_text($thissection);
1497        $self->extract_placenames (\$text, $doc_obj, $thissection) if $text =~ /./;
1498        $thissection = $doc_obj->get_next_section ($thissection);
1499    }
1500    }
1501
1502    if ($self->{'extract_keyphrases'} || $self->{'extract_keyphrases_kea4'}) {
1503    $self->extract_keyphrases($doc_obj);
1504    }
1505
1506    if ($self->{'first'}) {
1507    my $thissection = $doc_obj->get_top_section();
1508    while (defined $thissection) {
1509        my $text = $doc_obj->get_text($thissection);
1510        $self->extract_first_NNNN_characters (\$text, $doc_obj, $thissection) if $text =~ /./;
1511        $thissection = $doc_obj->get_next_section ($thissection);
1512    }
1513    }   
1514   
1515    if ($self->{'extract_acronyms'}) {
1516    my $thissection = $doc_obj->get_top_section();
1517    while (defined $thissection) {
1518        my $text = $doc_obj->get_text($thissection);
1519        $self->extract_acronyms (\$text, $doc_obj, $thissection) if $text =~ /./;
1520        $thissection = $doc_obj->get_next_section ($thissection);
1521    }
1522    }
1523   
1524    if ($self->{'markup_acronyms'}) {
1525    my $thissection = $doc_obj->get_top_section();
1526    while (defined $thissection) {
1527        my $text = $doc_obj->get_text($thissection);
1528        $text = $self->markup_acronyms ($text, $doc_obj, $thissection);
1529        $doc_obj->delete_text($thissection);
1530        $doc_obj->add_text($thissection, $text);
1531        $thissection = $doc_obj->get_next_section ($thissection);
1532    }
1533    }
1534
1535    if($self->{'extract_historical_years'}) {
1536    my $thissection = $doc_obj->get_top_section();
1537    while (defined $thissection) {
1538
1539        my $text = $doc_obj->get_text($thissection);
1540        &DateExtract::get_date_metadata($text, $doc_obj,
1541                        $thissection,
1542                        $self->{'no_bibliography'},
1543                        $self->{'maximum_year'},
1544                        $self->{'maximum_century'});
1545        $thissection = $doc_obj->get_next_section ($thissection);
1546    }
1547    }
1548}
1549
1550
1551#adding kea keyphrases
1552sub extract_keyphrases
1553{
1554    my $self = shift(@_);
1555    my $doc_obj = shift(@_);
1556
1557    # Use Kea 3.0 unless 4.0 has been specified
1558    my $kea_version = "3.0";
1559    if ($self->{'extract_keyphrases_kea4'}) {
1560    $kea_version = "4.0";
1561    }
1562
1563    # Check that Kea exists, and tell the user where to get it if not
1564    my $keahome = &Kea::get_Kea_directory($kea_version);
1565    if (!-e $keahome) {
1566    gsprintf(STDERR, "{BasPlug.missing_kea}\n", $keahome, $kea_version);
1567    return;
1568    }
1569
1570    my $thissection = $doc_obj->get_top_section();
1571    my $text = "";
1572    my $list;
1573
1574    #loop through sections to gather whole doc
1575    while (defined $thissection) {
1576    my $sectiontext = $doc_obj->get_text($thissection);   
1577    $text = $text.$sectiontext;
1578    $thissection = $doc_obj->get_next_section ($thissection);
1579    }
1580   
1581    if($self->{'extract_keyphrase_options'}) { #if kea options flag is set, call Kea with specified options
1582    $list = &Kea::extract_KeyPhrases ($kea_version, $text, $self->{'extract_keyphrase_options'});
1583    } else { #otherwise call Kea with no options
1584    $list = &Kea::extract_KeyPhrases ($kea_version, $text);
1585    }
1586 
1587    if ($list){
1588    # if a list of kea keyphrases was returned (ie not empty)
1589    if ($self->{'verbosity'}) {
1590        gsprintf(STDERR, "{BasPlug.keyphrases}: $list\n");
1591    }
1592
1593    #add metadata to top section
1594    $thissection = $doc_obj->get_top_section();
1595
1596    # add all key phrases as one metadata
1597    $doc_obj->add_metadata($thissection, "Keyphrases", $list);
1598
1599    # add individual key phrases as multiple metadata
1600    foreach my $keyphrase (split(',', $list)) {
1601        $keyphrase =~ s/^\s+|\s+$//g;
1602        $doc_obj->add_metadata($thissection, "Keyphrase", $keyphrase);
1603    }
1604    }
1605}
1606
1607
1608# extract acronyms from a section in a document. progress is
1609# reported to outhandle based on the verbosity. both the Acronym
1610# and the AcronymKWIC metadata items are created.
1611
1612sub extract_acronyms {
1613    my $self = shift (@_);
1614    my ($textref, $doc_obj, $thissection) = @_;
1615    my $outhandle = $self->{'outhandle'};
1616
1617    # print $outhandle " extracting acronyms ...\n"
1618    gsprintf($outhandle, " {BasPlug.extracting_acronyms}...\n")
1619    if ($self->{'verbosity'} > 2);
1620
1621    my $acro_array =  &acronym::acronyms($textref);
1622   
1623    foreach my $acro (@$acro_array) {
1624
1625    #check that this is the first time ...
1626    my $seen_before = "false";
1627    my $previous_data = $doc_obj->get_metadata($thissection, "Acronym");
1628    foreach my $thisAcro (@$previous_data) {
1629        if ($thisAcro eq $acro->to_string()) {
1630        $seen_before = "true";
1631        if ($self->{'verbosity'} >= 4) {
1632            gsprintf($outhandle, " {BasPlug.already_seen} " .
1633                 $acro->to_string() . "\n");
1634        }
1635        }
1636    }
1637
1638    if ($seen_before eq "false") {
1639        #write it to the file ...
1640        $acro->write_to_file();
1641
1642        #do the normal acronym
1643        $doc_obj->add_utf8_metadata($thissection, "Acronym",  $acro->to_string());
1644        gsprintf($outhandle, " {BasPlug.adding} ".$acro->to_string()."\n")
1645        if ($self->{'verbosity'} > 3);
1646    }
1647    }
1648
1649    gsprintf($outhandle, " {BasPlug.done_acronym_extract}\n")
1650    if ($self->{'verbosity'} > 2);
1651}
1652
1653sub markup_acronyms {
1654    my $self = shift (@_);
1655    my ($text, $doc_obj, $thissection) = @_;
1656    my $outhandle = $self->{'outhandle'};
1657
1658    gsprintf($outhandle, " {BasPlug.marking_up_acronyms}...\n")
1659    if ($self->{'verbosity'} > 2);
1660
1661    #self is passed in to check for verbosity ...
1662    $text = &acronym::markup_acronyms($text, $self);
1663
1664    gsprintf($outhandle, " {BasPlug.done_acronym_markup}\n")
1665    if ($self->{'verbosity'} > 2);
1666
1667    return $text;
1668}
1669
1670sub compile_stats {
1671    my $self = shift(@_);
1672    my ($stats) = @_;
1673
1674    $stats->{'num_processed'} += $self->{'num_processed'};
1675    $stats->{'num_not_processed'} += $self->{'num_not_processed'};
1676    $stats->{'num_archives'} += $self->{'num_archives'};
1677
1678}
1679
1680sub associate_cover_image {
1681    my $self = shift;
1682    my ($doc_obj, $filename) = @_;
1683
1684    $filename =~ s/\.[^\\\/\.]+$/\.jpg/;
1685    if (exists $self->{'covers_missing_cache'}->{$filename}) {
1686    # don't stat() for existence eg for multiple document input files
1687    # (eg SplitPlug)
1688    return;
1689    }
1690
1691    my $top_section=$doc_obj->get_top_section();
1692
1693    if (-e $filename) {
1694        $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1695    $doc_obj->add_utf8_metadata($top_section, "hascover",  1);
1696    } else {
1697    my $upper_filename = $filename;
1698    $upper_filename =~ s/jpg$/JPG/;
1699    if (-e $upper_filename) {
1700        $doc_obj->associate_file($upper_filename, "cover.jpg",
1701                     "image/jpeg");
1702        $doc_obj->add_utf8_metadata($top_section, "hascover",  1);
1703    } else {
1704        # file doesn't exist, so record the fact that it's missing so
1705        # we don't stat() again (stat is slow)
1706        $self->{'covers_missing_cache'}->{$filename} = 1;
1707    }
1708    }
1709
1710}
1711
1712
1713# Overridden by exploding plugins (eg. ISISPlug)
1714sub clean_up_after_exploding
1715{
1716    my $self = shift(@_);
1717}
1718
1719
17201;
Note: See TracBrowser for help on using the browser.