source: trunk/gsdl/perllib/plugins/BasPlug.pm@ 12270

Last change on this file since 12270 was 12270, checked in by kjdon, 18 years ago

set_OIDtype now takes two arguments, the type and the metadata (used if type=assigned)
  • Property svn:keywords set to Author Date Id Revision
File size: 46.3 KB
Line 
1###########################################################################
2#
3# BasPlug.pm -- base class for all the import plugins
4# A component of the Greenstone digital library software
5# from the New Zealand Digital Library Project at the
6# University of Waikato, New Zealand.
7#
8# Copyright (C) 1999-2005 New Zealand Digital Library Project
9#
10# This program is free software; you can redistribute it and/or modify
11# it under the terms of the GNU General Public License as published by
12# the Free Software Foundation; either version 2 of the License, or
13# (at your option) any later version.
14#
15# This program is distributed in the hope that it will be useful,
16# but WITHOUT ANY WARRANTY; without even the implied warranty of
17# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18# GNU General Public License for more details.
19#
20# You should have received a copy of the GNU General Public License
21# along with this program; if not, write to the Free Software
22# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
23#
24###########################################################################
25
26package BasPlug;
27
28BEGIN {
29 die "GSDLHOME not set\n" unless defined $ENV{'GSDLHOME'};
30}
31
32eval {require bytes};
33
34# suppress the annoying "subroutine redefined" warning that various
35# plugins cause under perl 5.6
36$SIG{__WARN__} = sub {warn($_[0]) unless ($_[0] =~ /Subroutine\s+\S+\sredefined/)};
37
38use strict;
39no strict 'subs';
40no strict 'refs'; # allow filehandles to be variables and viceversa
41
42use File::Basename;
43
44use Kea;
45use multiread;
46use encodings;
47use unicode;
48use cnseg;
49use acronym;
50use textcat;
51use doc;
52eval "require diagnostics"; # some perl distros (eg mac) don't have this
53use DateExtract;
54use ghtml;
55use gsprintf 'gsprintf';
56use printusage;
57use parse2;
58
59
60use GISBasPlug;
61
62@BasPlug::ISA = ( GISBasPlug );
63
64my $unicode_list =
65 [ { 'name' => "ascii",
66 'desc' => "{BasPlug.input_encoding.ascii}" },
67 { 'name' => "utf8",
68 'desc' => "{BasPlug.input_encoding.utf8}" },
69 { 'name' => "unicode",
70 'desc' => "{BasPlug.input_encoding.unicode}" } ];
71
72my $auto_unicode_list =
73 [ { 'name' => "auto",
74 'desc' => "{BasPlug.input_encoding.auto}" } ];
75
76my $e = $encodings::encodings;
77foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e))
78{
79 my $hashEncode =
80 {'name' => $enc,
81 'desc' => $e->{$enc}->{'name'}};
82
83 push(@{$unicode_list},$hashEncode);
84}
85
86push(@{$auto_unicode_list},@{$unicode_list});
87
88my $arguments =
89 [ { 'name' => "process_exp",
90 'desc' => "{BasPlug.process_exp}",
91 'type' => "regexp",
92 'deft' => "",
93 'reqd' => "no" },
94 { 'name' => "block_exp",
95 'desc' => "{BasPlug.block_exp}",
96 'type' => "regexp",
97 'deft' => "",
98 'reqd' => "no" },
99 { 'name' => "smart_block",
100 'desc' => "{BasPlug.smart_block}",
101 'type' => "flag",
102 'reqd' => "no" },
103 { 'name' => "associate_ext",
104 'desc' => "{BasPlug.associate_ext}",
105 'type' => "string",
106 'reqd' => "no" },
107 { 'name' => "associate_tail_re",
108 'desc' => "{BasPlug.associate_tail_re}",
109 'type' => "string",
110 'reqd' => "no" },
111 { 'name' => "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 my $header = shift(@_);
240
241 # XML output is always in UTF-8
242 gsprintf::output_strings_in_UTF8;
243
244 if ($header) {
245 &PrintUsage::print_xml_header("plugin");
246 }
247 $self->print_xml();
248}
249
250
251sub print_xml
252{
253 my $self = shift(@_);
254
255 my $optionlistref = $self->{'option_list'};
256 my @optionlist = @$optionlistref;
257 my $pluginoptions = shift(@$optionlistref);
258 return if (!defined($pluginoptions));
259
260 gsprintf(STDERR, "<PlugInfo>\n");
261 gsprintf(STDERR, " <Name>$pluginoptions->{'name'}</Name>\n");
262 my $desc = gsprintf::lookup_string($pluginoptions->{'desc'});
263 $desc =~ s/</&amp;lt;/g; # doubly escaped
264 $desc =~ s/>/&amp;gt;/g;
265
266 gsprintf(STDERR, " <Desc>$desc</Desc>\n");
267 gsprintf(STDERR, " <Abstract>$pluginoptions->{'abstract'}</Abstract>\n");
268 gsprintf(STDERR, " <Inherits>$pluginoptions->{'inherits'}</Inherits>\n");
269 gsprintf(STDERR, " <Explodes>" . ($pluginoptions->{'explodes'} || "no") . "</Explodes>\n");
270 gsprintf(STDERR, " <Arguments>\n");
271 if (defined($pluginoptions->{'args'})) {
272 &PrintUsage::print_options_xml($pluginoptions->{'args'});
273 }
274 gsprintf(STDERR, " </Arguments>\n");
275 # Recurse up the plugin hierarchy
276 $self->print_xml();
277 gsprintf(STDERR, "</PlugInfo>\n");
278}
279
280
281sub print_txt_usage
282{
283 my $self = shift(@_);
284 # Print the usage message for a plugin (recursively)
285 my $descoffset = $self->determine_description_offset(0);
286 $self->print_plugin_usage($descoffset, 1);
287}
288
289
290sub determine_description_offset
291{
292 my $self = shift(@_);
293 my $maxoffset = shift(@_);
294
295 my $optionlistref = $self->{'option_list'};
296 my @optionlist = @$optionlistref;
297 my $pluginoptions = shift(@$optionlistref);
298 return $maxoffset if (!defined($pluginoptions));
299
300 # Find the length of the longest option string of this plugin
301 my $pluginargs = $pluginoptions->{'args'};
302 if (defined($pluginargs)) {
303 my $longest = &PrintUsage::find_longest_option_string($pluginargs);
304 if ($longest > $maxoffset) {
305 $maxoffset = $longest;
306 }
307 }
308
309 # Recurse up the plugin hierarchy
310 $maxoffset = $self->determine_description_offset($maxoffset);
311 $self->{'option_list'} = \@optionlist;
312 return $maxoffset;
313}
314
315
316sub print_plugin_usage
317{
318 my $self = shift(@_);
319 my $descoffset = shift(@_);
320 my $isleafclass = shift(@_);
321
322 my $optionlistref = $self->{'option_list'};
323 my @optionlist = @$optionlistref;
324 my $pluginoptions = shift(@$optionlistref);
325 return if (!defined($pluginoptions));
326
327 my $pluginname = $pluginoptions->{'name'};
328 my $pluginargs = $pluginoptions->{'args'};
329 my $plugindesc = $pluginoptions->{'desc'};
330
331 # Produce the usage information using the data structure above
332 if ($isleafclass) {
333 if (defined($plugindesc)) {
334 gsprintf(STDERR, "$plugindesc\n\n");
335 }
336 gsprintf(STDERR, " {common.usage}: plugin $pluginname [{common.options}]\n\n");
337 }
338
339 # Display the plugin options, if there are some
340 if (defined($pluginargs)) {
341 # Calculate the column offset of the option descriptions
342 my $optiondescoffset = $descoffset + 2; # 2 spaces between options & descriptions
343
344 if ($isleafclass) {
345 gsprintf(STDERR, " {common.specific_options}:\n");
346 }
347 else {
348 gsprintf(STDERR, " {common.general_options}:\n", $pluginname);
349 }
350
351 # Display the plugin options
352 &PrintUsage::print_options_txt($pluginargs, $optiondescoffset);
353 }
354
355 # Recurse up the plugin hierarchy
356 $self->print_plugin_usage($descoffset, 0);
357 $self->{'option_list'} = \@optionlist;
358}
359
360
361sub new {
362 # Set Encodings to the list!!
363
364
365 # Start the BasPlug Constructor
366 my $class = shift (@_);
367 my ($pluginlist,$args,$hashArgOptLists) = @_;
368 push(@$pluginlist, $class);
369 my $plugin_name = (defined $pluginlist->[0]) ? $pluginlist->[0] : $class;
370
371 if(defined $arguments){ push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});}
372 if(defined $options) { push(@{$hashArgOptLists->{"OptList"}},$options)};
373
374 if (GISBasPlug::has_mapdata()) {
375 push(@$arguments,@$gis_arguments);
376 }
377
378 my $self = {};
379 $self->{'outhandle'} = STDERR;
380 $self->{'option_list'} = $hashArgOptLists->{"OptList"};
381 $self->{"info_only"} = 0;
382
383 # Check if gsdlinfo is in the argument list or not - if it is, don't parse
384 # the args, just return the object.
385 foreach my $strArg (@{$args})
386 {
387 if($strArg eq "-gsdlinfo")
388 {
389 $self->{"info_only"} = 1;
390 return bless $self, $class;
391 }
392 }
393
394 if(!parse2::parse($args,$hashArgOptLists->{"ArgList"},$self))
395 {
396 my $classTempClass = bless $self, $class;
397 print STDERR "<BadPlugin p=$plugin_name>\n";
398 &gsprintf(STDERR, "\n{BasPlug.bad_general_option}\n", $plugin_name);
399 $classTempClass->print_txt_usage(""); # Use default resource bundle
400 die "\n";
401 }
402
403
404 delete $self->{"info_only"};
405 # else parsing was successful.
406
407 $self->{'plugin_type'} = $plugin_name;
408 #$self->{'outhandle'} = STDERR;
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 if ($self->{'verbosity'} > 2) {
812 print $outhandle "BasPlug: reading $file as ($encoding,$language)\n";
813 }
814
815 # create a new document
816 my $doc_obj = new doc ($filename, "indexed_doc");
817 $doc_obj->set_OIDtype ($processor->{'OIDtype'}, $processor->{'OIDmetadata'});
818 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Language", $language);
819 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Encoding", $encoding);
820 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Plugin", "$self->{'plugin_type'}");
821 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "FileSize", (-s $filename));
822
823 my ($filemeta) = $file =~ /([^\\\/]+)$/;
824 # how do we know what encoding the filename is in?
825 # assume it is in the same encoding as its contents
826 if ($encoding !~ /(?:ascii|utf8|unicode)/) {
827 $filemeta = unicode::unicode2utf8(
828 unicode::convert2unicode($encoding, \$filemeta)
829 );
830 }
831 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Source", &ghtml::dmsafe($filemeta));
832 if ($self->{'cover_image'}) {
833 $self->associate_cover_image($doc_obj, $filename);
834 }
835
836 # read in file ($text will be in utf8)
837 my $text = "";
838 $self->read_file ($filename, $encoding, $language, \$text);
839
840 if (!length ($text)) {
841 my $plugin_name = ref ($self);
842 if ($gli) {
843 print STDERR "<ProcessingError n='$file' r='File contains no text'>\n";
844 }
845 gsprintf($outhandle, "$plugin_name: {BasPlug.file_has_no_text}\n", $filename) if $self->{'verbosity'};
846
847 my $failhandle = $self->{'failhandle'};
848 gsprintf($failhandle, "$file: " . ref($self) . ": {BasPlug.empty_file}\n");
849 # print $failhandle "$file: " . ref($self) . ": file contains no text\n";
850 $self->{'num_not_processed'} ++;
851
852 return (0,undef); # what should we return here?? error but don't want to pass it on
853 }
854
855 # include any metadata passed in from previous plugins
856 # note that this metadata is associated with the top level section
857
858 my $associate_tail_re = $self->{'associate_tail_re'};
859
860 $self->extra_metadata ($doc_obj, $doc_obj->get_top_section(), $metadata);
861
862 # do plugin specific processing of doc_obj
863 unless (defined ($self->process (\$text, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli))) {
864 $text = '';
865 undef $text;
866 print STDERR "<ProcessingError n='$file'>\n" if ($gli);
867 return (-1,undef);
868 }
869 $text='';
870 undef $text;
871
872 # do any automatic metadata extraction
873 $self->auto_extract_metadata ($doc_obj);
874
875 # add an OID
876 # see if there is a plugin-specific set_OID function...
877 if (defined ($self->can('set_OID'))) {
878 # it will need $doc_obj to set the Identifier metadata...
879 $self->set_OID($doc_obj);
880 } else {
881 # use the default set_OID() in doc.pm
882 $doc_obj->set_OID();
883 }
884
885 return (1,$doc_obj);
886}
887
888
889# The BasPlug read() function. This function calls read_into_doc_obj()
890# to ensure all the right things to make general options work for a
891# given plugin are done. It then calls the process() function which
892# does all the work specific to a plugin (like the old read functions
893# used to do). Most plugins should define their own process() function
894# and let this read() function keep control.
895#
896# recursive plugins (e.g. RecPlug) and specialized plugins like those
897# capable of processing many documents within a single file (e.g.
898# GMLPlug) might want to implement their own version of read(), but
899# more likely need to implement their own version of read_into_doc_obj()
900#
901# Return number of files processed, undef if can't recognise, -1 if can't
902# process
903
904sub read {
905 my $self = shift (@_);
906 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
907
908 my ($process_status,$doc_obj) = $self->read_into_doc_obj(@_);
909
910 if ((defined $process_status) && ($process_status == 1)) {
911 # process the document
912 $processor->process($doc_obj);
913
914 if(defined($self->{'places_filename'})){
915 &util::rm($self->{'places_filename'});
916 $self->{'places_filename'} = undef;
917 }
918
919 $self->{'num_processed'} ++;
920 undef $doc_obj;
921 }
922
923 # if process_status == 1, then the file has been processed.
924 return $process_status;
925
926}
927
928# returns undef if file is rejected by the plugin
929sub process {
930 my $self = shift (@_);
931 my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli) = @_;
932
933 gsprintf(STDERR, "BasPlug::process {common.must_be_implemented}\n") && die "\n";
934 # die "Basplug::process function must be implemented in sub-class\n";
935
936 return undef; # never gets here
937}
938
939# uses the multiread package to read in the entire file pointed to
940# by filename and loads the resulting text into $$textref. Input text
941# may be in any of the encodings handled by multiread, output text
942# will be in utf8
943sub read_file {
944 my $self = shift (@_);
945 my ($filename, $encoding, $language, $textref) = @_;
946
947 if (!-r $filename)
948 {
949 my $outhandle = $self->{'outhandle'};
950 gsprintf($outhandle, "{BasPlug.read_denied}\n", $filename) if $self->{'verbosity'};
951 # print $outhandle "Read permission denied for $filename\n" if $self->{'verbosity'};
952 return;
953 }
954 $$textref = "";
955 if (!open (FILE, $filename)) {
956 gsprintf(STDERR, "BasPlug::read_file {BasPlug.could_not_open_for_reading} ($!)\n", $filename);
957 die "\n";
958 }
959
960 if ($encoding eq "ascii") {
961 undef $/;
962 $$textref = <FILE>;
963 $/ = "\n";
964 } else {
965 my $reader = new multiread();
966 $reader->set_handle ('BasPlug::FILE');
967 $reader->set_encoding ($encoding);
968 $reader->read_file ($textref);
969 #Now segments chinese if the separate_cjk option is set
970 if ($self->{'separate_cjk'}) {
971 # segment the Chinese words
972 $$textref = &cnseg::segment($$textref);
973 }
974 }
975 close FILE;
976}
977
978# write_file -- used by ConvertToPlug, for example in post processing
979#
980sub utf8_write_file {
981 my $self = shift (@_);
982 my ($textref, $filename) = @_;
983
984 if (!open (FILE, ">$filename")) {
985 gsprintf(STDERR, "ConvertToPlug::write_file {ConvertToPlug.could_not_open_for_writing} ($!)\n", $filename);
986 die "\n";
987 }
988 print FILE $$textref;
989
990 close FILE;
991}
992
993
994sub filename_based_title
995{
996 my $self = shift (@_);
997 my ($file) = @_;
998
999 my $file_derived_title = $file;
1000 $file_derived_title =~ s/_/ /g;
1001 $file_derived_title =~ s/\..*?$//;
1002
1003 return $file_derived_title;
1004}
1005
1006
1007sub title_fallback
1008{
1009 my $self = shift (@_);
1010 my ($doc_obj,$section,$file) = @_;
1011
1012 if (!defined $doc_obj->get_metadata_element ($section, "Title")) {
1013
1014 my $file_derived_title = $self->filename_based_title($file);
1015 $doc_obj->add_metadata ($section, "Title", $file_derived_title);
1016 }
1017}
1018
1019sub textcat_get_language_encoding {
1020 my $self = shift (@_);
1021 my ($filename) = @_;
1022
1023
1024 my ($language, $encoding, $extracted_encoding);
1025 if ($self->{'input_encoding'} eq "auto") {
1026 # use textcat to automatically work out the input encoding and language
1027 ($language, $encoding) = $self->get_language_encoding ($filename);
1028 } elsif ($self->{'extract_language'}) {
1029 # use textcat to get language metadata
1030 ($language, $extracted_encoding) = $self->get_language_encoding ($filename);
1031 $encoding = $self->{'input_encoding'};
1032 # don't print this message for english... english in utf8 is identical
1033 # to english in iso-8859-1 (except for some punctuation). We don't have
1034 # a language model for en_utf8, so textcat always says iso-8859-1!
1035 if ($extracted_encoding ne $encoding && $language ne "en"
1036 && $self->{'verbosity'}) {
1037 my $plugin_name = ref ($self);
1038 my $outhandle = $self->{'outhandle'};
1039 gsprintf($outhandle, "$plugin_name: {BasPlug.wrong_encoding}\n", $filename, $encoding, $extracted_encoding);
1040 }
1041 } else {
1042 $language = $self->{'default_language'};
1043 $encoding = $self->{'input_encoding'};
1044 }
1045
1046 return ($language, $encoding);
1047}
1048
1049# Uses textcat to work out the encoding and language of the text in
1050# $filename. All html tags are removed before processing.
1051# returns an array containing "language" and "encoding"
1052sub get_language_encoding {
1053 my $self = shift (@_);
1054 my ($filename) = @_;
1055 my $outhandle = $self->{'outhandle'};
1056 my $unicode_format = "";
1057 my $best_language = "";
1058 my $best_encoding = "";
1059
1060 # read in file
1061 if (!open (FILE, $filename)) {
1062 gsprintf(STDERR, "BasPlug::get_language_encoding {BasPlug.could_not_open_for_reading} ($!)\n", $filename);
1063 # this is a pretty bad error, but try to continue anyway
1064 return ($self->{'default_language'}, $self->{'input_encoding'});
1065 }
1066 undef $/;
1067 my $text = <FILE>;
1068 $/ = "\n";
1069 close FILE;
1070
1071 # check if first few bytes have a Byte Order Marker
1072 my $bom=substr($text,0,2); # check 16bit unicode
1073 if ($bom eq "\xff\xfe") { # little endian 16bit unicode
1074 $unicode_format="unicode";
1075 } elsif ($bom eq "\xfe\xff") { # big endian 16bit unicode
1076 $unicode_format="unicode";
1077 } else {
1078 $bom=substr($text,0,3); # check utf-8
1079 if ($bom eq "\xef\xbb\xbf") { # utf-8 coded FEFF bom
1080 $unicode_format="utf8";
1081# } elsif ($bom eq "\xef\xbf\xbe") { # utf-8 coded FFFE bom. Error!?
1082# $unicode_format="utf8";
1083 }
1084 }
1085
1086
1087 # handle html files specially
1088 # XXX this doesn't match plugins derived from HTMLPlug (except ConvertTo)
1089 if (ref($self) eq 'HTMLPlug' ||
1090 (exists $self->{'converted_to'} && $self->{'converted_to'} eq 'HTML')){
1091
1092 # remove <title>stuff</title> -- as titles tend often to be in English
1093 # for foreign language documents
1094 $text =~ s!<title>.*?</title>!!si;
1095
1096 # see if this html file specifies its encoding
1097 if ($text =~ /^<\?xml.*encoding="(.+?)"/) {
1098 $best_encoding = $1;
1099 } elsif ($text =~ /<meta http-equiv.*content-type.*charset=(.+?)"/i) {#"
1100 $best_encoding = $1;
1101 }
1102 if ($best_encoding) { # we extracted an encoding
1103 $best_encoding =~ s/-+/_/g;
1104 $best_encoding = lc($best_encoding); # lowercase
1105 if ($best_encoding eq "utf_8") { $best_encoding = "utf8" }
1106 $self->{'input_encoding'} = $best_encoding;
1107 }
1108
1109 # remove all HTML tags
1110 $text =~ s/<[^>]*>//sg;
1111 }
1112
1113 # get the language/encoding
1114 $self->{'textcat'} = new textcat() if (!defined($self->{'textcat'}));
1115 my $results = $self->{'textcat'}->classify(\$text);
1116
1117 # if textcat returns 3 or less possibilities we'll use the
1118 # first one in the list - otherwise use the defaults
1119 if (scalar @$results > 3) {
1120 if ($unicode_format) { # in case the first had a BOM
1121 $best_encoding=$unicode_format;
1122 } else {
1123 my %guessed_encodings = ();
1124 foreach my $result (@$results) {
1125 $result =~ /([^\-]+)$/;
1126 my $enc=$1;
1127 if (!defined($guessed_encodings{$enc})) {
1128 $guessed_encodings{$enc}=0;
1129 }
1130 $guessed_encodings{$enc}++;
1131 }
1132
1133 $guessed_encodings{""}=-1; # for default best_encoding of ""
1134 foreach my $enc (keys %guessed_encodings) {
1135 if ($guessed_encodings{$enc} >
1136 $guessed_encodings{$best_encoding}){
1137 $best_encoding=$enc;
1138 }
1139 }
1140 }
1141
1142 if ($self->{'input_encoding'} ne 'auto') {
1143 if ($self->{'extract_language'} && ($self->{'verbosity'}>2)) {
1144 gsprintf($outhandle,
1145 "BasPlug: {BasPlug.could_not_extract_language}\n",
1146 $filename, $self->{'default_language'});
1147 }
1148 $best_language = $self->{'default_language'};
1149 $best_encoding = $self->{'input_encoding'};
1150
1151 } else {
1152 if ($self->{'verbosity'}>2) {
1153 gsprintf($outhandle,
1154 "BasPlug: {BasPlug.could_not_extract_language}\n",
1155 $filename, $self->{'default_language'});
1156 }
1157 $best_language = $self->{'default_language'};
1158 }
1159 } else { # <= 3 suggestions
1160 my ($language, $encoding) = $results->[0] =~ /^([^-]*)(?:-(.*))?$/;
1161 if (!defined $language) {
1162 if ($self->{'verbosity'}>2) {
1163 gsprintf($outhandle,
1164 "BasPlug: {BasPlug.could_not_extract_language}\n",
1165 $filename, $self->{'default_language'});
1166 }
1167 $language = $self->{'default_language'};
1168 }
1169 if (!defined $encoding) {
1170 if ($self->{'verbosity'}>2) {
1171 gsprintf($outhandle,
1172 "BasPlug: {BasPlug.could_not_extract_encoding}\n",
1173 $filename, $self->{'default_encoding'});
1174 }
1175 $encoding = $self->{'default_encoding'};
1176 }
1177 $best_language = $language;
1178 if (! $best_encoding ) { # may already be set... eg from html meta tag
1179 $best_encoding = $encoding;
1180 }
1181 }
1182
1183 my $text_copy = $text;
1184 if ($best_encoding =~ /^iso_8859/ && unicode::ensure_utf8(\$text_copy)==0) {
1185 # the text is valid utf8, so assume that's the real encoding
1186 # (since textcat is based on probabilities)
1187 $best_encoding = 'utf8';
1188 }
1189
1190 # check for equivalents where textcat doesn't have some encodings...
1191 # eg MS versions of standard encodings
1192 if ($best_encoding =~ /^iso_8859_(\d+)/) {
1193 my $iso = $1; # which variant of the iso standard?
1194 # iso-8859 sets don't use chars 0x80-0x9f, windows codepages do
1195 if ($text =~ /[\x80-\x9f]/) {
1196 # Western Europe
1197 if ($iso == 1 or $iso == 15) { $best_encoding = 'windows_1252' }
1198 elsif ($iso == 2) {$best_encoding = 'windows_1250'} # Central Europe
1199 elsif ($iso == 5) {$best_encoding = 'windows_1251'} # Cyrillic
1200 elsif ($iso == 6) {$best_encoding = 'windows_1256'} # Arabic
1201 elsif ($iso == 7) {$best_encoding = 'windows_1253'} # Greek
1202 elsif ($iso == 8) {$best_encoding = 'windows_1255'} # Hebrew
1203 elsif ($iso == 9) {$best_encoding = 'windows_1254'} # Turkish
1204 }
1205 }
1206
1207 if ($best_encoding !~ /^(ascii|utf8|unicode)$/ &&
1208 !defined $encodings::encodings->{$best_encoding}) {
1209 if ($self->{'verbosity'}) {
1210 gsprintf($outhandle, "BasPlug: {BasPlug.unsupported_encoding}\n",
1211 $filename, $best_encoding, $self->{'default_encoding'});
1212 }
1213 $best_encoding = $self->{'default_encoding'};
1214 }
1215
1216 return ($best_language, $best_encoding);
1217}
1218
1219# add any extra metadata that's been passed around from one
1220# plugin to another.
1221# extra_metadata uses add_utf8_metadata so it expects metadata values
1222# to already be in utf8
1223sub extra_metadata {
1224 my $self = shift (@_);
1225 my ($doc_obj, $cursection, $metadata) = @_;
1226
1227 my $associate_tail_re = $self->{'associate_tail_re'};
1228
1229 foreach my $field (keys(%$metadata)) {
1230 # $metadata->{$field} may be an array reference
1231 if ($field eq "gsdlassocfile_tobe") {
1232 # 'gsdlassocfile_tobe' is artificially introduced metadata
1233 # that is used to signal that certain additional files should
1234 # be tied to this document. Useful in situations where a
1235 # metadata pass in the plugin pipeline works out some files
1236 # need to be associated with a document, but the document hasn't
1237 # been formed yet.
1238
1239 my $equiv_form = "";
1240 foreach my $gaf (@{$metadata->{$field}}) {
1241 my ($full_filename,$mimetype) = ($gaf =~ m/^(.*):(.*):$/);
1242 my ($tail_filename) = ($full_filename =~ /^.*[\/\\](.+?)$/);
1243 my $filename = $full_filename;
1244
1245 $doc_obj->associate_file($full_filename,$tail_filename,$mimetype);
1246
1247 # work out extended tail extension (i.e. matching tail re)
1248
1249 my ($file_prefix,$file_extended_ext)
1250 = $self->root_ext_split($tail_filename,$associate_tail_re);
1251 my ($pre_doc_ext) = ($file_extended_ext =~ m/^(.*)\..*$/);
1252
1253 my ($doc_ext) = ($tail_filename =~ m/^.*\.(.*)$/);
1254 my $start_doclink = "<a href=\"_httpprefix_/collect/[collection]/index/assoc/{Or}{[parent(Top):archivedir],[archivedir]}/$tail_filename\">";
1255 my $srcicon = "_icon".$doc_ext."_";
1256 my $end_doclink = "</a>";
1257
1258 my $assoc_form = "$start_doclink\{If\}{$srcicon,$srcicon,$doc_ext\}$end_doclink";
1259
1260 if (defined $pre_doc_ext) {
1261 # for metadata such as [mp3._edited] [mp3._full] ...
1262 $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.$pre_doc_ext", $assoc_form);
1263 }
1264
1265 # for multiple metadata such as [mp3.assoclink]
1266 $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.assoclink", $assoc_form);
1267
1268 $equiv_form .= " $assoc_form";
1269 }
1270 $doc_obj->add_utf8_metadata ($cursection, "equivlink", $equiv_form);
1271 }
1272 elsif (ref ($metadata->{$field}) eq "ARRAY") {
1273 map {
1274 $doc_obj->add_utf8_metadata ($cursection, $field, $_);
1275 } @{$metadata->{$field}};
1276 } else {
1277 $doc_obj->add_utf8_metadata ($cursection, $field, $metadata->{$field});
1278 }
1279 }
1280}
1281
1282# initialise metadata extractors
1283sub initialise_extractors {
1284 my $self = shift (@_);
1285
1286 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1287 &acronym::initialise_acronyms();
1288 }
1289}
1290
1291# finalise metadata extractors
1292sub finalise_extractors {
1293 my $self = shift (@_);
1294
1295 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1296 &acronym::finalise_acronyms();
1297 }
1298}
1299
1300# FIRSTNNN: extract the first NNN characters as metadata
1301sub extract_first_NNNN_characters {
1302 my $self = shift (@_);
1303 my ($textref, $doc_obj, $thissection) = @_;
1304
1305 foreach my $size (split /,/, $self->{'first'}) {
1306 my $tmptext = $$textref;
1307 $tmptext =~ s/^\s+//;
1308 $tmptext =~ s/\s+$//;
1309 $tmptext =~ s/\s+/ /gs;
1310 $tmptext = substr ($tmptext, 0, $size);
1311 $tmptext =~ s/\s\S*$/&#8230;/;
1312 $doc_obj->add_utf8_metadata ($thissection, "First$size", $tmptext);
1313 }
1314}
1315
1316sub extract_email {
1317 my $self = shift (@_);
1318 my ($textref, $doc_obj, $thissection) = @_;
1319 my $outhandle = $self->{'outhandle'};
1320
1321 gsprintf($outhandle, " {BasPlug.extracting_emails}...\n")
1322 if ($self->{'verbosity'} > 2);
1323
1324 my @email = ($$textref =~ m/([-a-z0-9\.@+_=]+@(?:[-a-z0-9]+\.)+(?:com|org|edu|mil|int|net|[a-z][a-z]))/g);
1325 @email = sort @email;
1326
1327# if($self->{"new_extract_email"} == 0)
1328# {
1329# my @email2 = ();
1330# foreach my $address (@email)
1331# {
1332# if (!(join(" ",@email2) =~ m/(^| )$address( |$)/ ))
1333# {
1334# push @email2, $address;
1335# $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1336# # print $outhandle " extracting $address\n"
1337# &gsprintf($outhandle, " {BasPlug.extracting} $address\n")
1338# if ($self->{'verbosity'} > 3);
1339# }
1340# }
1341# }
1342# else
1343# {
1344 my $hashExistMail = {};
1345 foreach my $address (@email) {
1346 if (!(defined $hashExistMail->{$address}))
1347 {
1348 $hashExistMail->{$address} = 1;
1349 $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1350 gsprintf($outhandle, " {BasPlug.extracting} $address\n")
1351 if ($self->{'verbosity'} > 3);
1352 }
1353 }
1354 gsprintf($outhandle, " {BasPlug.done_email_extract}\n")
1355 if ($self->{'verbosity'} > 2);
1356}
1357
1358# extract metadata
1359sub auto_extract_metadata {
1360
1361 my $self = shift (@_);
1362 my ($doc_obj) = @_;
1363
1364 if ($self->{'extract_email'}) {
1365 my $thissection = $doc_obj->get_top_section();
1366 while (defined $thissection) {
1367 my $text = $doc_obj->get_text($thissection);
1368 $self->extract_email (\$text, $doc_obj, $thissection) if $text =~ /./;
1369 $thissection = $doc_obj->get_next_section ($thissection);
1370 }
1371 }
1372 if ($self->{'extract_placenames'}) {
1373 my $thissection = $doc_obj->get_top_section();
1374 while (defined $thissection) {
1375 my $text = $doc_obj->get_text($thissection);
1376 $self->extract_placenames (\$text, $doc_obj, $thissection) if $text =~ /./;
1377 $thissection = $doc_obj->get_next_section ($thissection);
1378 }
1379 }
1380
1381 if ($self->{'extract_keyphrases'} || $self->{'extract_keyphrases_kea4'}) {
1382 $self->extract_keyphrases($doc_obj);
1383 }
1384
1385 if ($self->{'first'}) {
1386 my $thissection = $doc_obj->get_top_section();
1387 while (defined $thissection) {
1388 my $text = $doc_obj->get_text($thissection);
1389 $self->extract_first_NNNN_characters (\$text, $doc_obj, $thissection) if $text =~ /./;
1390 $thissection = $doc_obj->get_next_section ($thissection);
1391 }
1392 }
1393
1394 if ($self->{'extract_acronyms'}) {
1395 my $thissection = $doc_obj->get_top_section();
1396 while (defined $thissection) {
1397 my $text = $doc_obj->get_text($thissection);
1398 $self->extract_acronyms (\$text, $doc_obj, $thissection) if $text =~ /./;
1399 $thissection = $doc_obj->get_next_section ($thissection);
1400 }
1401 }
1402
1403 if ($self->{'markup_acronyms'}) {
1404 my $thissection = $doc_obj->get_top_section();
1405 while (defined $thissection) {
1406 my $text = $doc_obj->get_text($thissection);
1407 $text = $self->markup_acronyms ($text, $doc_obj, $thissection);
1408 $doc_obj->delete_text($thissection);
1409 $doc_obj->add_text($thissection, $text);
1410 $thissection = $doc_obj->get_next_section ($thissection);
1411 }
1412 }
1413
1414 if($self->{'extract_historical_years'}) {
1415 my $thissection = $doc_obj->get_top_section();
1416 while (defined $thissection) {
1417
1418 my $text = $doc_obj->get_text($thissection);
1419 &DateExtract::get_date_metadata($text, $doc_obj,
1420 $thissection,
1421 $self->{'no_bibliography'},
1422 $self->{'maximum_year'},
1423 $self->{'maximum_century'});
1424 $thissection = $doc_obj->get_next_section ($thissection);
1425 }
1426 }
1427}
1428
1429
1430#adding kea keyphrases
1431sub extract_keyphrases
1432{
1433 my $self = shift(@_);
1434 my $doc_obj = shift(@_);
1435
1436 # Use Kea 3.0 unless 4.0 has been specified
1437 my $kea_version = "3.0";
1438 if ($self->{'extract_keyphrases_kea4'}) {
1439 $kea_version = "4.0";
1440 }
1441
1442 # Check that Kea exists, and tell the user where to get it if not
1443 my $keahome = &Kea::get_Kea_directory($kea_version);
1444 if (!-e $keahome) {
1445 gsprintf(STDERR, "{BasPlug.missing_kea}\n", $keahome, $kea_version);
1446 return;
1447 }
1448
1449 my $thissection = $doc_obj->get_top_section();
1450 my $text = "";
1451 my $list;
1452
1453 #loop through sections to gather whole doc
1454 while (defined $thissection) {
1455 my $sectiontext = $doc_obj->get_text($thissection);
1456 $text = $text.$sectiontext;
1457 $thissection = $doc_obj->get_next_section ($thissection);
1458 }
1459
1460 if($self->{'extract_keyphrase_options'}) { #if kea options flag is set, call Kea with specified options
1461 $list = &Kea::extract_KeyPhrases ($kea_version, $text, $self->{'extract_keyphrase_options'});
1462 } else { #otherwise call Kea with no options
1463 $list = &Kea::extract_KeyPhrases ($kea_version, $text);
1464 }
1465
1466 if ($list){
1467 # if a list of kea keyphrases was returned (ie not empty)
1468 if ($self->{'verbosity'}) {
1469 gsprintf(STDERR, "{BasPlug.keyphrases}: $list\n");
1470 }
1471
1472 #add metadata to top section
1473 $thissection = $doc_obj->get_top_section();
1474
1475 # add all key phrases as one metadata
1476 $doc_obj->add_metadata($thissection, "Keyphrases", $list);
1477
1478 # add individual key phrases as multiple metadata
1479 foreach my $keyphrase (split(',', $list)) {
1480 $keyphrase =~ s/^\s+|\s+$//g;
1481 $doc_obj->add_metadata($thissection, "Keyphrase", $keyphrase);
1482 }
1483 }
1484}
1485
1486
1487# extract acronyms from a section in a document. progress is
1488# reported to outhandle based on the verbosity. both the Acronym
1489# and the AcronymKWIC metadata items are created.
1490
1491sub extract_acronyms {
1492 my $self = shift (@_);
1493 my ($textref, $doc_obj, $thissection) = @_;
1494 my $outhandle = $self->{'outhandle'};
1495
1496 # print $outhandle " extracting acronyms ...\n"
1497 gsprintf($outhandle, " {BasPlug.extracting_acronyms}...\n")
1498 if ($self->{'verbosity'} > 2);
1499
1500 my $acro_array = &acronym::acronyms($textref);
1501
1502 foreach my $acro (@$acro_array) {
1503
1504 #check that this is the first time ...
1505 my $seen_before = "false";
1506 my $previous_data = $doc_obj->get_metadata($thissection, "Acronym");
1507 foreach my $thisAcro (@$previous_data) {
1508 if ($thisAcro eq $acro->to_string()) {
1509 $seen_before = "true";
1510 if ($self->{'verbosity'} >= 4) {
1511 gsprintf($outhandle, " {BasPlug.already_seen} " .
1512 $acro->to_string() . "\n");
1513 }
1514 }
1515 }
1516
1517 if ($seen_before eq "false") {
1518 #write it to the file ...
1519 $acro->write_to_file();
1520
1521 #do the normal acronym
1522 $doc_obj->add_utf8_metadata($thissection, "Acronym", $acro->to_string());
1523 gsprintf($outhandle, " {BasPlug.adding} ".$acro->to_string()."\n")
1524 if ($self->{'verbosity'} > 3);
1525 }
1526 }
1527
1528 gsprintf($outhandle, " {BasPlug.done_acronym_extract}\n")
1529 if ($self->{'verbosity'} > 2);
1530}
1531
1532sub markup_acronyms {
1533 my $self = shift (@_);
1534 my ($text, $doc_obj, $thissection) = @_;
1535 my $outhandle = $self->{'outhandle'};
1536
1537 gsprintf($outhandle, " {BasPlug.marking_up_acronyms}...\n")
1538 if ($self->{'verbosity'} > 2);
1539
1540 #self is passed in to check for verbosity ...
1541 $text = &acronym::markup_acronyms($text, $self);
1542
1543 gsprintf($outhandle, " {BasPlug.done_acronym_markup}\n")
1544 if ($self->{'verbosity'} > 2);
1545
1546 return $text;
1547}
1548
1549sub compile_stats {
1550 my $self = shift(@_);
1551 my ($stats) = @_;
1552
1553 $stats->{'num_processed'} += $self->{'num_processed'};
1554 $stats->{'num_not_processed'} += $self->{'num_not_processed'};
1555 $stats->{'num_archives'} += $self->{'num_archives'};
1556
1557}
1558
1559sub associate_cover_image {
1560 my $self = shift;
1561 my ($doc_obj, $filename) = @_;
1562
1563 $filename =~ s/\.[^\\\/\.]+$/\.jpg/;
1564 if (exists $self->{'covers_missing_cache'}->{$filename}) {
1565 # don't stat() for existence eg for multiple document input files
1566 # (eg SplitPlug)
1567 return;
1568 }
1569
1570 my $top_section=$doc_obj->get_top_section();
1571
1572 if (-e $filename) {
1573 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1574 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1575 } else {
1576 my $upper_filename = $filename;
1577 $upper_filename =~ s/jpg$/JPG/;
1578 if (-e $upper_filename) {
1579 $doc_obj->associate_file($upper_filename, "cover.jpg",
1580 "image/jpeg");
1581 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1582 } else {
1583 # file doesn't exist, so record the fact that it's missing so
1584 # we don't stat() again (stat is slow)
1585 $self->{'covers_missing_cache'}->{$filename} = 1;
1586 }
1587 }
1588
1589}
1590
1591
1592# Overridden by exploding plugins (eg. ISISPlug)
1593sub clean_up_after_exploding
1594{
1595 my $self = shift(@_);
1596}
1597
1598
15991;
Note: See TracBrowser for help on using the repository browser.