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

Revision 11122, 45.1 KB (checked in by davidb, 14 years ago)

Introduction of -associate_tail_re option to BasPlug?. This is a generalisation
of the associate_ext (in fact associate_ext is now mapped into the equivalent
assoicate_tail_re expression). To work properly, plugins that use the
secondary plugin mechanism (such as PDFPlug) need to duplicate the
associate_tail_re value secondary plug ins too.

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