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

Last change on this file since 9144 was 9067, checked in by kjdon, 19 years ago

moved smart blocking stuff in htmlplug metadata_read into basplug metadata read. htmlplug now just needs to implement store_block_files. basplug smart block will block a cover image if -cover_images is on. Converttoplug store_block_files needs to call the basplug default one (do nothing) cos it doesn't want to use the html specific one. Image plug needs to implement store_cover_image to do nothing cos it doesn'tmake sense
  • Property svn:keywords set to Author Date Id Revision
File size: 37.4 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 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
28eval {require bytes};
29
30# suppress the annoying "subroutine redefined" warning that various
31# plugins cause under perl 5.6
32$SIG{__WARN__} = sub {warn($_[0]) unless ($_[0] =~ /Subroutine\s+\S+\sredefined/)};
33
34use File::Basename;
35
36use Kea;
37use parsargv;
38use multiread;
39use encodings;
40use cnseg;
41use acronym;
42use textcat;
43use doc;
44eval "require diagnostics"; # some perl distros (eg mac) don't have this
45use DateExtract;
46use ghtml;
47use gsprintf;
48use printusage;
49
50
51my $unicode_list =
52 [ { 'name' => "auto",
53 'desc' => "{BasPlug.input_encoding.auto}" },
54 { 'name' => "ascii",
55 'desc' => "{BasPlug.input_encoding.ascii}" },
56 { 'name' => "utf8",
57 'desc' => "{BasPlug.input_encoding.utf8}" },
58 { 'name' => "unicode",
59 'desc' => "{BasPlug.input_encoding.unicode}" } ];
60
61my $arguments =
62 [ { 'name' => "process_exp",
63 'desc' => "{BasPlug.process_exp}",
64 'type' => "regexp",
65 'deft' => "",
66 'reqd' => "no" },
67 { 'name' => "block_exp",
68 'desc' => "{BasPlug.block_exp}",
69 'type' => "regexp",
70 'deft' => "",
71 'reqd' => "no" },
72 { 'name' => "smart_block",
73 'desc' => "{BasPlug.smart_block}",
74 'type' => "flag",
75 'reqd' => "no" },
76 { 'name' => "associate_ext",
77 'desc' => "{BasPlug.associate_ext}",
78 'type' => "string",
79 'reqd' => "no" },
80 { 'name' => "input_encoding",
81 'desc' => "{BasPlug.input_encoding}",
82 'type' => "enum",
83 'list' => $unicode_list,
84 'reqd' => "no" ,
85 'deft' => "auto" } ,
86 { 'name' => "default_encoding",
87 'desc' => "{BasPlug.default_encoding}",
88 'type' => "enum",
89 'list' => $unicode_list,
90 'reqd' => "no",
91 'deft' => "utf8" },
92 { 'name' => "extract_language",
93 'desc' => "{BasPlug.extract_language}",
94 'type' => "flag",
95 'reqd' => "no" },
96 { 'name' => "default_language",
97 'desc' => "{BasPlug.default_language}",
98 'type' => "language",
99 'deft' => "en",
100 'reqd' => "no" },
101 { 'name' => "extract_acronyms",
102 'desc' => "{BasPlug.extract_acronyms}",
103 'type' => "flag",
104 'reqd' => "no" },
105 { 'name' => "markup_acronyms",
106 'desc' => "{BasPlug.markup_acronyms}",
107 'type' => "flag",
108 'reqd' => "no" },
109 { 'name' => "extract_keyphrases",
110 'desc' => "{BasPlug.extract_keyphrases}",
111 'type' => "flag",
112 'reqd' => "no" },
113 { 'name' => "extract_keyphrase_options",
114 'desc' => "{BasPlug.extract_keyphrase_options}",
115 'type' => "string",
116 'deft' => "",
117 'reqd' => "no" },
118 { 'name' => "first",
119 'desc' => "{BasPlug.first}",
120 'type' => "string",
121 'reqd' => "no" },
122 { 'name' => "extract_email",
123 'desc' => "{BasPlug.extract_email}",
124 'type' => "flag",
125 'reqd' => "no" },
126 { 'name' => "extract_historical_years",
127 'desc' => "{BasPlug.extract_historical_years}",
128 'type' => "flag",
129 'reqd' => "no" },
130 { 'name' => "maximum_year",
131 'desc' => "{BasPlug.maximum_year}",
132 'type' => "int",
133 'deft' => (localtime)[5]+1900,
134 'reqd' => "no"},
135 { 'name' => "maximum_century",
136 'desc' => "{BasPlug.maximum_century}",
137 'type' => "string",
138 'deft' => "",
139 'reqd' => "no" },
140 { 'name' => "no_bibliography",
141 'desc' => "{BasPlug.no_bibliography}",
142 'type' => "flag",
143 'reqd' => "no"},
144 { 'name' => "no_cover_image",
145 'desc' => "{BasPlug.no_cover_image}",
146 'type' => "flag",
147 'reqd' => "no" } ];
148
149my $options = { 'name' => "BasPlug",
150 'desc' => "{BasPlug.desc}",
151 'abstract' => "yes",
152 'inherits' => "no",
153 'args' => $arguments };
154
155
156sub gsprintf
157{
158 return &gsprintf::gsprintf(@_);
159}
160
161
162sub get_arguments
163{
164 my $self = shift(@_);
165 my $optionlistref = $self->{'option_list'};
166 my @optionlist = @$optionlistref;
167 my $pluginoptions = pop(@$optionlistref);
168 my $pluginarguments = $pluginoptions->{'args'};
169 return $pluginarguments;
170}
171
172
173sub print_xml_usage
174{
175 my $self = shift(@_);
176
177 # XML output is always in UTF-8
178 &gsprintf::output_strings_in_UTF8;
179
180 &PrintUsage::print_xml_header();
181 $self->print_xml();
182}
183
184
185sub print_xml
186{
187 my $self = shift(@_);
188
189 my $optionlistref = $self->{'option_list'};
190 my @optionlist = @$optionlistref;
191 my $pluginoptions = pop(@$optionlistref);
192 return if (!defined($pluginoptions));
193
194 &gsprintf(STDERR, "<PlugInfo>\n");
195 &gsprintf(STDERR, " <Name>$pluginoptions->{'name'}</Name>\n");
196 my $desc = &gsprintf::lookup_string($pluginoptions->{'desc'});
197 $desc =~ s/</&amp;lt;/g; # doubly escaped
198 $desc =~ s/>/&amp;gt;/g;
199
200 &gsprintf(STDERR, " <Desc>$desc</Desc>\n");
201 &gsprintf(STDERR, " <Abstract>$pluginoptions->{'abstract'}</Abstract>\n");
202 &gsprintf(STDERR, " <Inherits>$pluginoptions->{'inherits'}</Inherits>\n");
203 &gsprintf(STDERR, " <Explodes>" . ($pluginoptions->{'explodes'} || "no") . "</Explodes>\n");
204 &gsprintf(STDERR, " <Arguments>\n");
205 if (defined($pluginoptions->{'args'})) {
206 &PrintUsage::print_options_xml($pluginoptions->{'args'});
207 }
208
209 # Recurse up the plugin hierarchy
210 $self->print_xml();
211
212 &gsprintf(STDERR, " </Arguments>\n");
213 &gsprintf(STDERR, "</PlugInfo>\n");
214}
215
216
217sub print_txt_usage
218{
219 my $self = shift(@_);
220
221 # Print the usage message for a plugin (recursively)
222 my $descoffset = $self->determine_description_offset(0);
223 $self->print_plugin_usage($descoffset, 1);
224}
225
226
227sub determine_description_offset
228{
229 my $self = shift(@_);
230 my $maxoffset = shift(@_);
231
232 my $optionlistref = $self->{'option_list'};
233 my @optionlist = @$optionlistref;
234 my $pluginoptions = pop(@$optionlistref);
235 return $maxoffset if (!defined($pluginoptions));
236
237 # Find the length of the longest option string of this plugin
238 my $pluginargs = $pluginoptions->{'args'};
239 if (defined($pluginargs)) {
240 my $longest = &PrintUsage::find_longest_option_string($pluginargs);
241 if ($longest > $maxoffset) {
242 $maxoffset = $longest;
243 }
244 }
245
246 # Recurse up the plugin hierarchy
247 $maxoffset = $self->determine_description_offset($maxoffset);
248 $self->{'option_list'} = \@optionlist;
249 return $maxoffset;
250}
251
252
253sub print_plugin_usage
254{
255 my $self = shift(@_);
256 my $descoffset = shift(@_);
257 my $isleafclass = shift(@_);
258
259 my $optionlistref = $self->{'option_list'};
260 my @optionlist = @$optionlistref;
261 my $pluginoptions = pop(@$optionlistref);
262 return if (!defined($pluginoptions));
263
264 my $pluginname = $pluginoptions->{'name'};
265 my $pluginargs = $pluginoptions->{'args'};
266 my $plugindesc = $pluginoptions->{'desc'};
267
268 # Produce the usage information using the data structure above
269 if ($isleafclass) {
270 if (defined($plugindesc)) {
271 &gsprintf(STDERR, "$plugindesc\n\n");
272 }
273 &gsprintf(STDERR, " {common.usage}: plugin $pluginname [{common.options}]\n\n");
274 }
275
276 # Display the plugin options, if there are some
277 if (defined($pluginargs)) {
278 # Calculate the column offset of the option descriptions
279 my $optiondescoffset = $descoffset + 2; # 2 spaces between options & descriptions
280
281 if ($isleafclass) {
282 &gsprintf(STDERR, " {common.specific_options}:\n");
283 }
284 else {
285 &gsprintf(STDERR, " {common.general_options}:\n", $pluginname);
286 }
287
288 # Display the plugin options
289 &PrintUsage::print_options_txt($pluginargs, $optiondescoffset);
290 }
291
292 # Recurse up the plugin hierarchy
293 $self->print_plugin_usage($descoffset, 0);
294 $self->{'option_list'} = \@optionlist;
295}
296
297
298sub new {
299 my $class = shift (@_);
300 my $plugin_name = shift (@_);
301 my $self = {};
302 $self->{'plugin_type'} = "BasPlug";
303 my $enc = "^(";
304 map {$enc .= "$_|";} keys %$encodings::encodings;
305 my $denc = $enc . "ascii|utf8|unicode)\$";
306 $enc .= "ascii|utf8|unicode|auto)\$";
307
308 $self->{'outhandle'} = STDERR;
309 my $year = (localtime)[5]+1900;
310
311 $self->{'textcat'} = new textcat();
312
313 $self->{'num_processed'} = 0;
314 $self->{'num_not_processed'} = 0;
315 $self->{'num_blocked'} = 0;
316 $self->{'num_archives'} = 0;
317 $self->{'cover_image'} = 1; # cover image is on by default
318
319 # 14-05-02 To allow for proper inheritance of arguments - John Thompson
320 $self->{'option_list'} = [ $options ];
321
322 my $no_cover_image = 0;
323 # general options available to all plugins
324 if (!parsargv::parse(\@_,
325 q^process_exp/.*/^, \$self->{'process_exp'},
326 q^block_exp/.*/^, \$self->{'block_exp'},
327 q^associate_ext/.*/^, \$self->{'associate_ext'},
328 q^extract_language^, \$self->{'extract_language'},
329 q^extract_acronyms^, \$self->{'extract_acronyms'},
330 q^extract_keyphrases^, \$self->{'kea'},
331 q^extract_keyphrase_options/.*/^, \$self->{'kea_options'},
332 qq^input_encoding/$enc/auto^, \$self->{'input_encoding'},
333 qq^default_encoding/$denc/utf8^, \$self->{'default_encoding'},
334 q^extract_email^, \$self->{'extract_email'},
335 q^markup_acronyms^, \$self->{'markup_acronyms'},
336 q^default_language/.{2}/en^, \$self->{'default_language'},
337 q^first/.*/^, \$self->{'first'},
338 q^extract_historical_years^, \$self->{'date_extract'},
339 qq^maximum_year/\\d{4}/$year^, \$self->{'max_year'},
340 q^no_bibliography^, \$self->{'no_biblio'},
341 qq^maximum_century/-?\\d{1,2}( ?B\\.C\\.E\\.)?/-1^, \$self->{'max_century'},
342 q^no_cover_image^, \$no_cover_image,
343 q^separate_cjk^, \$self->{'separate_cjk'},
344 q^smart_block^, \$self->{'smart_block'},
345 q^smart_block_BN^, \$self->{'smart_block_BN'},
346 "allow_extra_options")) {
347
348 &gsprintf(STDERR, "\n{BasPlug.bad_general_option}\n", $plugin_name);
349 $self->print_txt_usage(""); # Use default resource bundle
350 die "\n";
351 }
352
353 my $associate_ext = $self->{'associate_ext'};
354 if ((defined $associate_ext) && ($associate_ext ne "")) {
355 my @exts = split(/,/,$associate_ext);
356
357 my %associate_ext_lookup = ();
358 foreach my $e (@exts) {
359 $assoicate_ext_lookup{$e} = 1;
360 }
361
362 $self->{'associate_ext_lookup'} = \%associate_ext_lookup;
363 }
364
365 $self->{'shared_fileroot'} = {};
366 $self->{'file_blocks'} = {};
367
368 $self->{'cover_image'} = 0 if ($no_cover_image);
369
370 return bless $self, $class;
371}
372
373# initialize BasPlug options
374# if init() is overridden in a sub-class, remember to call BasPlug::init()
375sub init {
376 my $self = shift (@_);
377 my ($verbosity, $outhandle, $failhandle) = @_;
378
379 # verbosity is passed through from the processor
380 $self->{'verbosity'} = $verbosity;
381
382 # as are the outhandle and failhandle
383 $self->{'outhandle'} = $outhandle if defined $outhandle;
384 $self->{'failhandle'} = $failhandle;
385
386 # set process_exp and block_exp to defaults unless they were
387 # explicitly set
388
389 if ((!$self->is_recursive()) and
390 (!defined $self->{'process_exp'}) || ($self->{'process_exp'} eq "")) {
391
392 $self->{'process_exp'} = $self->get_default_process_exp ();
393 if ($self->{'process_exp'} eq "") {
394 warn ref($self) . " Warning: Non-recursive plugin has no process_exp\n";
395 }
396 }
397
398 if ((!defined $self->{'block_exp'}) || ($self->{'block_exp'} eq "")) {
399 $self->{'block_exp'} = $self->get_default_block_exp ();
400 }
401}
402
403sub begin {
404 my $self = shift (@_);
405 my ($pluginfo, $base_dir, $processor, $maxdocs) = @_;
406 $self->initialise_extractors();
407}
408
409sub end {
410 my ($self) = @_;
411 $self->finalise_extractors();
412}
413
414# this function should be overridden to return 1
415# in recursive plugins
416sub is_recursive {
417 my $self = shift (@_);
418
419 return 0;
420}
421
422sub get_default_block_exp {
423 my $self = shift (@_);
424
425 return "";
426}
427
428sub get_default_process_exp {
429 my $self = shift (@_);
430
431 return "";
432}
433
434# default implementation is to do nothing.
435sub store_block_files
436{
437 my $self =shift (@_);
438 my ($filename) = @_;
439 return;
440}
441
442#default implementation is to block a file with same name as this, but extension jpg or JPG, if cover_images is on.
443sub block_cover_image
444{
445 my $self =shift (@_);
446 my ($filename) = @_;
447 if ($self->{'cover_image'}) {
448 my $coverfile = $filename;
449 $coverfile =~ s/\.[^\\\/\.]+$/\.jpg/;
450 if (!-e $coverfile) {
451 $coverfile =~ s/jpg$/JPG/;
452 }
453 if (-e $coverfile) {
454 $self->{'file_blocks'}->{$coverfile} = 1;
455 }
456 }
457
458 return;
459}
460
461sub metadata_read {
462 my $self = shift (@_);
463 my ($pluginfo, $base_dir, $file, $metadata, $extrametakeys, $extrametadata, $processor, $maxdocs, $gli) = @_;
464 # Keep track of filenames with same root but different extensions
465 # Used to support -associate_ext
466
467 my $associate_ext = $self->{'associate_ext'};
468 if ((defined $associate_ext) && ($associate_ext ne "")) {
469
470 my ($file_prefix,$file_ext) = ($file =~ m/^(.*)\.(.*?)$/);
471 if ((defined $file_prefix) && (defined $file_ext)) {
472
473 my $shared_fileroot = $self->{'shared_fileroot'};
474 if (!defined $shared_fileroot->{$file_prefix}) {
475 my $file_prefix_rec = { 'tie_to' => undef, 'exts' => {} };
476 $shared_fileroot->{$file_prefix} = $file_prefix_rec;
477 }
478
479 my $file_prefix_rec = $shared_fileroot->{$file_prefix};
480
481 my $process_exp = $self->{'process_exp'};
482
483 if ($file =~ m/$self->{'process_exp'}/) {
484 # This is the document the others should be tied to
485 $file_prefix_rec->{'tie_to'} = $file_ext;
486 }
487 else {
488 $file_prefix_rec->{'exts'}->{$file_ext} = 1;
489 }
490 }
491 }
492
493 # now check whether we are actually processing this
494 my $filename = $file;
495 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
496 if ($self->{'process_exp'} eq "" || $filename !~ /$self->{'process_exp'}/ || !-f $filename) {
497 return undef; # can't recognise
498 }
499
500 # do smart blocking if appropriate
501 if (defined $self->{'smart_block'}) {
502 $self->block_cover_image($filename);
503 $self->store_block_files($filename);
504 }
505
506 return 1;
507}
508
509sub tie_to_filename
510{
511 my $self = shift (@_);
512
513 my ($file_ext,$file_prefix_rec) = @_;
514
515 if (defined $file_prefix_rec) {
516 my $tie_to = $file_prefix_rec->{'tie_to'};
517 if (defined $tie_to) {
518 if ($tie_to eq $file_ext) {
519 return 1;
520 }
521 }
522 }
523
524 return 0;
525}
526
527sub tie_to_assoc_file
528{
529 my $self = shift (@_);
530 my ($file_ext,$file_prefix_rec) = @_;
531
532 if (defined $file_prefix_rec) {
533 my $tie_to = $file_prefix_rec->{'tie_to'};
534 if (defined $tie_to) {
535
536 my $exts = $file_prefix_rec->{'exts'};
537
538 my $has_file_ext = $exts->{$file_ext};
539
540 if ($has_file_ext) {
541 return 1;
542 }
543 }
544 }
545
546 return 0;
547}
548
549
550sub associate_with
551{
552 my $self = shift (@_);
553 my ($file, $filename, $metadata) = @_;
554
555 my $associate_ext = $self->{'associate_ext'};
556
557 return 0 if (!$associate_ext);
558
559 # If file, see if matches with "tie_to" doc or is one of the
560 # associated filename extensions.
561
562 my ($file_prefix,$file_ext) = ($file =~ m/^(.*)\.(.*?)$/);
563 if ((defined $file_prefix) && (defined $file_ext)) {
564
565 my $file_prefix_rec = $self->{'shared_fileroot'}->{$file_prefix};
566
567 if ($self->tie_to_filename($file_ext,$file_prefix_rec)) {
568
569 # Set up gsdlassocfile_tobe
570
571 my $exts = $file_prefix_rec->{'exts'};
572
573 if (!defined $metadata->{'gsdlassocfile_tobe'}) {
574 $metadata->{'gsdlassocfile_tobe'} = [];
575 }
576
577 my $assoc_tobe = $metadata->{'gsdlassocfile_tobe'};
578
579 my ($full_prefix) = ($filename =~ m/^(.*)\..*?$/);
580 foreach my $e (keys %$exts) {
581 my $assoc_file = "$full_prefix.$e";
582 my $mime_type = ""; # let system auto detect this
583 push(@$assoc_tobe,"$assoc_file:$mime_type:");
584 }
585 }
586 elsif ($self->tie_to_assoc_file($file_ext,$file_prefix_rec)) {
587 # a form of smart block
588
589 return 1;
590 }
591 }
592
593 return 0;
594}
595
596
597# The BasPlug read() function. This function does all the right things
598# to make general options work for a given plugin. It calls the process()
599# function which does all the work specific to a plugin (like the old
600# read functions used to do). Most plugins should define their own
601# process() function and let this read() function keep control.
602#
603# recursive plugins (e.g. RecPlug) and specialized plugins like those
604# capable of processing many documents within a single file (e.g.
605# GMLPlug) should normally implement their own version of read()
606#
607# Return number of files processed, undef if can't recognise, -1 if can't
608# process
609# Note that $base_dir might be "" and that $file might
610# include directories
611
612sub read {
613 my $self = shift (@_);
614
615 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $gli) = @_;
616
617 if ($self->is_recursive()) {
618 &gsprintf(STDERR, "{BasPlug.read_must_be_implemented}") && die "\n";
619 }
620
621 my $outhandle = $self->{'outhandle'};
622 my $smart_block = $self->{'smart_block'};
623 my $smart_block_BN = $self->{'smart_block_BN'};
624
625 my $filename = $file;
626 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
627
628 if ($self->associate_with($file,$filename,$metadata)) {
629 # a form of smart block
630 $self->{'num_blocked'} ++;
631 return 0; # blocked
632 }
633
634 if ($smart_block || $smart_block_BN) {
635 if (defined $self->{'file_blocks'}->{$filename} && $self->{'file_blocks'}->{$filename} == 1){
636 $self->{'num_blocked'} ++;
637 return 0; # blocked
638 }
639 } elsif ($self->{'block_exp'} ne "" && $filename =~ /$self->{'block_exp'}/) {
640 $self->{'num_blocked'} ++;
641 return 0; # blocked
642 }
643
644 if ($filename !~ /$self->{'process_exp'}/ || !-f $filename) {
645 return undef; # can't recognise
646 }
647 $file =~ s/^[\/\\]+//; # $file often begins with / so we'll tidy it up
648
649 # Do encoding stuff
650 my ($language, $encoding) = $self->textcat_get_language_encoding ($filename);
651
652 # create a new document
653 my $doc_obj = new doc ($filename, "indexed_doc");
654 $doc_obj->set_OIDtype ($processor->{'OIDtype'});
655 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Language", $language);
656 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Encoding", $encoding);
657 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Plugin", "$self->{'plugin_type'}");
658 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "FileSize", (-s $filename));
659
660 my ($filemeta) = $file =~ /([^\\\/]+)$/;
661
662 # how do we know what encoding the filename is in?
663 $doc_obj->add_metadata($doc_obj->get_top_section(), "Source", &ghtml::dmsafe($filemeta));
664 if ($self->{'cover_image'}) {
665 $self->associate_cover_image($doc_obj, $filename);
666 }
667
668 # read in file ($text will be in utf8)
669 my $text = "";
670 $self->read_file ($filename, $encoding, $language, \$text);
671
672 if (!length ($text)) {
673 my $plugin_name = ref ($self);
674 &gsprintf($outhandle, "$plugin_name: {BasPlug.file_has_no_text}\n", $filename) if $self->{'verbosity'};
675
676 my $failhandle = $self->{'failhandle'};
677 &gsprintf($failhandle, "$file: " . ref($self) . ": {BasPlug.empty_file}\n");
678 # print $failhandle "$file: " . ref($self) . ": file contains no text\n";
679 $self->{'num_not_processed'} ++;
680
681 return 0; # what should we return here?? error but don't want to pass it on
682 }
683
684 # include any metadata passed in from previous plugins
685 # note that this metadata is associated with the top level section
686
687 $self->extra_metadata ($doc_obj, $doc_obj->get_top_section(), $metadata);
688
689 # do plugin specific processing of doc_obj
690 unless (defined ($self->process (\$text, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli))) {
691 $text = '';
692 undef $text;
693 return -1;
694 }
695 $text='';
696 undef $text;
697
698 # do any automatic metadata extraction
699 $self->auto_extract_metadata ($doc_obj);
700
701 # add an OID
702 # see if there is a plugin-specific set_OID function...
703 if (defined ($self->can('set_OID'))) {
704 # it will need $doc_obj to set the Identifier metadata...
705 $self->set_OID($doc_obj);
706 } else {
707 # use the default set_OID() in doc.pm
708 $doc_obj->set_OID();
709 }
710
711 # process the document
712 $processor->process($doc_obj);
713
714 $self->{'num_processed'} ++;
715 undef $doc_obj;
716 return 1; # processed the file
717}
718
719# returns undef if file is rejected by the plugin
720sub process {
721 my $self = shift (@_);
722 my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj) = @_;
723
724 &gsprintf(STDERR, "BasPlug::process {common.must_be_implemented}\n") && die "\n";
725 # die "Basplug::process function must be implemented in sub-class\n";
726
727 return undef; # never gets here
728}
729
730# uses the multiread package to read in the entire file pointed to
731# by filename and loads the resulting text into $$textref. Input text
732# may be in any of the encodings handled by multiread, output text
733# will be in utf8
734sub read_file {
735 my $self = shift (@_);
736 my ($filename, $encoding, $language, $textref) = @_;
737
738 if (!-r $filename)
739 {
740 my $outhandle = $self->{'outhandle'};
741 &gsprintf($outhandle, "{BasPlug.read_denied}\n", $filename) if $self->{'verbosity'};
742 # print $outhandle "Read permission denied for $filename\n" if $self->{'verbosity'};
743 return;
744 }
745
746 $$textref = "";
747
748 open (FILE, $filename) || (&gsprintf(STDERR, "BasPlug::read_file {BasPlug.could_not_open_for_reading} ($!)\n", $filename) && die "\n");
749 # open (FILE, $filename) || die "BasPlug::read_file could not open $filename for reading ($!)\n";
750
751 if ($encoding eq "ascii") {
752 undef $/;
753 $$textref = <FILE>;
754 $/ = "\n";
755 } else {
756 my $reader = new multiread();
757 $reader->set_handle ('BasPlug::FILE');
758 $reader->set_encoding ($encoding);
759 $reader->read_file ($textref);
760
761 #Now segments chinese if the separate_cjk option is set
762 if ($self->{'separate_cjk'}) {
763 # segment the Chinese words
764 $$textref = &cnseg::segment($$textref);
765 }
766 }
767
768 close FILE;
769}
770
771sub filename_based_title
772{
773 my $self = shift (@_);
774 my ($file) = @_;
775
776 my $file_derived_title = $file;
777 $file_derived_title =~ s/_/ /g;
778 $file_derived_title =~ s/\..*?$//;
779
780 return $file_derived_title;
781}
782
783sub title_fallback
784{
785 my $self = shift (@_);
786 my ($doc_obj,$section,$file) = @_;
787
788 if (!defined $doc_obj->get_metadata_element ($section, "Title")) {
789
790 my $file_derived_title = $self->filename_based_title($file);
791 $doc_obj->add_metadata ($section, "Title", $file_derived_title);
792 }
793}
794
795sub textcat_get_language_encoding {
796 my $self = shift (@_);
797 my ($filename) = @_;
798
799 my ($language, $encoding, $extracted_encoding);
800 if ($self->{'input_encoding'} eq "auto") {
801 # use textcat to automatically work out the input encoding and language
802 ($language, $encoding) = $self->get_language_encoding ($filename);
803 } elsif ($self->{'extract_language'}) {
804 # use textcat to get language metadata
805 ($language, $extracted_encoding) = $self->get_language_encoding ($filename);
806 $encoding = $self->{'input_encoding'};
807 # don't print this message for english... english in utf8 is identical
808 # to english in iso-8859-1 (except for some punctuation). We don't have
809 # a language model for en_utf8, so textcat always says iso-8859-1!
810 if ($extracted_encoding ne $encoding && $language ne "en"
811 && $self->{'verbosity'}) {
812 my $plugin_name = ref ($self);
813 my $outhandle = $self->{'outhandle'};
814 &gsprintf($outhandle, "$plugin_name: {BasPlug.wrong_encoding}\n", $filename, $encoding, $extracted_encoding);
815 # print $outhandle "$plugin_name: WARNING: $filename was read using $encoding encoding but ";
816 # print $outhandle "appears to be encoded as $extracted_encoding.\n";
817 }
818 } else {
819 $language = $self->{'default_language'};
820 $encoding = $self->{'input_encoding'};
821 }
822 return ($language, $encoding);
823}
824
825# Uses textcat to work out the encoding and language of the text in
826# $filename. All html tags are removed before processing.
827# returns an array containing "language" and "encoding"
828sub get_language_encoding {
829 my $self = shift (@_);
830 my ($filename) = @_;
831 my $outhandle = $self->{'outhandle'};
832
833 # read in file
834 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";
835 undef $/;
836 my $text = <FILE>;
837 $/ = "\n";
838 close FILE;
839
840 # remove <title>stuff</title> -- as titles tend often to be in English
841 # for foreign language documents
842 $text =~ s/<title>(.|\n)*?<\/title>//i;
843
844 # remove all HTML tags
845 $text =~ s/<[^>]*>//sg;
846
847 # get the language/encoding
848 my $results = $self->{'textcat'}->classify(\$text);
849
850 # if textcat returns 3 or less possibilities we'll use the
851 # first one in the list - otherwise use the defaults
852 if (scalar @$results > 3) {
853 # changed 12 Feb 2003 by jrm21
854 # use the most popular encoding at least... otherwise we might
855 # generate invalid archive files!
856 my %guessed_encodings = ();
857 foreach my $result (@$results) {
858 $result =~ /([^\-]+)$/;
859 my $enc=$1;
860 if (!defined($guessed_encodings{$enc})) {
861 $guessed_encodings{$enc}=0;
862 }
863 $guessed_encodings{$enc}++;
864 }
865 my $best_encoding="";
866 $guessed_encodings{""}=-1;
867 foreach my $enc (keys %guessed_encodings) {
868 if ($guessed_encodings{$enc} > $guessed_encodings{$best_encoding}){
869 $best_encoding=$enc;
870 }
871 }
872
873 if ($self->{'input_encoding'} ne 'auto') {
874 if ($self->{'extract_language'} && $self->{'verbosity'}) {
875 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_language}\n", $filename, $self->{'default_language'});
876 # print $outhandle "BasPlug: WARNING: language could not be extracted from $filename - ";
877 # print $outhandle "defaulting to $self->{'default_language'}\n";
878 }
879 return ($self->{'default_language'}, $self->{'input_encoding'});
880
881 } else {
882 if ($self->{'verbosity'}) {
883 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_language}\n", $filename, $self->{'default_language'});
884 # print $outhandle "BASPlug: WARNING: language could not be extracted from $filename - ";
885 # print $outhandle "defaulting to $self->{'default_language'}.\n";
886 }
887 return ($self->{'default_language'}, $best_encoding);
888 }
889 }
890
891 # format language/encoding
892 my ($language, $encoding) = $results->[0] =~ /^([^-]*)(?:-(.*))?$/;
893 if (!defined $language) {
894 if ($self->{'verbosity'}) {
895 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_language}\n", $filename, $self->{'default_language'});
896 # print $outhandle "BasPlug: WARNING: language could not be extracted from $filename - ";
897 # print $outhandle "defaulting to $self->{'default_language'}\n";
898 }
899 $language = $self->{'default_language'};
900 }
901 if (!defined $encoding) {
902 if ($self->{'verbosity'}) {
903 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_encoding}\n", $filename, $self->{'default_encoding'});
904 # print $outhandle "BasPlug: WARNING: encoding could not be extracted from $filename - ";
905 # print $outhandle "defaulting to $self->{'default_encoding'}\n";
906 }
907 $encoding = $self->{'default_encoding'};
908 }
909
910
911 # check for equivalents where textcat doesn't have some encodings...
912 # eg MS versions of standard encodings
913 if ($encoding =~ /^iso_8859_(\d+)/) {
914 my $iso = $1; # which variant of the iso standard?
915 # iso-8859 sets don't use chars 0x80-0x9f, windows codepages do
916 if ($text =~ /[\x80-\x9f]/) {
917 # Western Europe
918 if ($iso == 1 or $iso == 15) { $encoding = 'windows_1252' }
919 elsif ($iso == 2) { $encoding = 'windows_1250' } # Central Europe
920 elsif ($iso == 5) { $encoding = 'windows_1251' } # Cyrillic
921 elsif ($iso == 6) { $encoding = 'windows_1256' } # Arabic
922 elsif ($iso == 7) { $encoding = 'windows_1253' } # Greek
923 elsif ($iso == 8) { $encoding = 'windows_1255' } # Hebrew
924 elsif ($iso == 9) { $encoding = 'windows_1254' } # Turkish
925 }
926 }
927
928 if ($encoding !~ /^(ascii|utf8|unicode)$/ &&
929 !defined $encodings::encodings->{$encoding}) {
930 if ($self->{'verbosity'}) {
931 gsprintf($outhandle, "BasPlug: {BasPlug.unsupported_encoding}\n",
932 $filename, $encoding, $self->{'default_encoding'});
933 }
934 $encoding = $self->{'default_encoding'};
935 }
936
937 return ($language, $encoding);
938}
939
940# add any extra metadata that's been passed around from one
941# plugin to another.
942# extra_metadata uses add_utf8_metadata so it expects metadata values
943# to already be in utf8
944sub extra_metadata {
945 my $self = shift (@_);
946 my ($doc_obj, $cursection, $metadata) = @_;
947
948 foreach my $field (keys(%$metadata)) {
949 # $metadata->{$field} may be an array reference
950
951 if ($field eq "gsdlassocfile_tobe") {
952 # 'gsdlassocfile_tobe' is artificially introduced metadata
953 # that is used to signal that certain additional files should
954 # be tied to this document. Useful in situations where a
955 # metadata pass in the plugin pipeline works out some files
956 # need to be associated with a document, but the document hasn't
957 # been formed yet.
958
959 my $equiv_form = "";
960 foreach my $gaf (@{$metadata->{$field}}) {
961 my ($full_filename,$mimetype) = ($gaf =~ m/^(.*):(.*):$/);
962 my ($tail_filename) = ($full_filename =~ /^.*[\/\\](.+?)$/);
963 my $filename = $full_filename;
964
965 $doc_obj->associate_file($full_filename,$tail_filename,$mimetype);
966
967 my ($doc_ext) = ($tail_filename =~ m/^.*\.(.*)$/);
968 my $start_doclink = "<a href=\"_httpcollection_/index/assoc/[archivedir]/$tail_filename\">";
969 my $srcicon = "_icon".$doc_ext."_";
970 my $end_doclink = "</a>";
971
972 $equiv_form .= " $start_doclink\{If\}{$srcicon,$srcicon,$doc_ext\}$end_doclink";
973 }
974 $doc_obj->add_utf8_metadata ($cursection, "equivlink", $equiv_form);
975 }
976 elsif (ref ($metadata->{$field}) eq "ARRAY") {
977 map {
978 $doc_obj->add_utf8_metadata ($cursection, $field, $_);
979 } @{$metadata->{$field}};
980 } else {
981 $doc_obj->add_utf8_metadata ($cursection, $field, $metadata->{$field});
982 }
983 }
984}
985
986# initialise metadata extractors
987sub initialise_extractors {
988 my $self = shift (@_);
989
990 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
991 &acronym::initialise_acronyms();
992 }
993}
994
995# finalise metadata extractors
996sub finalise_extractors {
997 my $self = shift (@_);
998
999 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
1000 &acronym::finalise_acronyms();
1001 }
1002}
1003
1004# FIRSTNNN: extract the first NNN characters as metadata
1005sub extract_first_NNNN_characters {
1006 my $self = shift (@_);
1007 my ($textref, $doc_obj, $thissection) = @_;
1008
1009 foreach my $size (split /,/, $self->{'first'}) {
1010 my $tmptext = $$textref;
1011 $tmptext =~ s/^\s+//;
1012 $tmptext =~ s/\s+$//;
1013 $tmptext =~ s/\s+/ /gs;
1014 $tmptext = substr ($tmptext, 0, $size);
1015 $tmptext =~ s/\s\S*$/&#8230;/;
1016 $doc_obj->add_utf8_metadata ($thissection, "First$size", $tmptext);
1017 }
1018}
1019
1020sub extract_email {
1021 my $self = shift (@_);
1022 my ($textref, $doc_obj, $thissection) = @_;
1023 my $outhandle = $self->{'outhandle'};
1024
1025 # print $outhandle " extracting email addresses ...\n"
1026 &gsprintf($outhandle, " {BasPlug.extracting_emails}...\n")
1027 if ($self->{'verbosity'} > 2);
1028
1029 my @email = ($$textref =~ m/([-a-z0-9\.@+_=]+@(?:[-a-z0-9]+\.)+(?:com|org|edu|mil|int|net|[a-z][a-z]))/g);
1030 @email = sort @email;
1031
1032 my @email2 = ();
1033 foreach my $address (@email) {
1034 if (!(join(" ",@email2) =~ m/$address/ )) {
1035 push @email2, $address;
1036 $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
1037 # print $outhandle " extracting $address\n"
1038 &gsprintf($outhandle, " {BasPlug.extracting} $address\n")
1039 if ($self->{'verbosity'} > 3);
1040 }
1041 }
1042 # print $outhandle " done extracting email addresses.\n"
1043 &gsprintf($outhandle, " {BasPlug.done_email_extract}\n")
1044 if ($self->{'verbosity'} > 2);
1045}
1046
1047# extract metadata
1048sub auto_extract_metadata {
1049
1050 my $self = shift (@_);
1051 my ($doc_obj) = @_;
1052
1053 if ($self->{'extract_email'}) {
1054 my $thissection = $doc_obj->get_top_section();
1055 while (defined $thissection) {
1056 my $text = $doc_obj->get_text($thissection);
1057 $self->extract_email (\$text, $doc_obj, $thissection) if $text =~ /./;
1058 $thissection = $doc_obj->get_next_section ($thissection);
1059 }
1060 }
1061
1062
1063 # adding kea keyphrases
1064
1065 if ($self->{'kea'}) {
1066
1067 my $thissection = $doc_obj->get_top_section();
1068 my $text = "";
1069 my @list;
1070
1071 #loop through sections to gather whole doc
1072 while (defined $thissection) {
1073 my $sectiontext = $doc_obj->get_text($thissection);
1074 $text = $text.$sectiontext;
1075 $thissection = $doc_obj->get_next_section ($thissection);
1076 }
1077
1078
1079 if($self->{'kea_options'}) {
1080 #if kea options flag is set, call Kea with specified options
1081 $list = &Kea::extract_KeyPhrases ($text, $self->{'kea_options'});
1082 } else {
1083 #otherwise call Kea with no options
1084 $list = &Kea::extract_KeyPhrases ($text);
1085 }
1086 if($list){
1087 # if a list of kea keyphrases was returned (ie not empty)
1088 &gsprintf(STDERR, "{BasPlug.keyphrases}: $list\n");
1089
1090 #add metadata to top section
1091 $thissection = $doc_obj->get_top_section();
1092
1093 # add all key phrases as one metadata
1094 $doc_obj->add_metadata($thissection, "Keyphrases", $list);
1095
1096 # add individual key phrases as multiple metadata
1097 foreach my $keyphrase (split(',', $list)) {
1098 $keyphrase =~ s/^\s+|\s+$//g;
1099 $doc_obj->add_metadata($thissection, "Keyphrase", $keyphrase);
1100 }
1101 }
1102 }
1103
1104 #end of kea
1105
1106 if ($self->{'first'}) {
1107 my $thissection = $doc_obj->get_top_section();
1108 while (defined $thissection) {
1109 my $text = $doc_obj->get_text($thissection);
1110 $self->extract_first_NNNN_characters (\$text, $doc_obj, $thissection) if $text =~ /./;
1111 $thissection = $doc_obj->get_next_section ($thissection);
1112 }
1113 }
1114
1115 if ($self->{'extract_acronyms'}) {
1116 my $thissection = $doc_obj->get_top_section();
1117 while (defined $thissection) {
1118 my $text = $doc_obj->get_text($thissection);
1119 $self->extract_acronyms (\$text, $doc_obj, $thissection) if $text =~ /./;
1120 $thissection = $doc_obj->get_next_section ($thissection);
1121 }
1122 }
1123
1124 if ($self->{'markup_acronyms'}) {
1125 my $thissection = $doc_obj->get_top_section();
1126 while (defined $thissection) {
1127 my $text = $doc_obj->get_text($thissection);
1128 $text = $self->markup_acronyms ($text, $doc_obj, $thissection);
1129 $doc_obj->delete_text($thissection);
1130 $doc_obj->add_text($thissection, $text);
1131 $thissection = $doc_obj->get_next_section ($thissection);
1132 }
1133 }
1134
1135 if($self->{'date_extract'}) {
1136 my $thissection = $doc_obj->get_top_section();
1137 while (defined $thissection) {
1138
1139 my $text = $doc_obj->get_text($thissection);
1140 &DateExtract::get_date_metadata($text, $doc_obj,
1141 $thissection,
1142 $self->{'no_biblio'},
1143 $self->{'max_year'},
1144 $self->{'max_century'});
1145 $thissection = $doc_obj->get_next_section ($thissection);
1146 }
1147 }
1148}
1149
1150# extract acronyms from a section in a document. progress is
1151# reported to outhandle based on the verbosity. both the Acronym
1152# and the AcronymKWIC metadata items are created.
1153
1154sub extract_acronyms {
1155 my $self = shift (@_);
1156 my ($textref, $doc_obj, $thissection) = @_;
1157 my $outhandle = $self->{'outhandle'};
1158
1159 # print $outhandle " extracting acronyms ...\n"
1160 &gsprintf($outhandle, " {BasPlug.extracting_acronyms}...\n")
1161 if ($self->{'verbosity'} > 2);
1162
1163 my $acro_array = &acronym::acronyms($textref);
1164
1165 foreach my $acro (@$acro_array) {
1166
1167 #check that this is the first time ...
1168 my $seen_before = "false";
1169 my $previous_data = $doc_obj->get_metadata($thissection, "Acronym");
1170 foreach my $thisAcro (@$previous_data) {
1171 if ($thisAcro eq $acro->to_string()) {
1172 $seen_before = "true";
1173 # print $outhandle " already seen ". $acro->to_string() . "\n"
1174 &gsprintf($outhandle, " {BasPlug.already_seen} " . $acro->to_string() . "\n")
1175 if ($self->{'verbosity'} >= 4);
1176 }
1177 }
1178
1179 if ($seen_before eq "false") {
1180 #write it to the file ...
1181 $acro->write_to_file();
1182
1183 #do the normal acronym
1184 $doc_obj->add_utf8_metadata($thissection, "Acronym", $acro->to_string());
1185 # print $outhandle " adding ". $acro->to_string() . "\n"
1186 &gsprintf($outhandle, " {BasPlug.adding} " . $acro->to_string() . "\n")
1187 if ($self->{'verbosity'} > 3);
1188 }
1189 }
1190
1191 # print $outhandle " done extracting acronyms. \n"
1192 &gsprintf($outhandle, " {BasPlug.done_acronym_extract}\n")
1193 if ($self->{'verbosity'} > 2);
1194}
1195
1196sub markup_acronyms {
1197 my $self = shift (@_);
1198 my ($text, $doc_obj, $thissection) = @_;
1199 my $outhandle = $self->{'outhandle'};
1200
1201 # print $outhandle " marking up acronyms ...\n"
1202 &gsprintf($outhandle, " {BasPlug.marking_up_acronyms}...\n")
1203 if ($self->{'verbosity'} > 2);
1204
1205 #self is passed in to check for verbosity ...
1206 $text = &acronym::markup_acronyms($text, $self);
1207
1208 # print $outhandle " done marking up acronyms. \n"
1209 &gsprintf($outhandle, " {BasPlug.done_acronym_markup}\n")
1210 if ($self->{'verbosity'} > 2);
1211
1212 return $text;
1213}
1214
1215sub compile_stats {
1216 my $self = shift(@_);
1217 my ($stats) = @_;
1218
1219 $stats->{'num_processed'} += $self->{'num_processed'};
1220 $stats->{'num_not_processed'} += $self->{'num_not_processed'};
1221 $stats->{'num_archives'} += $self->{'num_archives'};
1222
1223}
1224
1225sub associate_cover_image {
1226 my $self = shift(@_);
1227 my ($doc_obj, $filename) = @_;
1228
1229 $filename =~ s/\.[^\\\/\.]+$/\.jpg/;
1230 if (-e $filename) {
1231 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1232 $doc_obj->add_utf8_metadata($thissection, "hascover", 1);
1233 } else {
1234 $filename =~ s/jpg$/JPG/;
1235 if (-e $filename) {
1236 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1237 $doc_obj->add_utf8_metadata($thissection, "hascover", 1);
1238 }
1239 }
1240}
1241
12421;
Note: See TracBrowser for help on using the repository browser.