source: main/trunk/greenstone2/perllib/plugins/BasePlugin.pm@ 26536

Last change on this file since 26536 was 26536, checked in by davidb, 11 years ago

Introduction of two new OIDtype values (hash_on_full_filename and full_filename) designed to help provide more stable document IDs for collections that are rebuilt over time, including rebuilt after the Greenstone install has been upgraded
  • Property svn:keywords set to Author Date Id Revision
File size: 46.6 KB
Line 
1###########################################################################
2#
3# BasePlugin.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 BasePlugin;
27
28use strict;
29no strict 'subs';
30no strict 'refs'; # allow filehandles to be variables and viceversa
31
32use File::Basename;
33use Encode;
34use Unicode::Normalize 'normalize';
35
36use encodings;
37use unicode;
38use doc;
39use ghtml;
40use gsprintf 'gsprintf';
41
42use PrintInfo;
43
44BEGIN {
45 @BasePlugin::ISA = ( 'PrintInfo' );
46}
47
48# the different methods that can be applied when renaming
49# imported documents and their associated files
50our $file_rename_method_list =
51 [ { 'name' => "url",
52 'desc' => "{BasePlugin.rename_method.url}" },
53 { 'name' => "base64",
54 'desc' => "{BasePlugin.rename_method.base64}" },
55 { 'name' => "none",
56 'desc' => "{BasePlugin.rename_method.none}",
57 'hiddengli' => "yes" } ];
58
59our $encoding_list =
60 [ { 'name' => "ascii",
61 'desc' => "{BasePlugin.encoding.ascii}" },
62 { 'name' => "utf8",
63 'desc' => "{BasePlugin.encoding.utf8}" },
64 { 'name' => "unicode",
65 'desc' => "{BasePlugin.encoding.unicode}" } ];
66
67
68my $e = $encodings::encodings;
69foreach my $enc (sort {$e->{$a}->{'name'} cmp $e->{$b}->{'name'}} keys (%$e))
70{
71 my $hashEncode =
72 {'name' => $enc,
73 'desc' => $e->{$enc}->{'name'}};
74
75 push(@{$encoding_list},$hashEncode);
76}
77
78our $encoding_plus_auto_list =
79 [ { 'name' => "auto",
80 'desc' => "{BasePlugin.filename_encoding.auto}" },
81 { 'name' => "auto-language-analysis",
82 'desc' => "{BasePlugin.filename_encoding.auto_language_analysis}" }, # textcat
83 { 'name' => "auto-filesystem-encoding",
84 'desc' => "{BasePlugin.filename_encoding.auto_filesystem_encoding}" }, # locale
85 { 'name' => "auto-fl",
86 'desc' => "{BasePlugin.filename_encoding.auto_fl}" }, # locale followed by textcat
87 { 'name' => "auto-lf",
88 'desc' => "{BasePlugin.filename_encoding.auto_lf}" } ]; # texcat followed by locale
89
90push(@{$encoding_plus_auto_list},@{$encoding_list});
91
92our $oidtype_list =
93 [ { 'name' => "auto",
94 'desc' => "{BasePlugin.OIDtype.auto}" },
95 { 'name' => "hash",
96 'desc' => "{import.OIDtype.hash}" },
97 { 'name' => "hash_on_ga_xml",
98 'desc' => "{import.OIDtype.hash_on_ga_xml}" },
99 { 'name' => "hash_on_full_filename",
100 'desc' => "{import.OIDtype.hash_on_full_filename}" },
101 { 'name' => "assigned",
102 'desc' => "{import.OIDtype.assigned}" },
103 { 'name' => "incremental",
104 'desc' => "{import.OIDtype.incremental}" },
105 { 'name' => "filename",
106 'desc' => "{import.OIDtype.filename}" },
107 { 'name' => "dirname",
108 'desc' => "{import.OIDtype.dirname}" },
109 { 'name' => "full_filename",
110 'desc' => "{import.OIDtype.full_filename}" } ];
111
112my $arguments =
113 [ { 'name' => "process_exp",
114 'desc' => "{BasePlugin.process_exp}",
115 'type' => "regexp",
116 'deft' => "",
117 'reqd' => "no" },
118 { 'name' => "no_blocking",
119 'desc' => "{BasePlugin.no_blocking}",
120 'type' => "flag",
121 'reqd' => "no"},
122 { 'name' => "block_exp",
123 'desc' => "{BasePlugin.block_exp}",
124 'type' => "regexp",
125 'deft' => "",
126 'reqd' => "no" },
127 { 'name' => "store_original_file",
128 'desc' => "{BasePlugin.store_original_file}",
129 'type' => "flag",
130 'reqd' => "no" },
131 { 'name' => "associate_ext",
132 'desc' => "{BasePlugin.associate_ext}",
133 'type' => "string",
134 'reqd' => "no" },
135 { 'name' => "associate_tail_re",
136 'desc' => "{BasePlugin.associate_tail_re}",
137 'type' => "string",
138 'reqd' => "no" },
139 { 'name' => "OIDtype",
140 'desc' => "{import.OIDtype}",
141 'type' => "enum",
142 'list' => $oidtype_list,
143 # leave default empty so we can tell if its been set or not - if not set will use option from import.pl
144 'deft' => "auto",
145 'reqd' => "no" },
146 { 'name' => "OIDmetadata",
147 'desc' => "{import.OIDmetadata}",
148 'type' => "metadata",
149 'deft' => "dc.Identifier",
150 'reqd' => "no" },
151# { 'name' => "use_as_doc_identifier",
152# 'desc' => "{BasePlugin.use_as_doc_identifier}",
153# 'type' => "string",
154# 'reqd' => "no" ,
155# 'deft' => "" } ,
156 { 'name' => "no_cover_image",
157 'desc' => "{BasePlugin.no_cover_image}",
158 'type' => "flag",
159 'reqd' => "no" },
160 { 'name' => "filename_encoding",
161 'desc' => "{BasePlugin.filename_encoding}",
162 'type' => "enum",
163 'deft' => "auto",
164 'list' => $encoding_plus_auto_list,
165 'reqd' => "no" },
166 { 'name' => "smart_block",
167 'desc' => "{common.deprecated}. {BasePlugin.smart_block}",
168 'type' => "flag",
169 'reqd' => "no",
170 'hiddengli' => "yes" }, # deprecated, but leave in for old collections
171 { 'name' => "file_rename_method",
172 'desc' => "{BasePlugin.file_rename_method}",
173 'type' => "enum",
174 'deft' => &get_default_file_rename_method(), # by default rename imported files and assoc files using this encoding
175 'list' => $file_rename_method_list,
176 'reqd' => "no"
177 }
178
179 ];
180
181
182my $options = { 'name' => "BasePlugin",
183 'desc' => "{BasePlugin.desc}",
184 'abstract' => "yes",
185 'inherits' => "no",
186 'args' => $arguments };
187
188sub new {
189
190 my ($class) = shift (@_);
191 my ($pluginlist,$inputargs,$hashArgOptLists,$auxiliary) = @_;
192 push(@$pluginlist, $class);
193
194 push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});
195 push(@{$hashArgOptLists->{"OptList"}},$options);
196
197 my $self = new PrintInfo($pluginlist, $inputargs, $hashArgOptLists,$auxiliary);
198
199 if ($self->{'info_only'}) {
200 # don't worry about any options etc
201 return bless $self, $class;
202 }
203
204 if ($self->{'smart_block'}) {
205 print STDERR "WARNING: -smart_block option has been deprecated and is no longer useful\n";
206 }
207 $self->{'smart_block'} = undef;
208
209 my $plugin_name = (defined $pluginlist->[0]) ? $pluginlist->[0] : $class;
210 $self->{'plugin_type'} = $plugin_name;
211
212 # remove ex. from OIDmetadata iff it's the only namespace prefix
213 $self->{'OIDmetadata'} =~ s/^ex\.([^.]+)$/$1/ if defined $self->{'OIDmetadata'};
214 $self->{'num_processed'} = 0;
215 $self->{'num_not_processed'} = 0;
216 $self->{'num_blocked'} = 0;
217 $self->{'num_archives'} = 0;
218 $self->{'cover_image'} = 1; # cover image is on by default
219 $self->{'cover_image'} = 0 if ($self->{'no_cover_image'});
220 $self->{'can_process_directories'} = 0;
221 #$self->{'option_list'} = $hashArgOptLists->{"OptList"};
222
223 my $associate_ext = $self->{'associate_ext'};
224 if ((defined $associate_ext) && ($associate_ext ne "")) {
225
226 my $associate_tail_re = $self->{'associate_tail_re'};
227 if ((defined $associate_tail_re) && ($associate_tail_re ne "")) {
228 my $outhandle = $self->{'outhandle'};
229 print $outhandle "Warning: can only specify 'associate_ext' or 'associate_tail_re'\n";
230 print $outhandle " defaulting to 'associate_tail_re'\n";
231 }
232 else {
233 my @exts = split(/,/,$associate_ext);
234
235 my @exts_bracketed = map { $_ = "(?:\\.$_)" } @exts;
236 my $associate_tail_re = join("|",@exts_bracketed);
237 $self->{'associate_tail_re'} = $associate_tail_re;
238 }
239
240 delete $self->{'associate_ext'};
241 }
242
243 return bless $self, $class;
244
245}
246
247sub merge_inheritance
248{
249 my $self = {};
250 my @child_selfs = @_;
251
252 foreach my $child_self (@child_selfs) {
253 foreach my $key (keys %$child_self) {
254 if (defined $self->{$key}) {
255 if ($self->{$key} ne $child_self->{$key}) {
256# print STDERR "Warning: Conflicting value in multiple inheritance for '$key'\n";
257# print STDERR "Existing stored value = $self->{$key}\n";
258# print STDERR "New (child) value = $child_self->{$key}\n";
259# print STDERR "Keeping existing value\n";
260 # Existing value seems to be option specified in collect.cfg
261
262 ### $self->{$key} = $child_self->{$key};
263
264 }
265 else {
266## print STDERR "****Info: Value $self->{$key} for $key already defined through multiple inheritance as the same value\n";
267 }
268
269 }
270 else {
271 $self->{$key} = $child_self->{$key};
272 }
273 }
274 }
275
276 return $self;
277}
278
279# initialize BasePlugin options
280# if init() is overridden in a sub-class, remember to call BasePlugin::init()
281sub init {
282 my $self = shift (@_);
283 my ($verbosity, $outhandle, $failhandle) = @_;
284
285 # verbosity is passed through from the processor
286 $self->{'verbosity'} = $verbosity;
287
288 # as are the outhandle and failhandle
289 $self->{'outhandle'} = $outhandle if defined $outhandle;
290 $self->{'failhandle'} = $failhandle;
291# $self->SUPER::init(@_);
292
293 # set process_exp and block_exp to defaults unless they were
294 # explicitly set
295
296 if ((!$self->is_recursive()) and
297 (!defined $self->{'process_exp'}) || ($self->{'process_exp'} eq "")) {
298
299 $self->{'process_exp'} = $self->get_default_process_exp ();
300 if ($self->{'process_exp'} eq "") {
301 warn ref($self) . " Warning: Non-recursive plugin has no process_exp\n";
302 }
303 }
304
305 if ((!defined $self->{'block_exp'}) || ($self->{'block_exp'} eq "")) {
306 $self->{'block_exp'} = $self->get_default_block_exp ();
307 }
308
309}
310
311sub begin {
312 my $self = shift (@_);
313 my ($pluginfo, $base_dir, $processor, $maxdocs) = @_;
314
315 if ($self->{'OIDtype'} eq "auto") {
316 # hasn't been set in the plugin, use the processor values
317 $self->{'OIDtype'} = $processor->{'OIDtype'};
318 $self->{'OIDmetadata'} = $processor->{'OIDmetadata'};
319 }
320 if ($self->{'OIDtype'} eq "hash") {
321 # should we hash on the file or on the doc xml??
322 $self->{'OIDtype'} = $self->get_oid_hash_type();
323 if ($self->{'OIDtype'} !~ /^(hash_on_file|hash_on_ga_xml)$/) {
324 $self->{'OIDtype'} = "hash_on_file";
325 }
326 }
327}
328
329# This is called once if removeold is set with import.pl. Most plugins will do
330# nothing but if a plugin does any stuff outside of creating doc obj, then
331# it may need to clear something.
332sub remove_all {
333 my $self = shift (@_);
334 my ($pluginfo, $base_dir, $processor, $maxdocs) = @_;
335}
336
337# This is called per document for docs that have been deleted from the
338# collection. Most plugins will do nothing
339# but if a plugin does any stuff outside of creating doc obj, then it may need
340# to clear something.
341sub remove_one {
342 my $self = shift (@_);
343
344 my ($file, $oids, $archivedir) = @_;
345 return 0 if $self->can_process_this_file($file);
346 return undef;
347}
348
349sub end {
350 # potentially called at the end of each plugin pass
351 # import.pl only has one plugin pass, but buildcol.pl has multiple ones
352
353 my ($self) = shift (@_);
354}
355
356sub deinit {
357 # called only once, after all plugin passes have been done
358
359 my ($self) = @_;
360}
361
362# default hashing type is to hash on the original file (or converted file)
363# override this to return hash_on_ga_xml for filetypes where hashing on the
364# file is no good eg video
365sub get_oid_hash_type {
366
367 my $self = shift (@_);
368
369 return "hash_on_file";
370}
371
372
373# this function should be overridden to return 1
374# in recursive plugins
375sub is_recursive {
376 my $self = shift (@_);
377
378 return 0;
379}
380
381sub get_default_block_exp {
382 my $self = shift (@_);
383
384 return "";
385}
386
387sub get_default_process_exp {
388 my $self = shift (@_);
389
390 return "";
391}
392
393
394# rename imported files and assoc files using URL encoding by default
395# as this will work for most plugins and give more legible filenames
396sub get_default_file_rename_method() {
397 my $self = shift (@_);
398 return "url";
399}
400
401# returns this plugin's active (possibly user-selected) file_rename_method
402sub get_file_rename_method() {
403 my $self = shift (@_);
404 my $rename_method = $self->{'file_rename_method'};
405 if($rename_method) {
406 return $rename_method;
407 } else {
408 return $self->get_default_file_rename_method();
409 }
410}
411
412# default implementation is to do nothing
413sub store_block_files {
414
415 my $self =shift (@_);
416 my ($filename_full_path, $block_hash) = @_;
417
418}
419
420# put files to block into hash
421sub use_block_expressions {
422
423 my $self =shift (@_);
424 my ($filename_full_path, $block_hash) = @_;
425
426 $filename_full_path = &util::upgrade_if_dos_filename($filename_full_path);
427
428 if ($self->{'block_exp'} ne "" && $filename_full_path =~ /$self->{'block_exp'}/) {
429 &util::block_filename($block_hash,$filename_full_path);
430 }
431
432}
433
434#default implementation is to block a file with same name as this, but extension jpg or JPG, if cover_images is on.
435sub block_cover_image
436{
437 my $self =shift;
438 my ($filename, $block_hash) = @_;
439
440 $filename = &util::upgrade_if_dos_filename($filename);
441
442 if ($self->{'cover_image'}) {
443 my $coverfile = $filename;
444 $coverfile =~ s/\.[^\\\/\.]+$/\.jpg/;
445
446 #if there is no file extension, coverfile will be the same as filename
447 return if $coverfile eq $filename;
448
449 if (!&util::fd_exists($coverfile)) {
450 $coverfile =~ s/jpg$/JPG/;
451 }
452 if (&util::fd_exists($coverfile)) {
453 &util::block_filename($block_hash,$coverfile);
454 }
455 }
456
457 return;
458}
459
460
461# discover all the files that should be blocked by this plugin
462# check the args ...
463sub file_block_read {
464
465 my $self = shift (@_);
466 my ($pluginfo, $base_dir, $file, $block_hash, $metadata, $gli) = @_;
467 # Keep track of filenames with same root but different extensions
468 # Used to support -associate_ext and the more generalised
469 # -associate_tail_re
470 my ($filename_full_path, $filename_no_path) = &util::get_full_filenames($base_dir, $file);
471
472 if (!-d $filename_full_path) {
473 $block_hash->{'all_files'}->{$file} = 1;
474 }
475
476 my $associate_tail_re = $self->{'associate_tail_re'};
477 if ((defined $associate_tail_re) && ($associate_tail_re ne "")) {
478 my ($file_prefix,$file_ext)
479 = &util::get_prefix_and_tail_by_regex($filename_full_path,$associate_tail_re);
480 if ((defined $file_prefix) && (defined $file_ext)) {
481 my $shared_fileroot = $block_hash->{'shared_fileroot'};
482 if (!defined $shared_fileroot->{$file_prefix}) {
483 my $file_prefix_rec = { 'tie_to' => undef,
484 'exts' => {} };
485 $shared_fileroot->{$file_prefix} = $file_prefix_rec;
486 }
487
488 my $file_prefix_rec = $shared_fileroot->{$file_prefix};
489
490 if ($self->can_process_this_file($filename_full_path)) {
491 # This is the document the others should be tied to
492 $file_prefix_rec->{'tie_to'} = $file_ext;
493 }
494 else {
495 if ($file_ext =~ m/$associate_tail_re$/) {
496 # this file should be associated to the main one
497 $file_prefix_rec->{'exts'}->{$file_ext} = 1;
498 }
499 }
500
501 }
502 }
503
504 # check block expressions
505 $self->use_block_expressions($filename_full_path, $block_hash) unless $self->{'no_blocking'};
506
507 # now check whether we are actually processing this
508 if (!-f $filename_full_path || !$self->can_process_this_file($filename_full_path)) {
509 return undef; # can't recognise
510 }
511
512 # if we have a block_exp, then this overrides the normal 'smart' blocking
513 $self->store_block_files($filename_full_path, $block_hash) unless ($self->{'no_blocking'} || $self->{'block_exp'} ne "");
514
515 # block the cover image if there is one
516 if ($self->{'cover_image'}) {
517 $self->block_cover_image($filename_full_path, $block_hash);
518 }
519
520 return 1;
521}
522
523# plugins that rely on more than process_exp (eg XML plugins) can override this method
524sub can_process_this_file {
525 my $self = shift(@_);
526 my ($filename) = @_;
527
528 if (-d $filename && !$self->{'can_process_directories'}) {
529 return 0;
530 }
531
532 if ($self->{'process_exp'} ne "" && $filename =~ /$self->{'process_exp'}/) {
533 return 1;
534 }
535 return 0;
536
537}
538
539# Even if a plugin can extract metadata in its metadata_read pass,
540# make the default return 'undef' so processing of the file continues
541# down the pipeline, so other plugins can also have the opportunity to
542# locate metadata and set it up in the extrametakeys variables that
543# are passed around.
544
545sub can_process_this_file_for_metadata {
546 my $self = shift(@_);
547
548 return undef;
549}
550
551
552# just converts path as is to utf8.
553sub filepath_to_utf8 {
554 my $self = shift (@_);
555 my ($file, $file_encoding) = @_;
556 my $filemeta = $file;
557
558 my $filename_encoding = $self->{'filename_encoding'}; # filename encoding setting
559
560 # Whenever filename-encoding is set to any of the auto settings, we
561 # check if the filename is already in UTF8. If it is, then we're done.
562 if($filename_encoding =~ m/auto/) {
563 if(&unicode::check_is_utf8($filemeta))
564 {
565 $filename_encoding = "utf8";
566 return $filemeta;
567 }
568 }
569
570 # Auto setting, but filename is not utf8
571 if ($filename_encoding eq "auto")
572 {
573 # try textcat
574 $filename_encoding = $self->textcat_encoding($filemeta);
575
576 # check the locale next
577 $filename_encoding = $self->locale_encoding() if $filename_encoding eq "undefined";
578
579
580 # now try the encoding of the document, if available
581 if ($filename_encoding eq "undefined" && defined $file_encoding) {
582 $filename_encoding = $file_encoding;
583 }
584
585 }
586
587 elsif ($filename_encoding eq "auto-language-analysis")
588 {
589 $filename_encoding = $self->textcat_encoding($filemeta);
590
591 # now try the encoding of the document, if available
592 if ($filename_encoding eq "undefined" && defined $file_encoding) {
593 $filename_encoding = $file_encoding;
594 }
595 }
596
597 elsif ($filename_encoding eq "auto-filesystem-encoding")
598 {
599 # try locale
600 $filename_encoding = $self->locale_encoding();
601 }
602
603 elsif ($filename_encoding eq "auto-fl")
604 {
605 # filesystem-encoding (locale) then language-analysis (textcat)
606 $filename_encoding = $self->locale_encoding();
607
608 # try textcat
609 $filename_encoding = $self->textcat_encoding($filemeta) if $filename_encoding eq "undefined";
610
611 # else assume filename encoding is encoding of file content, if that's available
612 if ($filename_encoding eq "undefined" && defined $file_encoding) {
613 $filename_encoding = $file_encoding;
614 }
615 }
616
617 elsif ($filename_encoding eq "auto-lf")
618 {
619 # language-analysis (textcat) then filesystem-encoding (locale)
620 $filename_encoding = $self->textcat_encoding($filemeta);
621
622 # guess filename encoding from encoding of file content, if available
623 if ($filename_encoding eq "undefined" && defined $file_encoding) {
624 $filename_encoding = $file_encoding;
625 }
626
627 # try locale
628 $filename_encoding = $self->locale_encoding() if $filename_encoding eq "undefined";
629 }
630
631 # if still undefined, use utf8 as fallback
632 if ($filename_encoding eq "undefined") {
633 $filename_encoding = "utf8";
634 }
635
636 #print STDERR "**** UTF8 encoding the filename $filemeta ";
637
638 # if the filename encoding is set to utf8 but it isn't utf8 already--such as when
639 # 1. the utf8 fallback is used, or 2. if the system locale is used and happens to
640 # be always utf8 (in which case the filename's encoding is also set as utf8 even
641 # though the filename need not be if it originates from another system)--in such
642 # cases attempt to make the filename utf8 to match.
643 if($filename_encoding eq "utf8" && !&unicode::check_is_utf8($filemeta)) {
644 &unicode::ensure_utf8(\$filemeta);
645 }
646
647 # convert non-unicode encodings to utf8
648 if ($filename_encoding !~ m/(?:ascii|utf8|unicode)/) {
649 $filemeta = &unicode::unicode2utf8(
650 &unicode::convert2unicode($filename_encoding, \$filemeta)
651 );
652 }
653
654 #print STDERR " from encoding $filename_encoding -> $filemeta\n";
655 return $filemeta;
656}
657
658# gets the filename with no path, converts to utf8, and then dm safes it.
659# filename_encoding set by user
660sub filename_to_utf8_metadata
661{
662 my $self = shift (@_);
663 my ($file, $file_encoding) = @_;
664
665 my $outhandle = $self->{'outhandle'};
666
667 print $outhandle "****!!!!**** BasePlugin::filename_to_utf8_metadata now deprecated\n";
668 my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(0);
669 print $outhandle "Calling method: $cfilename:$cline $cpackage->$csubr\n";
670
671
672 my ($filemeta) = $file =~ /([^\\\/]+)$/; # getting the tail of the filepath (skips all string parts containing slashes upto the end)
673 $filemeta = $self->filepath_to_utf8($filemeta, $file_encoding);
674
675 return $filemeta;
676}
677
678sub locale_encoding {
679 my $self = shift(@_);
680
681 if (!defined $self->{'filesystem_encoding'}) {
682 $self->{'filesystem_encoding'} = $self->get_filesystem_encoding();
683 }
684
685 #print STDERR "*** filename encoding determined based on locale: " . $self->{'filesystem_encoding'} . "\n";
686 return $self->{'filesystem_encoding'}; # can be the string "undefined"
687}
688
689sub textcat_encoding {
690 my $self = shift(@_);
691 my ($filemeta) = @_;
692
693 # analyse filenames without extensions and digits (and trimmed of
694 # surrounding whitespace), so that irrelevant chars don't confuse
695 # textcat
696 my $strictfilemeta = $filemeta;
697 $strictfilemeta =~ s/\.[^\.]+$//g;
698 $strictfilemeta =~ s/\d//g;
699 $strictfilemeta =~ s/^\s*//g;
700 $strictfilemeta =~ s/\s*$//g;
701
702 my $filename_encoding = $self->encoding_from_language_analysis($strictfilemeta);
703 if(!defined $filename_encoding) {
704 $filename_encoding = "undefined";
705 }
706
707 return $filename_encoding; # can be the string "undefined"
708}
709
710# performs textcat
711sub encoding_from_language_analysis {
712 my $self = shift(@_);
713 my ($text) = @_;
714
715 my $outhandle = $self->{'outhandle'};
716 my $best_encoding = undef;
717
718 # get the language/encoding of the textstring using textcat
719 require textcat; # Only load the textcat module if it is required
720 $self->{'textcat'} = new textcat() unless defined($self->{'textcat'});
721 my $results = $self->{'textcat'}->classify_cached_filename(\$text);
722
723
724 if (scalar @$results < 0) {
725 return undef;
726 }
727
728 # We have some results, we choose the first
729 my ($language, $encoding) = $results->[0] =~ /^([^-]*)(?:-(.*))?$/;
730
731 $best_encoding = $encoding;
732 if (!defined $best_encoding) {
733 return undef;
734 }
735
736 if (defined $best_encoding && $best_encoding =~ m/^iso_8859/ && &unicode::check_is_utf8($text)) {
737 # the text is valid utf8, so assume that's the real encoding (since textcat is based on probabilities)
738 $best_encoding = 'utf8';
739 }
740
741
742 # check for equivalents where textcat doesn't have some encodings...
743 # eg MS versions of standard encodings
744 if (defined $best_encoding && $best_encoding =~ /^iso_8859_(\d+)/) {
745 my $iso = $1; # which variant of the iso standard?
746 # iso-8859 sets don't use chars 0x80-0x9f, windows codepages do
747 if ($text =~ /[\x80-\x9f]/) {
748 # Western Europe
749 if ($iso == 1 or $iso == 15) { $best_encoding = 'windows_1252' }
750 elsif ($iso == 2) {$best_encoding = 'windows_1250'} # Central Europe
751 elsif ($iso == 5) {$best_encoding = 'windows_1251'} # Cyrillic
752 elsif ($iso == 6) {$best_encoding = 'windows_1256'} # Arabic
753 elsif ($iso == 7) {$best_encoding = 'windows_1253'} # Greek
754 elsif ($iso == 8) {$best_encoding = 'windows_1255'} # Hebrew
755 elsif ($iso == 9) {$best_encoding = 'windows_1254'} # Turkish
756 }
757 }
758
759 if (defined $best_encoding && $best_encoding !~ /^(ascii|utf8|unicode)$/ &&
760 !defined $encodings::encodings->{$best_encoding})
761 {
762 if ($self->{'verbosity'}) {
763 gsprintf($outhandle, "BasePlugin: {ReadTextFile.unsupported_encoding}\n", $text, $best_encoding, "undef");
764 }
765 $best_encoding = undef;
766 }
767
768 return $best_encoding;
769}
770
771# uses locale
772sub get_filesystem_encoding
773{
774
775 my $self = shift(@_);
776
777 my $outhandle = $self->{'outhandle'};
778 my $filesystem_encoding = undef;
779
780 eval {
781 # Works for Windows as well, returning the DOS code page in use
782 use POSIX qw(locale_h);
783
784 # With only one parameter, setlocale retrieves the
785 # current value
786 my $current_locale = setlocale(LC_CTYPE);
787
788 my $char_encoding = undef;
789 if ($current_locale =~ m/\./) {
790 ($char_encoding) = ($current_locale =~ m/^.*\.(.*?)$/);
791 $char_encoding = lc($char_encoding);
792 }
793 else {
794 if ($current_locale =~ m/^(posix|c)$/i) {
795 $char_encoding = "ascii";
796 }
797 }
798
799 if (defined $char_encoding) {
800 if ($char_encoding =~ m/^(iso)(8859)-?(\d{1,2})$/) {
801 $char_encoding = "$1\_$2\_$3";
802 }
803
804 $char_encoding =~ s/-/_/g;
805 $char_encoding =~ s/^utf_8$/utf8/;
806
807 if ($char_encoding =~ m/^\d+$/) {
808 if (defined $encodings::encodings->{"windows_$char_encoding"}) {
809 $char_encoding = "windows_$char_encoding";
810 }
811 elsif (defined $encodings::encodings->{"dos_$char_encoding"}) {
812 $char_encoding = "dos_$char_encoding";
813 }
814 }
815
816 if (($char_encoding =~ m/(?:ascii|utf8|unicode)/)
817 || (defined $encodings::encodings->{$char_encoding})) {
818 $filesystem_encoding = $char_encoding;
819 }
820 else {
821 print $outhandle "Warning: Unsupported character encoding '$char_encoding' from locale '$current_locale'\n";
822 }
823 }
824
825
826 };
827 if ($@) {
828 print $outhandle "$@\n";
829 print $outhandle "Warning: Unable to establish locale. Will assume filesystem is UTF-8\n";
830
831 }
832
833 return $filesystem_encoding;
834}
835
836
837
838sub deduce_filename_encoding
839{
840 my $self = shift (@_);
841 my ($file,$metadata,$plugin_filename_encoding) = @_;
842
843 my $gs_filename_encoding = $metadata->{"gs.filenameEncoding"};
844 my $deduced_filename_encoding = undef;
845
846 # Start by looking for manually assigned metadata
847 if (defined $gs_filename_encoding) {
848 if (ref ($gs_filename_encoding) eq "ARRAY") {
849 my $outhandle = $self->{'outhandle'};
850
851 $deduced_filename_encoding = $gs_filename_encoding->[0];
852
853 my $num_vals = scalar(@$gs_filename_encoding);
854 if ($num_vals>1) {
855 print $outhandle "Warning: gs.filenameEncoding multiply defined for $file\n";
856 print $outhandle " Selecting first value: $deduced_filename_encoding\n";
857 }
858 }
859 else {
860 $deduced_filename_encoding = $gs_filename_encoding;
861 }
862 }
863
864 if (!defined $deduced_filename_encoding || ($deduced_filename_encoding =~ m/^\s*$/)) {
865 # Look to see if plugin specifies this value
866
867 if (defined $plugin_filename_encoding) {
868 # First look to see if we're using any of the "older" (i.e. deprecated auto-... plugin options)
869 if ($plugin_filename_encoding =~ m/^auto-.*$/) {
870 my $outhandle = $self->{'outhandle'};
871 print $outhandle "Warning: $plugin_filename_encoding is no longer supported\n";
872 print $outhandle " default to 'auto'\n";
873 $self->{'filename_encoding'} = $plugin_filename_encoding = "auto";
874 }
875
876 if ($plugin_filename_encoding ne "auto") {
877 # We've been given a specific filenamne encoding
878 # => so use it!
879 $deduced_filename_encoding = $plugin_filename_encoding;
880 }
881 }
882 }
883
884 if (!defined $deduced_filename_encoding || ($deduced_filename_encoding =~ m/^\s*$/)) {
885
886 # Look to file system to provide a character encoding
887
888 # If Windows NTFS, then -- assuming we work with long file names got through
889 # Win32::GetLongFilePath() -- then the underlying file system is UTF16
890
891 if ($ENV{'GSDLOS'} =~ m/^windows$/i) {
892 # Can do better than working with the DOS character encoding returned by locale
893 $deduced_filename_encoding = "unicode";
894 }
895 else {
896 # Unix of some form or other
897
898 # See if we can determine the file system encoding through locale
899 $deduced_filename_encoding = $self->locale_encoding();
900
901 # if locale shows us filesystem is utf8, check to see filename is consistent
902 # => if not, then we have an "alien" filename on our hands
903
904 if (defined $deduced_filename_encoding && $deduced_filename_encoding =~ m/^utf-?8$/i) {
905 if (!&unicode::check_is_utf8($file)) {
906 # "alien" filename, so revert
907 $deduced_filename_encoding = undef;
908 }
909 }
910 }
911 }
912
913# if (!defined $deduced_filename_encoding || ($deduced_filename_encoding =~ m/^\s*$/)) {
914# # Last chance, apply textcat to deduce filename encoding
915# $deduced_filename_encoding = $self->textcat_encoding($file);
916# }
917
918 if ($self->{'verbosity'}>3) {
919 my $outhandle = $self->{'outhandle'};
920
921 if (defined $deduced_filename_encoding) {
922 print $outhandle " Deduced filename encoding as: $deduced_filename_encoding\n";
923 }
924 else {
925 print $outhandle " No filename encoding deduced\n";
926 }
927 }
928
929 return $deduced_filename_encoding;
930}
931
932
933
934
935# Notionally written to be called once for each document, it is however safe to
936# call multiple times (as in the case of ImagePlugin) which calls this later on
937# after the original image has potentially been converted to a *new* source image
938# format (e.g. TIFF to PNG)
939
940sub set_Source_metadata {
941 my $self = shift (@_);
942 my ($doc_obj, $raw_filename, $filename_encoding, $section) = @_;
943
944 # 1. Sets the filename (Source) for display encoded as Unicode if possible,
945 # and (as a fallback) using %xx if not for non-ascii chars
946 # 2. Sets the url ref (SourceFile) to the URL encoded version
947 # of filename for generated files
948
949 my ($unused_full_rf, $raw_file) = &util::get_full_filenames("", $raw_filename);
950
951 my $this_section = (defined $section)? $section : $doc_obj->get_top_section();
952
953 my $octet_file = $raw_file;
954
955 # UTF-8 version of filename
956# if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
957# print STDERR "**** Setting Source Metadata given: $octet_file\n";
958# }
959
960 # Deal with (on Windows) raw filenames that are in their
961 # abbreviated DOS form
962
963 if ($ENV{'GSDLOS'} =~ m/^windows$/i) {
964 if ((defined $filename_encoding) && ($filename_encoding eq "unicode")) {
965 if (-e $raw_filename) {
966 my $unicode_filename = Win32::GetLongPathName($raw_filename);
967
968 my $unused_full_uf;
969 ($unused_full_uf, $octet_file) = &util::get_full_filenames("", $unicode_filename);
970 }
971 }
972 }
973
974 my $url_encoded_filename;
975 if ((defined $filename_encoding) && ($filename_encoding ne "ascii")) {
976 # => Generate a pretty print version of filename that is mapped to Unicode
977
978 # Use filename_encoding to map raw filename to a Perl unicode-aware string
979 $url_encoded_filename = decode($filename_encoding,$octet_file);
980 }
981 else {
982 # otherwise generate %xx encoded version of filename for char > 127
983 $url_encoded_filename = &unicode::raw_filename_to_url_encoded($octet_file);
984 }
985
986# if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
987# print STDERR "****** saving Source as: $url_encoded_filename\n";
988# }
989
990 # In the case of converted files and (generalized) exploded documents, there
991 # will already be a source filename => store as OrigSource before overriding
992 my $orig_source = $doc_obj->get_metadata_element ($this_section, "Source");
993 if ((defined $orig_source) && ($orig_source !~ m/^\s*$/)) {
994 $doc_obj->set_utf8_metadata_element($this_section, "OrigSource", $orig_source);
995 }
996
997 # Source is the UTF8 display name - not necessarily the name of the file on the system
998 if ($ENV{'GSDLOS'} =~ m/^darwin$/i) {
999 # on Darwin want all display strings to be in composed form, then can search on that
1000 $url_encoded_filename = normalize('C', $url_encoded_filename); # Normalisation Form 'C' (composition)
1001 }
1002 $doc_obj->set_utf8_metadata_element($this_section, "Source", $url_encoded_filename);
1003
1004
1005 my $renamed_raw_file = &util::rename_file($raw_file, $self->{'file_rename_method'});
1006 # If using URL encoding, then SourceFile is the url-reference to url-encoded
1007 # renamed_raw_url: it's a url that refers to the actual file on the system
1008 my $renamed_raw_url = &unicode::filename_to_url($renamed_raw_file);
1009
1010 $doc_obj->set_utf8_metadata_element($this_section, "SourceFile",
1011 $renamed_raw_url);
1012
1013# if ((defined $ENV{"DEBUG_UNICODE"}) && ($ENV{"DEBUG_UNICODE"})) {
1014# print STDERR "****** saving SourceFile as: $renamed_raw_url\n";
1015# }
1016}
1017
1018# this should be called by all plugins to set the oid of the doc obj, rather
1019# than calling doc_obj->set_OID directly
1020sub add_OID {
1021 my $self = shift (@_);
1022 my ($doc_obj) = @_;
1023
1024 # don't add one if there is one already set
1025 return unless $doc_obj->get_OID() =~ /^NULL$/;
1026 $doc_obj->set_OIDtype($self->{'OIDtype'}, $self->{'OIDmetadata'});
1027
1028 # see if there is a plugin specific set_OID function
1029 if (defined ($self->can('set_OID'))) {
1030 $self->set_OID(@_); # pass through doc_obj and any extra arguments
1031 }
1032 else {
1033 # use the default set_OID() in doc.pm
1034 $doc_obj->set_OID();
1035 }
1036
1037}
1038
1039# The BasePlugin read_into_doc_obj() function. This function does all the
1040# right things to make general options work for a given plugin. It doesn't do anything with the file other than setting reads in
1041# a file and sets up a slew of metadata all saved in doc_obj, which
1042# it then returns as part of a tuple (process_status,doc_obj)
1043#
1044# Much of this functionality used to reside in read, but it was broken
1045# down into a supporting routine to make the code more flexible.
1046#
1047# recursive plugins (e.g. RecPlug) and specialized plugins like those
1048# capable of processing many documents within a single file (e.g.
1049# GMLPlug) will normally want to implement their own version of
1050# read_into_doc_obj()
1051#
1052# Note that $base_dir might be "" and that $file might
1053# include directories
1054
1055# currently blocking has been done before it gets here - does this affect secondary plugin stuff??
1056sub read_into_doc_obj {
1057 my $self = shift (@_);
1058 my ($pluginfo, $base_dir, $file, $block_hash, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
1059
1060 my $outhandle = $self->{'outhandle'};
1061
1062 # should we move this to read? What about secondary plugins?
1063 my $pp_file = &util::prettyprint_file($base_dir,$file,$gli);
1064 print STDERR "<Processing n='$file' p='$self->{'plugin_type'}'>\n" if ($gli);
1065 print $outhandle "$self->{'plugin_type'} processing $pp_file\n"
1066 if $self->{'verbosity'} > 1;
1067
1068 my ($filename_full_path, $filename_no_path) = &util::get_full_filenames($base_dir, $file);
1069
1070 # create a new document
1071 my $doc_obj = new doc ($filename_full_path, "indexed_doc", $self->{'file_rename_method'});
1072 my $top_section = $doc_obj->get_top_section();
1073
1074 $doc_obj->add_utf8_metadata($top_section, "Plugin", "$self->{'plugin_type'}");
1075 $doc_obj->add_utf8_metadata($top_section, "FileSize", (-s $filename_full_path));
1076
1077
1078 my $plugin_filename_encoding = $self->{'filename_encoding'};
1079 my $filename_encoding = $self->deduce_filename_encoding($file,$metadata,$plugin_filename_encoding);
1080 $self->set_Source_metadata($doc_obj,$filename_full_path,$filename_encoding,$top_section);
1081
1082 # plugin specific stuff - what args do we need here??
1083 unless (defined ($self->process($pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli))) {
1084 print STDERR "<ProcessingError n='$file'>\n" if ($gli);
1085 return -1;
1086 }
1087
1088 # include any metadata passed in from previous plugins
1089 # note that this metadata is associated with the top level section
1090 my $section = $doc_obj->get_top_section();
1091 # can we merge these two methods??
1092 $self->add_associated_files($doc_obj, $filename_full_path);
1093 $self->extra_metadata ($doc_obj, $section, $metadata);
1094 $self->auto_extract_metadata($doc_obj);
1095
1096 # if we haven't found any Title so far, assign one
1097 # this was shifted to here from inside read()
1098 $self->title_fallback($doc_obj,$section,$filename_no_path);
1099
1100 $self->add_OID($doc_obj);
1101
1102 $self->post_process_doc_obj($pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli);
1103 return (1,$doc_obj);
1104}
1105
1106sub post_process_doc_obj {
1107 my $self = shift (@_);
1108 my ($pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli) = @_;
1109
1110 return 1;
1111}
1112
1113sub add_dummy_text {
1114 my $self = shift(@_);
1115 my ($doc_obj, $section) = @_;
1116
1117 # add NoText metadata so we can hide this dummy text in format statements
1118 $doc_obj->add_metadata($section, "NoText", "1");
1119 $doc_obj->add_text($section, &gsprintf::lookup_string("{BasePlugin.dummy_text}",1));
1120
1121}
1122
1123# does nothing. Can be overridden by subclass
1124sub auto_extract_metadata {
1125 my $self = shift(@_);
1126 my ($doc_obj) = @_;
1127}
1128
1129# adds cover image, associate_file options stuff. Should be called by sub class
1130# read_into_doc_obj
1131sub add_associated_files {
1132 my $self = shift(@_);
1133 # whatis filename??
1134 my ($doc_obj, $filename) = @_;
1135
1136 # add in the cover image
1137 if ($self->{'cover_image'}) {
1138 $self->associate_cover_image($doc_obj, $filename);
1139 }
1140 # store the original (used for eg TextPlugin to store the original for OAI)
1141 if ($self->{'store_original_file'}) {
1142 $self->associate_source_file($doc_obj, $filename);
1143 }
1144
1145
1146}
1147
1148# implement this if you are extracting metadata for other documents
1149sub metadata_read {
1150 my $self = shift (@_);
1151 my ($pluginfo, $base_dir, $file, $block_hash,
1152 $extrametakeys, $extrametadata, $extrametafile,
1153 $processor, $gli, $aux) = @_;
1154
1155 # can we process this file??
1156 my ($filename_full_path, $filename_no_path) = &util::get_full_filenames($base_dir, $file);
1157 return undef unless $self->can_process_this_file_for_metadata($filename_full_path);
1158
1159 return 1; # we recognise the file, but don't actually do anything with it
1160}
1161
1162
1163# The BasePlugin read() function. This function calls read_into_doc_obj()
1164# to ensure all the right things to make general options work for a
1165# given plugin are done. It then calls the process() function which
1166# does all the work specific to a plugin (like the old read functions
1167# used to do). Most plugins should define their own process() function
1168# and let this read() function keep control.
1169#
1170# recursive plugins (e.g. RecPlug) and specialized plugins like those
1171# capable of processing many documents within a single file (e.g.
1172# GMLPlug) might want to implement their own version of read(), but
1173# more likely need to implement their own version of read_into_doc_obj()
1174#
1175# Return number of files processed, undef if can't recognise, -1 if can't
1176# process
1177
1178sub read {
1179 my $self = shift (@_);
1180 my ($pluginfo, $base_dir, $file, $block_hash, $metadata, $processor, $maxdocs, $total_count, $gli) = @_;
1181
1182 # can we process this file??
1183 my ($filename_full_path, $filename_no_path) = &util::get_full_filenames($base_dir, $file);
1184
1185 return undef unless $self->can_process_this_file($filename_full_path);
1186
1187 my ($process_status,$doc_obj) = $self->read_into_doc_obj(@_);
1188
1189 if ((defined $process_status) && ($process_status == 1)) {
1190
1191 # process the document
1192 $processor->process($doc_obj);
1193
1194 $self->{'num_processed'} ++;
1195 undef $doc_obj;
1196 }
1197 # delete any temp files that we may have created
1198 $self->clean_up_after_doc_obj_processing();
1199
1200
1201 # if process_status == 1, then the file has been processed.
1202 return $process_status;
1203
1204}
1205
1206# returns undef if file is rejected by the plugin
1207sub process {
1208 my $self = shift (@_);
1209 my ($textref, $pluginfo, $base_dir, $file, $metadata, $doc_obj, $gli) = @_;
1210
1211 gsprintf(STDERR, "BasePlugin::process {common.must_be_implemented}\n");
1212
1213 my ($cpackage,$cfilename,$cline,$csubr,$chas_args,$cwantarray) = caller(1);
1214 print STDERR "Calling method: $cfilename:$cline $cpackage->$csubr\n";
1215
1216 die "\n";
1217
1218 return undef; # never gets here
1219}
1220
1221# overwrite this method to delete any temp files that we have created
1222sub clean_up_after_doc_obj_processing {
1223 my $self = shift(@_);
1224
1225}
1226
1227# write_file -- used by ConvertToPlug, for example in post processing
1228#
1229# where should this go, is here the best place??
1230sub utf8_write_file {
1231 my $self = shift (@_);
1232 my ($textref, $filename) = @_;
1233
1234 if (!open (FILE, ">:utf8", $filename)) {
1235 gsprintf(STDERR, "ConvertToPlug::write_file {ConvertToPlug.could_not_open_for_writing} ($!)\n", $filename);
1236 die "\n";
1237 }
1238 print FILE $$textref;
1239
1240 close FILE;
1241}
1242
1243
1244sub filename_based_title
1245{
1246 my $self = shift (@_);
1247 my ($file) = @_;
1248
1249 my $file_derived_title = $file;
1250 $file_derived_title =~ s/_/ /g;
1251 $file_derived_title =~ s/\.[^.]+$//;
1252
1253 return $file_derived_title;
1254}
1255
1256
1257sub title_fallback
1258{
1259 my $self = shift (@_);
1260 my ($doc_obj,$section,$file) = @_;
1261
1262 if (!defined $doc_obj->get_metadata_element ($section, "Title")
1263 || $doc_obj->get_metadata_element($section, "Title") eq "") {
1264
1265 my $source_file = $doc_obj->get_metadata_element($section, "Source");
1266 my $file_derived_title;
1267 if (defined $source_file) {
1268 $file_derived_title = $self->filename_based_title($source_file);
1269 }
1270 else {
1271 # pp = pretty print
1272 my $pp_file = (defined $source_file) ? $source_file : $file;
1273
1274 my $raw_title = $self->filename_based_title($file);
1275 my $file_derived_title = &unicode::raw_filename_to_url_encoded($raw_title);
1276 }
1277
1278
1279 if (!defined $doc_obj->get_metadata_element ($section, "Title")) {
1280 $doc_obj->add_utf8_metadata ($section, "Title", $file_derived_title);
1281 }
1282 else {
1283 $doc_obj->set_utf8_metadata_element ($section, "Title", $file_derived_title);
1284 }
1285 }
1286
1287}
1288
1289# add any extra metadata that's been passed around from one
1290# plugin to another.
1291# extra_metadata uses add_utf8_metadata so it expects metadata values
1292# to already be in utf8
1293sub extra_metadata {
1294 my $self = shift (@_);
1295 my ($doc_obj, $cursection, $metadata) = @_;
1296
1297 my $associate_tail_re = $self->{'associate_tail_re'};
1298
1299 foreach my $field (keys(%$metadata)) {
1300 # $metadata->{$field} may be an array reference
1301 if ($field eq "gsdlassocfile_tobe") {
1302 # 'gsdlassocfile_tobe' is artificially introduced metadata
1303 # that is used to signal that certain additional files should
1304 # be tied to this document. Useful in situations where a
1305 # metadata pass in the plugin pipeline works out some files
1306 # need to be associated with a document, but the document hasn't
1307 # been formed yet.
1308 my $equiv_form = "";
1309 foreach my $gaf (@{$metadata->{$field}}) {
1310 my ($full_filename,$mimetype) = ($gaf =~ m/^(.*):(.*):$/);
1311 my ($tail_filename) = ($full_filename =~ /^.*[\/\\](.+?)$/);
1312
1313 # we need to make sure the filename is valid utf-8 - we do
1314 # this by url or base64 encoding it
1315 # $tail_filename is the name that we store the file as
1316 $tail_filename = &util::rename_file($tail_filename, $self->{'file_rename_method'});
1317 $doc_obj->associate_file($full_filename,$tail_filename,$mimetype);
1318 $doc_obj->associate_source_file($full_filename);
1319 # If the filename is url_encoded, we need to encode the % signs
1320 # in the filename, so that it works in a url
1321 my $url_tail_filename = &unicode::filename_to_url($tail_filename);
1322 # work out extended tail extension (i.e. matching tail re)
1323
1324 my ($file_prefix,$file_extended_ext)
1325 = &util::get_prefix_and_tail_by_regex($tail_filename,$associate_tail_re);
1326 my ($pre_doc_ext) = ($file_extended_ext =~ m/^(.*)\..*$/);
1327 my ($doc_ext) = ($tail_filename =~ m/^.*\.(.*)$/);
1328
1329 # the greenstone 2 stuff
1330 my $start_doclink = "<a href=\"_httpprefix_/collect/[collection]/index/assoc/{Or}{[parent(Top):assocfilepath],[assocfilepath]}/$url_tail_filename\">";
1331 #my $start_doclink = "<a href=\'_httpprefix_/collect/[collection]/index/assoc/[assocfilepath]/$url_tail_filename\'>";
1332 my $start_doclink_gs3 = "<a href=\'_httpprefix_/collect/[collection]/index/assoc/[assocfilepath]/$url_tail_filename\'>";
1333
1334 my $srcicon = "_icon".$doc_ext."_";
1335 my $end_doclink = "</a>";
1336
1337 my $assoc_form = "$start_doclink\{If\}{$srcicon,$srcicon,$doc_ext\}$end_doclink";
1338
1339
1340 if (defined $pre_doc_ext && $pre_doc_ext ne "") {
1341 # for metadata such as [mp3._edited] [mp3._full] ...
1342 $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.$pre_doc_ext", $assoc_form);
1343 }
1344
1345 # for multiple metadata such as [mp3.assoclink]
1346 $doc_obj->add_utf8_metadata ($cursection, "$doc_ext.assoclink", $assoc_form);
1347
1348 $equiv_form .= " $assoc_form";
1349
1350 # following are used for greenstone 3,
1351 $doc_obj->add_utf8_metadata ($cursection, "equivDocLink", $start_doclink_gs3);
1352 $doc_obj->add_utf8_metadata ($cursection, "equivDocIcon", $srcicon);
1353 $doc_obj->add_utf8_metadata ($cursection, "/equivDocLink", $end_doclink);
1354
1355 }
1356 $doc_obj->add_utf8_metadata ($cursection, "equivlink", $equiv_form);
1357 }
1358 elsif ($field eq "gsdlzipfilename") {
1359 # special case for when files have come out of a zip. source_path
1360 # (used for archives dbs and keeping track for incremental import)
1361 # must be set to the zip file name
1362 my $zip_filename = $metadata->{$field};
1363 # overwrite the source_path
1364 $doc_obj->set_source_path($zip_filename);
1365 # and set the metadata
1366 $zip_filename = &util::filename_within_collection($zip_filename);
1367 $zip_filename = $doc_obj->encode_filename($zip_filename, $self->{'file_rename_method'});
1368 $doc_obj->add_utf8_metadata ($cursection, $field, $zip_filename);
1369 }
1370 elsif (ref ($metadata->{$field}) eq "ARRAY") {
1371 map {
1372 $doc_obj->add_utf8_metadata ($cursection, $field, $_);
1373 } @{$metadata->{$field}};
1374 } else {
1375 $doc_obj->add_utf8_metadata ($cursection, $field, $metadata->{$field});
1376 }
1377 }
1378}
1379
1380
1381sub compile_stats {
1382 my $self = shift(@_);
1383 my ($stats) = @_;
1384
1385 $stats->{'num_processed'} += $self->{'num_processed'};
1386 $stats->{'num_not_processed'} += $self->{'num_not_processed'};
1387 $stats->{'num_archives'} += $self->{'num_archives'};
1388
1389}
1390sub associate_source_file {
1391 my $self = shift(@_);
1392
1393 my ($doc_obj, $filename) = @_;
1394 my $cursection = $doc_obj->get_top_section();
1395 my $assocfilename = $doc_obj->get_assocfile_from_sourcefile();
1396
1397 $doc_obj->associate_file($filename, $assocfilename, undef, $cursection);
1398 # srclink_file is now deprecated because of the "_" in the metadataname. Use srclinkFile
1399 $doc_obj->add_utf8_metadata ($cursection, "srclink_file", $doc_obj->get_sourcefile());
1400 $doc_obj->add_utf8_metadata ($cursection, "srclinkFile", $doc_obj->get_sourcefile());
1401}
1402
1403sub associate_cover_image {
1404 my $self = shift(@_);
1405 my ($doc_obj, $filename) = @_;
1406
1407 my $upgraded_filename = &util::upgrade_if_dos_filename($filename);
1408
1409 $filename =~ s/\.[^\\\/\.]+$/\.jpg/;
1410 $upgraded_filename =~ s/\.[^\\\/\.]+$/\.jpg/;
1411
1412 if (exists $self->{'covers_missing_cache'}->{$upgraded_filename}) {
1413 # don't stat() for existence e.g. for multiple document input files
1414 # (eg SplitPlug)
1415 return;
1416 }
1417
1418 my $top_section=$doc_obj->get_top_section();
1419
1420 if (&util::fd_exists($upgraded_filename)) {
1421 $doc_obj->associate_source_file($filename);
1422 $doc_obj->associate_file($filename, "cover.jpg", "image/jpeg");
1423 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1424 } else {
1425 my $upper_filename = $filename;
1426 my $upgraded_upper_filename = $upgraded_filename;
1427
1428 $upper_filename =~ s/jpg$/JPG/;
1429 $upgraded_upper_filename =~ s/jpg$/JPG/;
1430
1431 if (&util::fd_exists($upgraded_upper_filename)) {
1432 $doc_obj->associate_source_file($upper_filename);
1433 $doc_obj->associate_file($upper_filename, "cover.jpg",
1434 "image/jpeg");
1435 $doc_obj->add_utf8_metadata($top_section, "hascover", 1);
1436 } else {
1437 # file doesn't exist, so record the fact that it's missing so
1438 # we don't stat() again (stat is slow)
1439 $self->{'covers_missing_cache'}->{$upgraded_filename} = 1;
1440 }
1441 }
1442
1443}
1444
1445
1446# Overridden by exploding plugins (eg. ISISPlug)
1447sub clean_up_after_exploding
1448{
1449 my $self = shift(@_);
1450}
1451
1452
1453
14541;
Note: See TracBrowser for help on using the repository browser.