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

Last change on this file since 7243 was 7105, checked in by kjdon, 20 years ago

changed the max century arg to a string instead of an int - need to be able to enter BCE as part of the century
  • Property svn:keywords set to Author Date Id Revision
File size: 29.2 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 Kea;
35use parsargv;
36use multiread;
37use encodings;
38use cnseg;
39use acronym;
40use textcat;
41use doc;
42use diagnostics;
43use DateExtract;
44use ghtml;
45use gsprintf;
46use printusage;
47
48
49my $unicode_list =
50 [ { 'name' => "auto",
51 'desc' => "{BasPlug.input_encoding.auto}" },
52 { 'name' => "ascii",
53 'desc' => "{BasPlug.input_encoding.ascii}" },
54 { 'name' => "utf8",
55 'desc' => "{BasPlug.input_encoding.utf8}" },
56 { 'name' => "unicode",
57 'desc' => "{BasPlug.input_encoding.unicode}" } ];
58
59my $arguments =
60 [ { 'name' => "process_exp",
61 'desc' => "{BasPlug.process_exp}",
62 'type' => "regexp",
63 'deft' => "",
64 'reqd' => "no" },
65 { 'name' => "block_exp",
66 'desc' => "{BasPlug.block_exp}",
67 'type' => "regexp",
68 'deft' => "",
69 'reqd' => "no" },
70 { 'name' => "input_encoding",
71 'desc' => "{BasPlug.input_encoding}",
72 'type' => "enum",
73 'list' => $unicode_list,
74 'reqd' => "no" ,
75 'deft' => "auto" } ,
76 { 'name' => "default_encoding",
77 'desc' => "{BasPlug.default_encoding}",
78 'type' => "enum",
79 'list' => $unicode_list,
80 'reqd' => "no",
81 'deft' => "utf8" },
82 { 'name' => "extract_language",
83 'desc' => "{BasPlug.extract_language}",
84 'type' => "flag",
85 'reqd' => "no" },
86 { 'name' => "default_language",
87 'desc' => "{BasPlug.default_language}",
88 'type' => "language",
89 'deft' => "en",
90 'reqd' => "no" },
91 { 'name' => "extract_acronyms",
92 'desc' => "{BasPlug.extract_acronyms}",
93 'type' => "flag",
94 'reqd' => "no" },
95 { 'name' => "markup_acronyms",
96 'desc' => "{BasPlug.markup_acronyms}",
97 'type' => "flag",
98 'reqd' => "no" },
99 { 'name' => "first",
100 'desc' => "{BasPlug.first}",
101 'type' => "string",
102 'reqd' => "no" },
103 { 'name' => "extract_email",
104 'desc' => "{BasPlug.extract_email}",
105 'type' => "flag",
106 'reqd' => "no" },
107 { 'name' => "extract_historical_years",
108 'desc' => "{BasPlug.extract_historical_years}",
109 'type' => "flag",
110 'reqd' => "no" },
111 { 'name' => "maximum_year",
112 'desc' => "{BasPlug.maximum_year}",
113 'type' => "int",
114 'deft' => (localtime)[5]+1900,
115 'reqd' => "no"},
116 { 'name' => "maximum_century",
117 'desc' => "{BasPlug.maximum_century}",
118 'type' => "string",
119 'deft' => "",
120 'reqd' => "no" },
121 { 'name' => "no_bibliography",
122 'desc' => "{BasPlug.no_bibliography}",
123 'type' => "flag",
124 'reqd' => "no"},
125 { 'name' => "cover_image",
126 'desc' => "{BasPlug.cover_image}",
127 'type' => "flag",
128 'reqd' => "no" } ];
129
130my $options = { 'name' => "BasPlug",
131 'desc' => "{BasPlug.desc}",
132 'abstract' => "yes",
133 'inherits' => "no",
134 'args' => $arguments };
135
136
137sub gsprintf
138{
139 return &gsprintf::gsprintf(@_);
140}
141
142
143sub get_arguments
144{
145 local $self = shift(@_);
146 local $optionlistref = $self->{'option_list'};
147 local @optionlist = @$optionlistref;
148 local $pluginoptions = pop(@$optionlistref);
149 local $pluginarguments = $pluginoptions->{'args'};
150 return $pluginarguments;
151}
152
153
154sub print_xml_usage
155{
156 local $self = shift(@_);
157
158 # XML output is always in UTF-8
159 &gsprintf::output_strings_in_UTF8;
160
161 &PrintUsage::print_xml_header();
162 $self->print_xml();
163}
164
165
166sub print_xml
167{
168 local $self = shift(@_);
169
170 local $optionlistref = $self->{'option_list'};
171 local @optionlist = @$optionlistref;
172 local $pluginoptions = pop(@$optionlistref);
173 return if (!defined($pluginoptions));
174
175 &gsprintf(STDERR, "<PlugInfo>\n");
176 &gsprintf(STDERR, " <Name>$pluginoptions->{'name'}</Name>\n");
177 my $desc = &gsprintf::lookup_string($pluginoptions->{'desc'});
178 $desc =~ s/</&amp;lt;/g; # doubly escaped
179 $desc =~ s/>/&amp;gt;/g;
180
181 &gsprintf(STDERR, " <Desc>$desc</Desc>\n");
182 &gsprintf(STDERR, " <Abstract>$pluginoptions->{'abstract'}</Abstract>\n");
183 &gsprintf(STDERR, " <Inherits>$pluginoptions->{'inherits'}</Inherits>\n");
184 &gsprintf(STDERR, " <Arguments>\n");
185 if (defined($pluginoptions->{'args'})) {
186 &PrintUsage::print_options_xml($pluginoptions->{'args'});
187 }
188
189 # Recurse up the plugin hierarchy
190 $self->print_xml();
191
192 &gsprintf(STDERR, " </Arguments>\n");
193 &gsprintf(STDERR, "</PlugInfo>\n");
194}
195
196
197sub print_txt_usage
198{
199 local $self = shift(@_);
200
201 # Print the usage message for a plugin (recursively)
202 local $descoffset = $self->determine_description_offset(0);
203 $self->print_plugin_usage($descoffset, 1);
204}
205
206
207sub determine_description_offset
208{
209 local $self = shift(@_);
210 local $maxoffset = shift(@_);
211
212 local $optionlistref = $self->{'option_list'};
213 local @optionlist = @$optionlistref;
214 local $pluginoptions = pop(@$optionlistref);
215 return $maxoffset if (!defined($pluginoptions));
216
217 # Find the length of the longest option string of this plugin
218 local $pluginargs = $pluginoptions->{'args'};
219 if (defined($pluginargs)) {
220 local $longest = &PrintUsage::find_longest_option_string($pluginargs);
221 if ($longest > $maxoffset) {
222 $maxoffset = $longest;
223 }
224 }
225
226 # Recurse up the plugin hierarchy
227 $maxoffset = $self->determine_description_offset($maxoffset);
228 $self->{'option_list'} = \@optionlist;
229 return $maxoffset;
230}
231
232
233sub print_plugin_usage
234{
235 local $self = shift(@_);
236 local $descoffset = shift(@_);
237 local $isleafclass = shift(@_);
238
239 local $optionlistref = $self->{'option_list'};
240 local @optionlist = @$optionlistref;
241 local $pluginoptions = pop(@$optionlistref);
242 return if (!defined($pluginoptions));
243
244 local $pluginname = $pluginoptions->{'name'};
245 local $pluginargs = $pluginoptions->{'args'};
246 local $plugindesc = $pluginoptions->{'desc'};
247
248 # Produce the usage information using the data structure above
249 if ($isleafclass) {
250 if (defined($plugindesc)) {
251 &gsprintf(STDERR, "$plugindesc\n\n");
252 }
253 &gsprintf(STDERR, " {common.usage}: plugin $pluginname [{common.options}]\n\n");
254 }
255
256 # Display the plugin options, if there are some
257 if (defined($pluginargs)) {
258 # Calculate the column offset of the option descriptions
259 local $optiondescoffset = $descoffset + 2; # 2 spaces between options & descriptions
260
261 if ($isleafclass) {
262 &gsprintf(STDERR, " {common.specific_options}:\n");
263 }
264 else {
265 &gsprintf(STDERR, " {common.general_options}:\n", $pluginname);
266 }
267
268 # Display the plugin options
269 &PrintUsage::print_options_txt($pluginargs, $optiondescoffset);
270 }
271
272 # Recurse up the plugin hierarchy
273 $self->print_plugin_usage($descoffset, 0);
274 $self->{'option_list'} = \@optionlist;
275}
276
277
278sub new {
279 my $class = shift (@_);
280 my $plugin_name = shift (@_);
281 my $self = {};
282 $self->{'plugin_type'} = "BasPlug";
283 my $enc = "^(";
284 map {$enc .= "$_|";} keys %$encodings::encodings;
285 my $denc = $enc . "ascii|utf8|unicode)\$";
286 $enc .= "ascii|utf8|unicode|auto)\$";
287
288 $self->{'outhandle'} = STDERR;
289 my $year = (localtime)[5]+1900;
290
291 $self->{'textcat'} = new textcat();
292
293 $self->{'num_processed'} = 0;
294 $self->{'num_not_processed'} = 0;
295 $self->{'num_blocked'} = 0;
296 $self->{'num_archives'} = 0;
297
298 # 14-05-02 To allow for proper inheritance of arguments - John Thompson
299 $self->{'option_list'} = [ $options ];
300
301 # general options available to all plugins
302 if (!parsargv::parse(\@_,
303 q^process_exp/.*/^, \$self->{'process_exp'},
304 q^block_exp/.*/^, \$self->{'block_exp'},
305 q^extract_language^, \$self->{'extract_language'},
306 q^extract_acronyms^, \$self->{'extract_acronyms'},
307 q^extract_keyphrases^, \$self->{'kea'}, #with extra options (UNDOCUMENTED)
308 q^extract_keyphrase_options/.*/^, \$self->{'kea_options'}, #no extra options (UNDOCUMENTED)
309 qq^input_encoding/$enc/auto^, \$self->{'input_encoding'},
310 qq^default_encoding/$denc/utf8^, \$self->{'default_encoding'},
311 q^extract_email^, \$self->{'extract_email'},
312 q^markup_acronyms^, \$self->{'markup_acronyms'},
313 q^default_language/.{2}/en^, \$self->{'default_language'},
314 q^first/.*/^, \$self->{'first'},
315 q^extract_historical_years^, \$self->{'date_extract'},
316 qq^maximum_year/\\d{4}/$year^, \$self->{'max_year'},
317 q^no_bibliography^, \$self->{'no_biblio'},
318 qq^maximum_century/-?\\d{1,2}( ?B\\.C\\.E\\.)?/-1^, \$self->{'max_century'},
319 q^cover_image^, \$self->{'cover_image'},
320 q^separate_cjk^, \$self->{'separate_cjk'},
321 "allow_extra_options")) {
322
323 &gsprintf(STDERR, "\n{BasPlug.bad_general_option}\n", $plugin_name);
324 $self->print_txt_usage(""); # Use default resource bundle
325 die "\n";
326 }
327
328 return bless $self, $class;
329}
330
331# initialize BasPlug options
332# if init() is overridden in a sub-class, remember to call BasPlug::init()
333sub init {
334 my $self = shift (@_);
335 my ($verbosity, $outhandle, $failhandle) = @_;
336
337 # verbosity is passed through from the processor
338 $self->{'verbosity'} = $verbosity;
339
340 # as are the outhandle and failhandle
341 $self->{'outhandle'} = $outhandle if defined $outhandle;
342 $self->{'failhandle'} = $failhandle;
343
344 # set process_exp and block_exp to defaults unless they were
345 # explicitly set
346
347 if ((!$self->is_recursive()) and
348 (!defined $self->{'process_exp'}) || ($self->{'process_exp'} eq "")) {
349
350 $self->{'process_exp'} = $self->get_default_process_exp ();
351 if ($self->{'process_exp'} eq "") {
352 warn ref($self) . " Warning: Non-recursive plugin has no process_exp\n";
353 }
354 }
355
356 if ((!defined $self->{'block_exp'}) || ($self->{'block_exp'} eq "")) {
357 $self->{'block_exp'} = $self->get_default_block_exp ();
358 }
359}
360
361sub begin {
362 my $self = shift (@_);
363 my ($pluginfo, $base_dir, $processor, $maxdocs) = @_;
364 $self->initialise_extractors();
365}
366
367sub end {
368 my ($self) = @_;
369 $self->finalise_extractors();
370}
371
372# this function should be overridden to return 1
373# in recursive plugins
374sub is_recursive {
375 my $self = shift (@_);
376
377 return 0;
378}
379
380sub get_default_block_exp {
381 my $self = shift (@_);
382
383 return "";
384}
385
386sub get_default_process_exp {
387 my $self = shift (@_);
388
389 return "";
390}
391
392# The BasPlug read() function. This function does all the right things
393# to make general options work for a given plugin. It calls the process()
394# function which does all the work specific to a plugin (like the old
395# read functions used to do). Most plugins should define their own
396# process() function and let this read() function keep control.
397#
398# recursive plugins (e.g. RecPlug) and specialized plugins like those
399# capable of processing many documents within a single file (e.g.
400# GMLPlug) should normally implement their own version of read()
401#
402# Return number of files processed, undef if can't process
403# Note that $base_dir might be "" and that $file might
404# include directories
405
406sub read {
407 my $self = shift (@_);
408
409 my ($pluginfo, $base_dir, $file, $metadata, $processor, $maxdocs, $gli) = @_;
410
411 if ($self->is_recursive()) {
412 &gsprintf(STDERR, "{BasPlug.read_must_be_implemented}") && die "\n";
413 }
414
415 my $outhandle = $self->{'outhandle'};
416
417 my $filename = $file;
418 $filename = &util::filename_cat ($base_dir, $file) if $base_dir =~ /\w/;
419
420 if ($self->{'block_exp'} ne "" && $filename =~ /$self->{'block_exp'}/) {
421 $self->{'num_blocked'} ++;
422 return 0;
423 }
424 if ($filename !~ /$self->{'process_exp'}/ || !-f $filename) {
425 return undef;
426 }
427 $file =~ s/^[\/\\]+//; # $file often begins with / so we'll tidy it up
428
429 # Do encoding stuff
430 my ($language, $encoding) = $self->textcat_get_language_encoding ($filename);
431
432 # create a new document
433 my $doc_obj = new doc ($filename, "indexed_doc");
434 $doc_obj->set_OIDtype ($processor->{'OIDtype'});
435 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Language", $language);
436 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "Encoding", $encoding);
437 $doc_obj->add_utf8_metadata($doc_obj->get_top_section(), "$self->{'plugin_type'}", "1");
438 my ($filemeta) = $file =~ /([^\\\/]+)$/;
439 # how do we know what encoding the filename is in?
440 $doc_obj->add_metadata($doc_obj->get_top_section(), "Source", &ghtml::dmsafe($filemeta));
441 if ($self->{'cover_image'}) {
442 $self->associate_cover_image($doc_obj, $filename);
443 }
444
445 # read in file ($text will be in utf8)
446 my $text = "";
447 $self->read_file ($filename, $encoding, $language, \$text);
448
449 if (!length ($text)) {
450 my $plugin_name = ref ($self);
451 &gsprintf($outhandle, "$plugin_name: {BasPlug.file_has_no_text}\n", $filename) if $self->{'verbosity'};
452
453 my $failhandle = $self->{'failhandle'};
454 &gsprintf($failhandle, "$file: " . ref($self) . ": {BasPlug.empty_file}\n");
455 # print $failhandle "$file: " . ref($self) . ": file contains no text\n";
456 $self->{'num_not_processed'} ++;
457
458 return 0;
459 }
460
461 # include any metadata passed in from previous plugins
462 # note that this metadata is associated with the top level section
463 $self->extra_metadata ($doc_obj, $doc_obj->get_top_section(), $metadata);
464
465 # do plugin specific processing of doc_obj
466 return undef unless defined ($self->process (\$text, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli));
467
468 # do any automatic metadata extraction
469 $self->auto_extract_metadata ($doc_obj);
470
471 # add an OID
472 # see if there is a plugin-specific set_OID function...
473 if (defined ($self->can(set_OID))) {
474 # it will need $doc_obj to set the Identifier metadata...
475 $self->set_OID($doc_obj);
476 } else {
477 # use the default set_OID() in doc.pm
478 $doc_obj->set_OID();
479 }
480
481 # process the document
482 $processor->process($doc_obj);
483
484 $self->{'num_processed'} ++;
485
486 return 1; # processed the file
487}
488
489# returns undef if file is rejected by the plugin
490sub process {
491 my $self = shift (@_);
492 my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj) = @_;
493
494 &gsprintf(STDERR, "BasPlug::process {common.must_be_implemented}\n") && die "\n";
495 # die "Basplug::process function must be implemented in sub-class\n";
496
497 return undef; # never gets here
498}
499
500# uses the multiread package to read in the entire file pointed to
501# by filename and loads the resulting text into $$textref. Input text
502# may be in any of the encodings handled by multiread, output text
503# will be in utf8
504sub read_file {
505 my $self = shift (@_);
506 my ($filename, $encoding, $language, $textref) = @_;
507
508 if (!-r $filename)
509 {
510 my $outhandle = $self->{'outhandle'};
511 &gsprintf($outhandle, "{BasPlug.read_denied}\n", $filename) if $self->{'verbosity'};
512 # print $outhandle "Read permission denied for $filename\n" if $self->{'verbosity'};
513 return;
514 }
515
516 $$textref = "";
517
518 open (FILE, $filename) || (&gsprintf(STDERR, "BasPlug::read_file {BasPlug.could_not_open_for_reading} ($!)\n", $filename) && die "\n");
519 # open (FILE, $filename) || die "BasPlug::read_file could not open $filename for reading ($!)\n";
520
521 if ($encoding eq "ascii") {
522 undef $/;
523 $$textref = <FILE>;
524 $/ = "\n";
525 } else {
526 my $reader = new multiread();
527 $reader->set_handle ('BasPlug::FILE');
528 $reader->set_encoding ($encoding);
529 $reader->read_file ($textref);
530
531 #Now segments chinese if the separate_cjk option is set
532 if ($self->{'separate_cjk'}) {
533 # segment the Chinese words
534 $$textref = &cnseg::segment($$textref);
535 }
536 }
537
538 close FILE;
539}
540
541sub textcat_get_language_encoding {
542 my $self = shift (@_);
543 my ($filename) = @_;
544
545 my ($language, $encoding, $extracted_encoding);
546 if ($self->{'input_encoding'} eq "auto") {
547 # use textcat to automatically work out the input encoding and language
548 ($language, $encoding) = $self->get_language_encoding ($filename);
549 } elsif ($self->{'extract_language'}) {
550 # use textcat to get language metadata
551 ($language, $extracted_encoding) = $self->get_language_encoding ($filename);
552 $encoding = $self->{'input_encoding'};
553 if ($extracted_encoding ne $encoding && $self->{'verbosity'}) {
554 my $plugin_name = ref ($self);
555 my $outhandle = $self->{'outhandle'};
556 &gsprintf($outhandle, "$plugin_name: {BasPlug.wrong_encoding}\n", $filename, $encoding, $extracted_encoding);
557 # print $outhandle "$plugin_name: WARNING: $filename was read using $encoding encoding but ";
558 # print $outhandle "appears to be encoded as $extracted_encoding.\n";
559 }
560 } else {
561 $language = $self->{'default_language'};
562 $encoding = $self->{'input_encoding'};
563 }
564 return ($language, $encoding);
565}
566
567# Uses textcat to work out the encoding and language of the text in
568# $filename. All html tags are removed before processing.
569# returns an array containing "language" and "encoding"
570sub get_language_encoding {
571 my $self = shift (@_);
572 my ($filename) = @_;
573 my $outhandle = $self->{'outhandle'};
574
575 # read in file
576 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";
577 undef $/;
578 my $text = <FILE>;
579 $/ = "\n";
580 close FILE;
581
582 # remove <title>stuff</title> -- as titles tend often to be in English
583 # for foreign language documents
584 $text =~ s/<title>.*?<\/title>//i;
585
586 # remove all HTML tags
587 $text =~ s/<[^>]*>//sg;
588
589 # get the language/encoding
590 my $results = $self->{'textcat'}->classify(\$text);
591
592 # if textcat returns 3 or less possibilities we'll use the
593 # first one in the list - otherwise use the defaults
594 if (scalar @$results > 3) {
595 # changed 12 Feb 2003 by jrm21
596 # use the most popular encoding at least... otherwise we might
597 # generate invalid archive files!
598 my %guessed_encodings = ();
599 foreach my $result (@$results) {
600 $result =~ /([^\-]+)$/;
601 my $enc=$1;
602 if (!defined($guessed_encodings{$enc})) {
603 $guessed_encodings{$enc}=0;
604 }
605 $guessed_encodings{$enc}++;
606 }
607 my $best_encoding="";
608 $guessed_encodings{""}=-1;
609 foreach my $enc (keys %guessed_encodings) {
610 if ($guessed_encodings{$enc} > $guessed_encodings{$best_encoding}){
611 $best_encoding=$enc;
612 }
613 }
614
615 if ($self->{'input_encoding'} ne 'auto') {
616 if ($self->{'extract_language'} && $self->{'verbosity'}) {
617 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_language}\n", $filename, $self->{'default_language'});
618 # print $outhandle "BasPlug: WARNING: language could not be extracted from $filename - ";
619 # print $outhandle "defaulting to $self->{'default_language'}\n";
620 }
621 return ($self->{'default_language'}, $self->{'input_encoding'});
622
623 } else {
624 if ($self->{'verbosity'}) {
625 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_language}\n", $filename, $self->{'default_language'});
626 # print $outhandle "BASPlug: WARNING: language could not be extracted from $filename - ";
627 # print $outhandle "defaulting to $self->{'default_language'}.\n";
628 }
629 return ($self->{'default_language'}, $best_encoding);
630 }
631 }
632
633 # format language/encoding
634 my ($language, $encoding) = $results->[0] =~ /^([^-]*)(?:-(.*))?$/;
635 if (!defined $language) {
636 if ($self->{'verbosity'}) {
637 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_language}\n", $filename, $self->{'default_language'});
638 # print $outhandle "BasPlug: WARNING: language could not be extracted from $filename - ";
639 # print $outhandle "defaulting to $self->{'default_language'}\n";
640 }
641 $language = $self->{'default_language'};
642 }
643 if (!defined $encoding) {
644 if ($self->{'verbosity'}) {
645 &gsprintf($outhandle, "BasPlug: {BasPlug.could_not_extract_encoding}\n", $filename, $self->{'default_encoding'});
646 # print $outhandle "BasPlug: WARNING: encoding could not be extracted from $filename - ";
647 # print $outhandle "defaulting to $self->{'default_encoding'}\n";
648 }
649 $encoding = $self->{'default_encoding'};
650 }
651
652 if ($encoding !~ /^(ascii|utf8|unicode)$/ &&
653 !defined $encodings::encodings->{$encoding}) {
654 if ($self->{'verbosity'}) {
655 &gsprintf($outhandle, "BasPlug: {BasPlug.unsupported_encoding}\n", $filename, $encoding, $self->{'default_encoding'});
656 # print $outhandle "BasPlug: WARNING: $filename appears to be encoded in an unsupported encoding ($encoding) - ";
657 # print $outhandle "using $self->{'default_encoding'}\n";
658 }
659 $encoding = $self->{'default_encoding'};
660 }
661
662 return ($language, $encoding);
663}
664
665# add any extra metadata that's been passed around from one
666# plugin to another.
667# extra_metadata uses add_utf8_metadata so it expects metadata values
668# to already be in utf8
669sub extra_metadata {
670 my $self = shift (@_);
671 my ($doc_obj, $cursection, $metadata) = @_;
672
673 foreach my $field (keys(%$metadata)) {
674 # $metadata->{$field} may be an array reference
675 if (ref ($metadata->{$field}) eq "ARRAY") {
676 map {
677 $doc_obj->add_utf8_metadata ($cursection, $field, $_);
678 } @{$metadata->{$field}};
679 } else {
680 $doc_obj->add_utf8_metadata ($cursection, $field, $metadata->{$field});
681 }
682 }
683}
684
685# initialise metadata extractors
686sub initialise_extractors {
687 my $self = shift (@_);
688
689 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
690 &acronym::initialise_acronyms();
691 }
692}
693
694# finalise metadata extractors
695sub finalise_extractors {
696 my $self = shift (@_);
697
698 if ($self->{'extract_acronyms'} || $self->{'markup_acronyms'}) {
699 &acronym::finalise_acronyms();
700 }
701}
702
703# FIRSTNNN: extract the first NNN characters as metadata
704sub extract_first_NNNN_characters {
705 my $self = shift (@_);
706 my ($textref, $doc_obj, $thissection) = @_;
707
708 foreach my $size (split /,/, $self->{'first'}) {
709 my $tmptext = $$textref;
710 $tmptext =~ s/^\s+//;
711 $tmptext =~ s/\s+$//;
712 $tmptext =~ s/\s+/ /gs;
713 $tmptext = substr ($tmptext, 0, $size);
714 $tmptext =~ s/\s\S*$/&#8230;/;
715 $doc_obj->add_utf8_metadata ($thissection, "First$size", $tmptext);
716 }
717}
718
719sub extract_email {
720 my $self = shift (@_);
721 my ($textref, $doc_obj, $thissection) = @_;
722 my $outhandle = $self->{'outhandle'};
723
724 # print $outhandle " extracting email addresses ...\n"
725 &gsprintf($outhandle, " {BasPlug.extracting_emails}...\n")
726 if ($self->{'verbosity'} > 2);
727
728 my @email = ($$textref =~ m/([-a-z0-9\.@+_=]+@(?:[-a-z0-9]+\.)+(?:com|org|edu|mil|int|net|[a-z][a-z]))/g);
729 @email = sort @email;
730
731 my @email2 = ();
732 foreach my $address (@email) {
733 if (!(join(" ",@email2) =~ m/$address/ )) {
734 push @email2, $address;
735 $doc_obj->add_utf8_metadata ($thissection, "emailAddress", $address);
736 # print $outhandle " extracting $address\n"
737 &gsprintf($outhandle, " {BasPlug.extracting} $address\n")
738 if ($self->{'verbosity'} > 3);
739 }
740 }
741 # print $outhandle " done extracting email addresses.\n"
742 &gsprintf($outhandle, " {BasPlug.done_email_extract}\n")
743 if ($self->{'verbosity'} > 2);
744}
745
746# extract metadata
747sub auto_extract_metadata {
748
749 my $self = shift (@_);
750 my ($doc_obj) = @_;
751
752 if ($self->{'extract_email'}) {
753 my $thissection = $doc_obj->get_top_section();
754 while (defined $thissection) {
755 my $text = $doc_obj->get_text($thissection);
756 $self->extract_email (\$text, $doc_obj, $thissection) if $text =~ /./;
757 $thissection = $doc_obj->get_next_section ($thissection);
758 }
759 }
760
761
762#adding kea keyphrases
763 if ($self->{'kea'}) {
764
765 my $thissection = $doc_obj->get_top_section();
766 my $text = "";
767 my @list;
768
769 while (defined $thissection) { #loop through sections to gather whole doc
770 my $sectiontext = $doc_obj->get_text($thissection);
771 $text = $text.$sectiontext;
772 $thissection = $doc_obj->get_next_section ($thissection);
773 }
774
775 if($self->{'kea_options'}) { #if kea options flag is set, call Kea with specified options
776 @list = &Kea::extract_KeyPhrases ($text, $self->{'kea_options'});
777 } else { #otherwise call Kea with no options
778 @list = &Kea::extract_KeyPhrases ($text);
779 }
780
781 if(@list){ #if a list of kea keyphrases was returned (ie not empty)
782 my $keyphrases = $list[0]; #first arg is keyphrase list
783 my $stems = $list[1]; #second arg is stemmed keyphrase list
784 &gsprintf(STDERR, "{BasPlug.keyphrases}: $keyphrases\n");
785 # print STDERR "keyphrases: $keyphrases\n";
786 &gsprintf(STDERR, "{BasPlug.stems}: $stems\n");
787 # print STDERR "stems: $stems\n";
788 $thissection = $doc_obj->get_top_section(); #add metadata to top section
789 $doc_obj->add_metadata($thissection, "kea", $keyphrases);
790 $doc_obj->add_metadata($thissection, "stems", $stems);
791 }
792 } #end of kea
793
794 if ($self->{'first'}) {
795 my $thissection = $doc_obj->get_top_section();
796 while (defined $thissection) {
797 my $text = $doc_obj->get_text($thissection);
798 $self->extract_first_NNNN_characters (\$text, $doc_obj, $thissection) if $text =~ /./;
799 $thissection = $doc_obj->get_next_section ($thissection);
800 }
801 }
802
803 if ($self->{'extract_acronyms'}) {
804 my $thissection = $doc_obj->get_top_section();
805 while (defined $thissection) {
806 my $text = $doc_obj->get_text($thissection);
807 $self->extract_acronyms (\$text, $doc_obj, $thissection) if $text =~ /./;
808 $thissection = $doc_obj->get_next_section ($thissection);
809 }
810 }
811
812 if ($self->{'markup_acronyms'}) {
813 my $thissection = $doc_obj->get_top_section();
814 while (defined $thissection) {
815 my $text = $doc_obj->get_text($thissection);
816 $text = $self->markup_acronyms ($text, $doc_obj, $thissection);
817 $doc_obj->delete_text($thissection);
818 $doc_obj->add_text($thissection, $text);
819 $thissection = $doc_obj->get_next_section ($thissection);
820 }
821 }
822
823 if($self->{'date_extract'}) {
824 my $thissection = $doc_obj->get_top_section();
825 while (defined $thissection) {
826
827 my $text = $doc_obj->get_text($thissection);
828 &DateExtract::get_date_metadata($text, $doc_obj,
829 $thissection,
830 $self->{'no_biblio'},
831 $self->{'max_year'},
832 $self->{'max_century'});
833 $thissection = $doc_obj->get_next_section ($thissection);
834 }
835 }
836}
837
838# extract acronyms from a section in a document. progress is
839# reported to outhandle based on the verbosity. both the Acronym
840# and the AcronymKWIC metadata items are created.
841
842sub extract_acronyms {
843 my $self = shift (@_);
844 my ($textref, $doc_obj, $thissection) = @_;
845 my $outhandle = $self->{'outhandle'};
846
847 # print $outhandle " extracting acronyms ...\n"
848 &gsprintf($outhandle, " {BasPlug.extracting_acronyms}...\n")
849 if ($self->{'verbosity'} > 2);
850
851 my $acro_array = &acronym::acronyms($textref);
852
853 foreach my $acro (@$acro_array) {
854
855 #check that this is the first time ...
856 my $seen_before = "false";
857 my $previous_data = $doc_obj->get_metadata($thissection, "Acronym");
858 foreach my $thisAcro (@$previous_data) {
859 if ($thisAcro eq $acro->to_string()) {
860 $seen_before = "true";
861 # print $outhandle " already seen ". $acro->to_string() . "\n"
862 &gsprintf($outhandle, " {BasPlug.already_seen} " . $acro->to_string() . "\n")
863 if ($self->{'verbosity'} >= 4);
864 }
865 }
866
867 if ($seen_before eq "false") {
868 #write it to the file ...
869 $acro->write_to_file();
870
871 #do the normal acronym
872 $doc_obj->add_utf8_metadata($thissection, "Acronym", $acro->to_string());
873 # print $outhandle " adding ". $acro->to_string() . "\n"
874 &gsprintf($outhandle, " {BasPlug.adding} " . $acro->to_string() . "\n")
875 if ($self->{'verbosity'} > 3);
876 }
877 }
878
879 # print $outhandle " done extracting acronyms. \n"
880 &gsprintf($outhandle, " {BasPlug.done_acronym_extract}\n")
881 if ($self->{'verbosity'} > 2);
882}
883
884sub markup_acronyms {
885 my $self = shift (@_);
886 my ($text, $doc_obj, $thissection) = @_;
887 my $outhandle = $self->{'outhandle'};
888
889 # print $outhandle " marking up acronyms ...\n"
890 &gsprintf($outhandle, " {BasPlug.marking_up_acronyms}...\n")
891 if ($self->{'verbosity'} > 2);
892
893 #self is passed in to check for verbosity ...
894 $text = &acronym::markup_acronyms($text, $self);
895
896 # print $outhandle " done marking up acronyms. \n"
897 &gsprintf($outhandle, " {BasPlug.done_acronym_markup}\n")
898 if ($self->{'verbosity'} > 2);
899
900 return $text;
901}
902
903sub compile_stats {
904 my $self = shift(@_);
905 my ($stats) = @_;
906
907 $stats->{'num_processed'} += $self->{'num_processed'};
908 $stats->{'num_not_processed'} += $self->{'num_not_processed'};
909 $stats->{'num_archives'} += $self->{'num_archives'};
910
911}
912
913sub associate_cover_image {
914 my $self = shift(@_);
915 my ($doc_obj, $filename) = @_;
916
917 $filename =~ s/\.[^\\\/\.]+$/\.jpg/;
918 if (-e $filename) {
919 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
920 } else {
921 $filename =~ s/jpg$/JPG/;
922 if (-e $filename) {
923 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
924 }
925 }
926}
927
9281;
Note: See TracBrowser for help on using the repository browser.