source: main/trunk/greenstone2/perllib/classify.pm@ 27375

Last change on this file since 27375 was 27375, checked in by jmt12, 11 years ago

Replaced a conditional add to INC with the call to the new function in util.pm
  • Property svn:keywords set to Author Date Id Revision
File size: 14.4 KB
Line 
1###########################################################################
2#
3# classify.pm --
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
26# functions to handle classifiers
27
28package classify;
29
30require util;
31use FileUtils;
32require AllList;
33
34use dbutil;
35use gsprintf;
36use strict; no strict 'subs';
37
38
39sub gsprintf
40{
41 return &gsprintf::gsprintf(@_);
42}
43
44
45sub load_classifier_for_info {
46 my ($classifier) = shift @_;
47
48 # find the classifier
49 # - used to have hardcoded list of places to load classifier from. We
50 # should, instead, try loading from all of the perllib places on the
51 # library path, as that improves support for extensions. Special cases
52 # needed for collection specific and custom classifier. [jmt12]
53 my @possible_class_paths;
54 if (defined($ENV{'GSDLCOLLECTION'}))
55 {
56 push(@possible_class_paths, &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'}, 'custom', $ENV{'GSDLCOLLECTION'}, 'perllib', 'classify', $classifier . '.pm'));
57 }
58 # (why does GSDLCOLLECTDIR get set to GSDLHOME for classinfo calls?)
59 if ($ENV{'GSDLCOLLECTDIR'} ne $ENV{'GSDLHOME'})
60 {
61 push(@possible_class_paths, &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'}, 'perllib', 'classify', $classifier . '.pm'));
62 }
63 foreach my $library_path (@INC)
64 {
65 # only interested in classify paths found in the library paths
66 if ($library_path =~ /classify$/)
67 {
68 push(@possible_class_paths, &FileUtils::filenameConcatenate($library_path, $classifier . '.pm'));
69 }
70 }
71 my $found_class = 0;
72 foreach my $possible_class_path (@possible_class_paths)
73 {
74 if (-e $possible_class_path)
75 {
76 require $possible_class_path;
77 $found_class = 1;
78 last;
79 }
80 }
81 if (!$found_class)
82 {
83 &gsprintf(STDERR, "{classify.could_not_find_classifier}\n", $classifier) && die "\n";
84 }
85
86 my ($classobj);
87 my $options = "-gsdlinfo";
88 eval ("\$classobj = new \$classifier([],[$options])");
89 die "$@" if $@;
90
91 return $classobj;
92}
93
94sub load_classifiers {
95 my ($classify_list, $build_dir, $outhandle) = @_;
96 my @classify_objects = ();
97 my $classify_number = 1;
98
99 # - ensure colclassdir doesn't already exist in INC before adding, other-
100 # wise we risk clobbering classifier inheritence implied by order of paths
101 # in INC [jmt12]
102 my $colclassdir = &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'},"perllib/classify");
103 &util::augmentINC($colclassdir);
104
105 foreach my $classifyoption (@$classify_list) {
106
107 # get the classifier name
108 my $classname = shift @$classifyoption;
109 next unless defined $classname;
110
111 # find the classifier
112 # - replaced as explained in load_classifier_for_info() [jmt12]
113 my @possible_class_paths;
114 if (defined($ENV{'GSDLCOLLECTION'}))
115 {
116 push(@possible_class_paths, &FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'}, 'custom', $ENV{'GSDLCOLLECTION'}, 'perllib', 'classify', $classname . '.pm'));
117 }
118 # (why does GSDLCOLLECTDIR get set to GSDLHOME for classinfo calls?)
119 if ($ENV{'GSDLCOLLECTDIR'} ne $ENV{'GSDLHOME'})
120 {
121 push(@possible_class_paths,&FileUtils::filenameConcatenate($ENV{'GSDLCOLLECTDIR'}, 'perllib', 'classify', $classname . '.pm'));
122 }
123 foreach my $library_path (@INC)
124 {
125 # only interested in classify paths found in the library paths
126 if ($library_path =~ /classify$/)
127 {
128 push(@possible_class_paths, &FileUtils::filenameConcatenate($library_path, $classname . '.pm'));
129 }
130 }
131 my $found_class = 0;
132 foreach my $possible_class_path (@possible_class_paths)
133 {
134 if (-e $possible_class_path)
135 {
136 require $possible_class_path;
137 $found_class = 1;
138 last;
139 }
140 }
141 if (!$found_class)
142 {
143 &gsprintf(STDERR, "{classify.could_not_find_classifier}\n", $classname) && die "\n";
144 }
145
146 # create the classify object
147 my ($classobj);
148
149 my @newoptions;
150
151 # do these first so they can be overriden by user supplied options
152 push @newoptions, "-builddir", "$build_dir" if ($build_dir);
153 push @newoptions, "-outhandle", "$outhandle" if ($outhandle);
154 push @newoptions, "-verbosity", "2";
155
156 # backwards compatability hack: if the classifier options are
157 # in "x=y" format, convert them to parsearg ("-x y") format.
158 my ($opt, $key, $value);
159 foreach $opt (@$classifyoption) {
160 # if ($opt =~ /^(\w+)=(.*)$/) {
161 # push @newoptions, "-$1", $2;
162 # } else {
163 push @newoptions, $opt;
164 #}
165 }
166
167 map { $_ = "\"$_\""; } @newoptions;
168 my $options .= join (",", @newoptions);
169
170
171 eval ("\$classobj = new \$classname([],[$options])");
172 die "$@" if $@;
173
174 $classobj->set_number($classify_number);
175 $classify_number ++;
176
177 # add this object to the list
178 push (@classify_objects, $classobj);
179 }
180
181 my ($classobj);
182 eval ("\$classobj = new AllList()");
183 die "$@" if $@;
184 push (@classify_objects, $classobj);
185
186 return \@classify_objects;
187}
188
189# init_classifiers resets all the classifiers and readys them to process
190# the documents.
191sub init_classifiers {
192 my ($classifiers) = @_;
193
194 foreach my $classobj (@$classifiers) {
195 $classobj->init();
196 }
197}
198
199
200
201# takes a hashref containing the metadata for an infodb entry, and extracts
202# the childrens numbers (from the 'contains' entry).
203# assumes format is ".1;".2;".3
204sub get_children {
205 my ($doc_db_hash) = @_;
206
207 my $children = undef;
208
209 my $contains = $doc_db_hash->{'contains'};
210 if (defined ($contains)) {
211 $contains =~ s/\@$//; #remove trailing @
212 $contains =~ s/^\"\.//; #remove initial ".
213 @$children = split /\;\"\./, $contains;
214 }
215
216 return $children;
217}
218
219
220sub recurse_sections {
221 my ($doc_obj, $children, $parentoid, $parentsection, $database_recs) = @_;
222
223 return if (!defined $children);
224
225 foreach my $child (sort { $a <=> $b} @$children) {
226 $doc_obj->create_named_section("$parentsection.$child");
227 my $doc_db_rec = $database_recs->{"$parentoid.$child"};
228 my $doc_db_hash = db_rec_to_hash($doc_db_rec);
229
230 # get child's children
231 my $newchildren = &get_children($doc_db_hash);
232
233 # add content for current section
234 add_section_content($doc_obj, "$parentsection.$child", $doc_db_hash);
235
236 # process all the children if there are any
237 if (defined ($newchildren))
238 {
239 recurse_sections($doc_obj, $newchildren, "$parentoid.$child",
240 "$parentsection.$child", $database_recs);
241 }
242 }
243}
244
245
246sub add_section_content {
247 my ($doc_obj, $cursection, $doc_db_hash) = @_;
248
249 foreach my $key (keys %$doc_db_hash) {
250 #don't need to store these metadata
251 next if $key =~ /(thistype|childtype|contains|docnum|doctype|classifytype)/i;
252 # but do want things like hastxt and archivedir
253 my @items = split /@/, $doc_db_hash->{$key};
254 # metadata is all from the info database so should already be in utf8
255 map {$doc_obj->add_utf8_metadata ($cursection, $key, $_); } @items;
256
257 }
258}
259
260
261# gets all the metadata from an infodb entry, and puts it into a hashref
262sub db_rec_to_hash {
263
264 my ($infodb_str_ref) = @_;
265
266 my $hashref = {};
267
268 my @entries = split(/\n/, $infodb_str_ref);
269 foreach my $entry (@entries) {
270 my($key, $value) = ($entry =~ /^<([^>]*)>(.*?)$/ );
271 $hashref->{$key} .= '@' if defined $hashref->{$key};
272 $hashref->{$key} .= $value;
273
274 }
275
276 return $hashref;
277}
278
279
280sub reconstruct_doc_objs_metadata
281{
282 my $infodb_type = shift(@_);
283 my $infodb_file_path = shift(@_);
284 my $database_recs = shift(@_);
285
286 # dig out top level doc sections
287 my %top_sections = ();
288 my %top_docnums = ();
289 foreach my $key ( keys %$database_recs )
290 {
291 my $md_rec = $database_recs->{$key};
292 my $md_hash = db_rec_to_hash($md_rec);
293
294 if ((defined $md_hash->{'doctype'}) && ($md_hash->{'doctype'} eq "doc")) {
295 next if ($key =~ m/\./);
296 $top_sections{$key} = $md_hash;
297 $top_docnums{$key} = $md_hash->{'docnum'};
298 }
299 }
300
301 # for greenstone document objects based on metadata in database file
302 my @all_docs = ();
303 # we need to make sure the documents were processed in the same order as
304 # before, so sort based on their docnums
305 foreach my $oid ( sort { $top_docnums{$a} <=> $top_docnums{$b} } keys %top_sections )
306 {
307 my $doc_db_hash = $top_sections{$oid};
308
309 my $doc_obj = new doc();
310 $doc_obj->set_OID($oid);
311 my $top = $doc_obj->get_top_section();
312 add_section_content ($doc_obj, $top, $doc_db_hash);
313 my $children = &get_children($doc_db_hash);
314 recurse_sections($doc_obj, $children, $oid, $top, $database_recs);
315
316 push(@all_docs,$doc_obj);
317 }
318
319 return \@all_docs;
320}
321
322
323
324
325
326# classify_doc lets each of the classifiers classify a document
327sub classify_doc {
328 my ($classifiers, $doc_obj) = @_;
329
330 foreach my $classobj (@$classifiers) {
331 my $title = $classobj->{'title'};
332
333 $classobj->classify($doc_obj);
334 }
335}
336
337
338our $next_classify_num = 1;
339
340# output_classify_info outputs all the info needed for the classification
341# to the database
342sub output_classify_info
343{
344 my ($classifiers, $infodb_type, $infodb_handle, $remove_empty_classifications, $gli) = @_;
345
346 $gli = 0 unless defined $gli;
347
348 # create a classification containing all the info
349 my $classifyinfo = { 'classifyOID'=> 'browse',
350 'contains' => [] };
351
352 # get each of the classifications
353 foreach my $classifier (@$classifiers)
354 {
355 my $classifier_info = $classifier->get_classify_info($gli);
356 $classifier_info->{'classifyOID'} = "CL$next_classify_num" unless defined($classifier_info->{'classifyOID'});
357 print STDERR "*** outputting information for classifier: $classifier_info->{'classifyOID'}\n";
358
359 push(@{$classifyinfo->{'contains'}}, $classifier_info);
360 $next_classify_num++;
361 }
362
363 &print_classify_info($infodb_type, $infodb_handle, $classifyinfo, "", $remove_empty_classifications);
364}
365
366
367sub print_classify_info
368{
369 my ($infodb_type, $infodb_handle, $classifyinfo, $OID, $remove_empty_classifications) = @_;
370
371 $OID =~ s/^\.+//; # just for good luck
372
373 # book information is printed elsewhere
374 return if (defined ($classifyinfo->{'OID'}));
375
376 # don't want empty classifications
377 return if (&check_contents ($classifyinfo, $remove_empty_classifications) == 0 && $remove_empty_classifications);
378
379 $OID = $classifyinfo->{'classifyOID'} if defined ($classifyinfo->{'classifyOID'});
380
381 my %classify_infodb = ();
382 $classify_infodb{"doctype"} = [ "classify" ];
383 $classify_infodb{"hastxt"} = [ "0" ];
384 $classify_infodb{"childtype"} = [ $classifyinfo->{'childtype'} ]
385 if defined $classifyinfo->{'childtype'};
386 $classify_infodb{"Title"} = [ $classifyinfo->{'Title'} ]
387 if defined $classifyinfo->{'Title'};
388 $classify_infodb{"numleafdocs"} = [ $classifyinfo->{'numleafdocs'} ]
389 if defined $classifyinfo->{'numleafdocs'};
390 $classify_infodb{"thistype"} = [ $classifyinfo->{'thistype'} ]
391 if defined $classifyinfo->{'thistype'};
392 $classify_infodb{"parameters"} = [ $classifyinfo->{'parameters'} ]
393 if defined $classifyinfo->{'parameters'};
394 $classify_infodb{"supportsmemberof"} = [ $classifyinfo->{'supportsmemberof'} ]
395 if defined $classifyinfo->{'supportsmemberof'};
396
397 my $contains_text = "";
398 my $mdoffset_text = "";
399
400 my $next_subOID = 1;
401 my $first = 1;
402 foreach my $tempinfo (@{$classifyinfo->{'contains'}}) {
403 # empty contents were made undefined by clean_contents()
404 next unless defined $tempinfo;
405 if (!defined ($tempinfo->{'classifyOID'}) ||
406 $tempinfo->{'classifyOID'} ne "oai") {
407 $contains_text .= ";" unless $first;
408 }
409 $mdoffset_text .= ";" unless $first;
410 $first = 0;
411
412 if (defined ($tempinfo->{'classifyOID'}))
413 {
414 if ($tempinfo->{'classifyOID'} ne "oai")
415 {
416 $contains_text .= $tempinfo->{'classifyOID'};
417 }
418
419 &print_classify_info ($infodb_type, $infodb_handle, $tempinfo, $tempinfo->{'classifyOID'},
420 $remove_empty_classifications);
421 }
422 elsif (defined ($tempinfo->{'OID'}))
423 {
424 $contains_text .= $tempinfo->{'OID'};
425 $mdoffset_text .= $tempinfo->{'offset'} if (defined ($tempinfo->{'offset'}));
426 }
427 else
428 {
429 # Supress having top-level node in Collage classifier
430 # so no bookshelf icon appears, top-level, along with the
431 # applet
432 if (!defined ($tempinfo->{'Title'}) || $tempinfo->{'Title'} ne "Collage")
433 {
434 $contains_text .= "\".$next_subOID";
435 }
436
437 &print_classify_info ($infodb_type, $infodb_handle, $tempinfo, "$OID.$next_subOID",
438 $remove_empty_classifications);
439 $next_subOID++;
440 }
441 }
442
443 $classify_infodb{"contains"} = [ $contains_text ];
444 $classify_infodb{"mdtype"} = [ $classifyinfo->{'mdtype'} ]
445 if defined $classifyinfo->{'mdtype'};
446 $classify_infodb{"mdoffset"} = [ $mdoffset_text ]
447 if ($mdoffset_text !~ m/^;+$/);
448
449 &dbutil::write_infodb_entry($infodb_type, $infodb_handle, $OID, \%classify_infodb);
450}
451
452
453sub check_contents {
454 my ($classifyinfo,$remove_empty_classifications) = @_;
455 $remove_empty_classifications = 0 unless ($remove_empty_classifications);
456 my $num_leaf_docs = 0;
457 my $sub_num_leaf_docs = 0;
458
459 return $classifyinfo->{'numleafdocs'} if (defined $classifyinfo->{'numleafdocs'});
460
461 foreach my $content (@{$classifyinfo->{'contains'}}) {
462 if (defined $content->{'OID'}) {
463 # found a book
464 $num_leaf_docs ++;
465 } elsif (($sub_num_leaf_docs = &check_contents ($content,$remove_empty_classifications)) > 0) {
466 # there's a book somewhere below
467 $num_leaf_docs += $sub_num_leaf_docs;
468 } else {
469 if ($remove_empty_classifications){
470 # section contains no books so we want to remove
471 # it from its parents contents
472 $content = undef;
473 }
474 }
475 }
476
477 $classifyinfo->{'numleafdocs'} = $num_leaf_docs;
478 return $num_leaf_docs;
479}
480
4811;
Note: See TracBrowser for help on using the repository browser.