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

Revision 11089, 43.4 KB (checked in by kjdon, 14 years ago)

removed a couple of unnecessary bits of code like repeated arguments, changed cover image stuff - these are now blocked even if smart block is off (when cover image is on)

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