source: main/trunk/model-sites-dev/heritage-nz/collect/pdf-reports/perllib/classify/AZCompactList.pm@ 33076

Last change on this file since 33076 was 33076, checked in by davidb, 5 years ago

Customized version to split up author field metadata from Heritage NZ spreadsheet; with hindsight it is probably better to be doing this in the Plugin, not the classifier
File size: 24.7 KB
Line 
1###########################################################################
2#
3# AZCompactList.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# classifier plugin for sorting alphabetically
26
27package AZCompactList;
28
29use strict;
30no strict 'refs'; # allow filehandles to be variables and viceversa
31
32use BaseClassifier;
33use sorttools;
34use FileUtils;
35
36use Unicode::Normalize;
37
38sub BEGIN {
39 @AZCompactList::ISA = ('BaseClassifier');
40}
41
42our $doclevel_list =
43 [ { 'name' => "top",
44 'desc' => "{AZCompactList.doclevel.top}" },
45 { 'name' => "firstlevel",
46 'desc' => "{AZCompactList.doclevel.firstlevel}" },
47 { 'name' => "section",
48 'desc' => "{AZCompactList.doclevel.section}" } ];
49
50my $arguments =
51 [ { 'name' => "metadata",
52 'desc' => "{AZCompactList.metadata}",
53 'type' => "metadata",
54 'reqd' => "yes" },
55 { 'name' => "firstvalueonly",
56 'desc' => "{AZCompactList.firstvalueonly}",
57 'type' => "flag",
58 'reqd' => "no" },
59 { 'name' => "allvalues",
60 'desc' => "{AZCompactList.allvalues}",
61 'type' => "flag",
62 'reqd' => "no" },
63 { 'name' => "sort",
64 'desc' => "{AZCompactList.sort}",
65 'type' => "metadata",
66# 'deft' => "Title",
67 'reqd' => "no" },
68 { 'name' => "removeprefix",
69 'desc' => "{BasClas.removeprefix}",
70 'type' => "regexp",
71 'deft' => "",
72 'reqd' => "no" },
73 { 'name' => "removesuffix",
74 'desc' => "{BasClas.removesuffix}",
75 'type' => "regexp",
76 'deft' => "",
77 'reqd' => "no" },
78 { 'name' => "mingroup",
79 'desc' => "{AZCompactList.mingroup}",
80 'type' => "int",
81 'deft' => "1",
82 'range' => "1,",
83 'reqd' => "no" },
84 { 'name' => "minnesting",
85 'desc' => "{AZCompactList.minnesting}",
86 'type' => "int",
87 'deft' => "20",
88 'range' => "2,",
89 'reqd' => "no" },
90 { 'name' => "mincompact",
91 'desc' => "{AZCompactList.mincompact}",
92 'type' => "int",
93 'deft' => "10",
94 'range' => "1,",
95 'reqd' => "no" },
96 { 'name' => "maxcompact",
97 'desc' => "{AZCompactList.maxcompact}",
98 'type' => "int",
99 'deft' => "30",
100 'range' => "1,",
101 'reqd' => "no" },
102 { 'name' => "doclevel",
103 'desc' => "{AZCompactList.doclevel}",
104 'type' => "enum",
105 'list' => $doclevel_list,
106 'deft' => "top",
107 'reqd' => "no" },
108 { 'name' => "freqsort",
109 'desc' => "{AZCompactList.freqsort}",
110 'type' => "flag"},
111 { 'name' => "recopt",
112 'desc' => "{AZCompactList.recopt}",
113 'type' => "flag",
114 'reqd' => "no" } ];
115
116my $options =
117{ 'name' => "AZCompactList",
118 'desc' => "{AZCompactList.desc}",
119 'abstract' => "no",
120 'inherits' => "yes",
121 'args' => $arguments };
122
123
124sub new {
125 my ($class) = shift (@_);
126 my ($pluginlist,$inputargs,$hashArgOptLists) = @_;
127 push(@$pluginlist, $class);
128
129 push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});
130 push(@{$hashArgOptLists->{"OptList"}},$options);
131
132 my $self = new BaseClassifier($pluginlist, $inputargs, $hashArgOptLists);
133
134 if ($self->{'info_only'}) {
135 # don't worry about any options etc
136 return bless $self, $class;
137 }
138
139 if (!$self->{"metadata"}) {
140 my $outhandle = $self->{'outhandle'};
141 print $outhandle "AZCompactList Error: required option -metadata not supplied\n";
142 $self->print_txt_usage("");
143 die "AZCompactList Error: required option -metadata not supplied\n";
144 }
145
146 $self->{'metadata'} = $self->strip_ex_from_metadata($self->{'metadata'});
147 # Manually set $self parameters.
148 $self->{'list'} = {};
149 $self->{'listmetavalue'} = {};
150 $self->{'list_mvpair'} = {};
151 $self->{'reclassify'} = {};
152 $self->{'reclassifylist'} = {};
153
154 $self->{'buttonname'} = $self->generate_title_from_metadata($self->{'metadata'}) unless ($self->{'buttonname'});
155
156 if (defined($self->{"removeprefix"}) && $self->{"removeprefix"}) {
157 $self->{"removeprefix"} =~ s/^\^//; # don't need a leading ^
158 }
159 if (defined($self->{"removesuffix"}) && $self->{"removesuffix"}) {
160 $self->{"removesuffix"} =~ s/\$$//; # don't need a trailing $
161 }
162
163 $self->{'recopt'} = ($self->{'recopt'} == 0) ? undef : "on";
164
165 if (defined $self->{'sort'}) {
166 $self->{'sort'} = $self->strip_ex_from_metadata($self->{'sort'});
167 }
168 # Clean out the unused keys
169 if($self->{"removeprefix"} eq "") {delete $self->{"removeprefix"};}
170 if($self->{"removesuffix"} eq "") {delete $self->{"removesuffix"};}
171
172 return bless $self, $class;
173}
174
175sub init
176{
177 my $self = shift (@_);
178
179 $self->{'list'} = {};
180 $self->{'listmetavalue'} = {};
181 $self->{'list_mvpair'} = {};
182 $self->{'reclassify'} = {};
183 $self->{'reclassifylist'} = {};
184}
185
186my $tmp = 0;
187
188sub classify
189{
190 my $self = shift (@_);
191 my ($doc_obj) = @_;
192
193 my $doc_OID = $doc_obj->get_OID();
194 my $outhandle = $self->{'outhandle'};
195
196 my @sectionlist = ();
197 my $topsection = $doc_obj->get_top_section();
198 my $metaname = $self->{'metadata'};
199
200 $metaname =~ s/(\/|\|).*//; # grab first name in n1/n2/n3 or n1|n2|n3 list
201 my @commameta_list = split(/,|;/, $metaname);
202
203 if ($self->{'doclevel'} =~ /^top(level)?/i)
204 {
205 push(@sectionlist,$topsection);
206 }
207 elsif ($self->{'doclevel'} =~ /^first(level)?/i)
208 {
209 my $toplevel_children = $doc_obj->get_children($topsection);
210 push(@sectionlist,@$toplevel_children);
211 }
212 else # (all)?section(s)?
213 {
214 my $thissection = $doc_obj->get_next_section($topsection);
215 while (defined $thissection)
216 {
217 push(@sectionlist,$thissection);
218 $thissection = $doc_obj->get_next_section ($thissection);
219 }
220 }
221
222 my $thissection;
223 foreach $thissection (@sectionlist)
224 {
225 my $full_doc_OID
226 = ($thissection ne "") ? "$doc_OID.$thissection" : $doc_OID;
227
228 if (defined $self->{'list_mvpair'}->{$full_doc_OID})
229 {
230 print $outhandle "WARNING: AZCompactList::classify called multiple times for $full_doc_OID\n";
231 }
232 $self->{'list'}->{$full_doc_OID} = [];
233 $self->{'listmetavalue'}->{$full_doc_OID} = [];
234 $self->{'list_mvpair'}->{$full_doc_OID} = [];
235
236 # if specified, used to further split a metavalue
237 # split on:
238 # | / or 'Unicode Character 'BOX DRAWINGS LIGHT VERTICAL' (U+2502)'
239 # *except* when 'n/a'
240
241 my $split_on_re_str = "(?!^[n])[&|\/\x{2502}](?![a]\$)";
242 # my $split_on_re_str = "[|\/\x{2502}]";
243 my $split_on_re = /$split_on_re_str/;
244
245 my $metavalues = [];
246 foreach my $cmn (@commameta_list) {
247 my $cmvalues = $doc_obj->get_metadata($thissection,$cmn);
248 if (@{$cmvalues}) {
249 # see if further splitting is required, due to 'split_on' field
250 if ($split_on_re) {
251
252 my $further_split_cmvalues = [];
253
254 foreach my $cmval (@$cmvalues) {
255 my @split_cmval = split(/$split_on_re_str/,$cmval);
256
257 push(@$further_split_cmvalues,@split_cmval);
258 last if (@{$cmval} && !$self->{'allvalues'});
259 }
260
261 $cmvalues = $further_split_cmvalues;
262 }
263 }
264 if (@{$cmvalues}) {
265 if ($self->{'allvalues'}) {
266 push(@$metavalues,@$cmvalues);
267 }
268 else {
269 # only want first one, then break out of loop
270 push(@$metavalues,$cmvalues->[0]);
271 last;
272 }
273 }
274 }
275
276 my $metavalue;
277 foreach $metavalue (@$metavalues)
278 {
279 # Tidy up use of white space in metavalue for classifying
280 $metavalue =~ s/^\s*//s;
281 $metavalue =~ s/\s*$//s;
282 $metavalue =~ s/\n/ /s;
283 $metavalue =~ s/\s{2,}/ /s;
284
285 # if this document doesn't contain the metadata element we're
286 # sorting by we won't include it in this classification
287 if (defined $metavalue && $metavalue =~ /\w/)
288 {
289 if (defined($self->{'removeprefix'}) &&
290 length($self->{'removeprefix'})) {
291 $metavalue =~ s/^$self->{'removeprefix'}//;
292
293 # check that it's not now empty
294 if (!$metavalue) {next;}
295 }
296
297 if (defined($self->{'removesuffix'}) &&
298 length($self->{'removesuffix'})) {
299 $metavalue =~ s/$self->{'removesuffix'}$//;
300
301 # check that it's not now empty
302 if (!$metavalue) {next;}
303 }
304
305 my $formatted_metavalue;
306 if ($self->{'no_metadata_formatting'}) {
307 $formatted_metavalue = $metavalue;
308 } else {
309 $formatted_metavalue = &sorttools::format_metadata_for_sorting($self->{'metadata'}, $metavalue, $doc_obj);
310 }
311
312 #### prefix-str
313 if (! defined($formatted_metavalue)) {
314 print $outhandle "Warning: AZCompactList: metavalue is ";
315 print $outhandle "empty\n";
316 $formatted_metavalue="";
317 }
318
319 my $mv_pair = { 'mv' => $metavalue, 'fmv' => $formatted_metavalue };
320 push(@{$self->{'list'}->{$full_doc_OID}},$formatted_metavalue);
321 push(@{$self->{'listmetavalue'}->{$full_doc_OID}} ,$metavalue);
322 push(@{$self->{'list_mvpair'}->{$full_doc_OID}},$mv_pair);
323
324
325 last if ($self->{'firstvalueonly'});
326 }
327 }
328
329 # This is used in reclassify below for AZCompactSectionList
330 my $sortmeta = $doc_obj->get_metadata_element($thissection, $self->{'sort'});
331 $self->{'reclassify'}->{$full_doc_OID} = [$doc_obj,$sortmeta];
332 }
333}
334
335sub reinit
336{
337 my ($self,$classlist_ref) = @_;
338 my $outhandle = $self->{'outhandle'};
339
340 my %mtfreq = ();
341 my @single_classlist = ();
342 my @multiple_classlist = ();
343
344 # find out how often each metavalue occurs
345 map
346 {
347 foreach my $mvp (@{$self->{'list_mvpair'}->{$_}} )
348 {
349### print STDERR "*** plain mv = $mvp->{'mv'}\n";
350### print STDERR "*** format mv = $mvp->{'fmv'}\n";
351
352 my $metavalue = $mvp->{'mv'};
353 $metavalue =~ s!^-!\\-!; # in case it starts with "-"
354 $mtfreq{$metavalue}++;
355 }
356 } @$classlist_ref;
357
358 # use this information to split the list: single metavalue/repeated value
359 map
360 {
361 my $i = 1;
362 my $metavalue;
363 foreach my $mvp (@{$self->{'list_mvpair'}->{$_}})
364 {
365 my $metavalue = $mvp->{'mv'};
366 $metavalue =~ s!^-!\\-!; # in case it starts with "-"
367 my $cs_metavalue = $mvp->{'mv'}; # case sensitive
368 if ($mtfreq{$metavalue} >= $self->{'mingroup'})
369 {
370### print STDERR "*** pushing on $cs_metavalue\n";
371 push(@multiple_classlist,[$_,$i,$metavalue]);
372 }
373 else
374 {
375 push(@single_classlist,[$_,$cs_metavalue]);
376 $metavalue =~ tr/[A-Z]/[a-z]/;
377 $self->{'reclassifylist'}->{"Metavalue_$i.$_"} = $metavalue;
378 }
379 $i++;
380 }
381 } @$classlist_ref;
382
383
384 # Setup sub-classifiers for multiple list
385
386 $self->{'classifiers'} = {};
387
388 my $pm;
389 foreach $pm ("SimpleList", "SectionList")
390 {
391 my $listname
392 = &FileUtils::filenameConcatenate($ENV{'GSDLHOME'},"perllib/classify/$pm.pm");
393 if (-e $listname) { require $listname; }
394 else
395 {
396 print $outhandle "AZCompactList ERROR - couldn't find classifier \"$listname\"\n";
397 die "\n";
398 }
399 }
400
401 # Create classifiers objects for each entry >= mingroup
402 my $metavalue;
403 my $doclevel = $self->{'doclevel'};
404 my $mingroup = $self->{'mingroup'};
405 my @metaname_list = split(/\/|\|/,$self->{'metadata'});
406 my $metaname = shift(@metaname_list);
407 my $hierarchical = 0;
408 if (scalar(@metaname_list) > 1) {
409 $hierarchical = 1;
410 $metaname = join('/',@metaname_list);
411 }
412 foreach $metavalue (sort keys %mtfreq)
413 {
414 if ($mtfreq{$metavalue} >= $mingroup)
415 {
416 # occurs more often than minimum required to compact into a group
417 my $listclassobj;
418
419 if (!$hierarchical)
420 {
421 my @args;
422 push @args, ("-metadata", "$metaname");
423 # buttonname is also used for the node's title
424 push @args, ("-buttonname", "$metavalue");
425 push @args, ("-sort", $self->{'sort'});
426
427 my $ptArgs = \@args;
428 if ($doclevel =~ m/^top(level)?/i)
429 {
430 eval ("\$listclassobj = new SimpleList([],\$ptArgs)");
431 }
432 else
433 {
434 # first(level)? or (all)?section(s)?
435 eval ("\$listclassobj = new SectionList([],\$ptArgs)");
436 }
437 }
438 else
439 {
440
441 my @args;
442 push @args, ("-metadata", "$metaname");
443 # buttonname is also used for the node's title
444 push @args, ("-buttonname", "$metavalue");
445 push @args, ("-sort", $self->{'sort'});
446
447 if (defined $self->{'removeprefix'}) {
448 push @args, ("-removeprefix", $self->{'removeprefix'});
449 }
450 if (defined $self->{'removesuffix'}) {
451 push @args, ("-removesuffix", $self->{'removesuffix'});
452 }
453
454 push @args, ("-doclevel", "$doclevel");
455 push @args, ("-mingroup", $mingroup);
456 push @args, "-recopt ";
457
458 my $ptArgs = \@args;
459 eval ("\$listclassobj = new AZCompactList([],\$ptArgs)");
460 }
461
462 if ($@) {
463 print $outhandle "$@";
464 die "\n";
465 }
466
467 $listclassobj->init();
468
469 if (defined $metavalue && $metavalue =~ /\w/)
470 {
471 my $formatted_node = $metavalue;
472
473 if (defined($self->{'removeprefix'}) &&
474 length($self->{'removeprefix'})) {
475 $formatted_node =~ s/^$self->{'removeprefix'}//;
476 # check that it's not now empty
477 if (!$formatted_node) {next;}
478 }
479 if (defined($self->{'removesuffix'}) &&
480 length($self->{'removesuffix'})) {
481 $formatted_node =~ s/$self->{'removesuffix'}$//;
482 # check that it's not now empty
483 if (!$formatted_node) {next;}
484 }
485
486 $formatted_node = &sorttools::format_metadata_for_sorting($self->{'metadata'}, $formatted_node) unless $self->{'no_metadata_formatting'};
487
488 # In case our formatted string is empty...
489 if (! defined($formatted_node)) {
490 print $outhandle "Warning: AZCompactList: metavalue is ";
491 print $outhandle "empty\n";
492 $formatted_node="";
493 }
494
495 # use the lower case, for speed of lookup.
496 my $meta_lc=lc($metavalue);
497 $self->{'classifiers'}->{$meta_lc}
498 = { 'classifyobj' => $listclassobj,
499 'formattednode' => $formatted_node };
500 }
501 }
502 }
503
504
505 return (\@single_classlist,\@multiple_classlist);
506}
507
508
509sub reclassify
510{
511 my ($self,$multiple_cl_ref) = @_;
512
513 # Entries in the current classify list that are "book nodes"
514 # should be recursively classified.
515 #--
516 foreach my $dm_pair (@$multiple_cl_ref)
517 {
518 my ($doc_OID,$mdoffset,$metavalue,$cs_metavalue) = @$dm_pair;
519 my $listclassobj;
520
521 # find metavalue in list of sub-classifiers
522 # check if we have a key (lower case) for this metadata value
523 my $node_name=lc($metavalue);
524 if (exists $self->{'classifiers'}->{$node_name})
525 {
526 my ($doc_obj, $sortmeta) = @{$self->{'reclassify'}->{$doc_OID}};
527
528 # record the metadata value offset temporarily, so eg AZList can
529 # get the correct metadata value (for multi-valued metadata fields)
530 $doc_obj->{'mdoffset'}=$mdoffset;
531
532 if ($doc_OID =~ m/^[^\.]*\.([\d\.]+)$/)
533 {
534 my $section=$1;
535 if ($self->{'doclevel'} =~ m/^top(level)?/i) { # toplevel
536 $self->{'classifiers'}->{$node_name}->{'classifyobj'}
537 ->classify($doc_obj,"Section=$section");
538 } else {
539 # first(level)? or (all)?section(s)?
540
541 # classify() can't handle multi-level section, so use
542 # classify_section()
543 # ... thanks to Don Gourley for this...
544
545 $self->{'classifiers'}->{$node_name}->{'classifyobj'}
546 ->classify_section($section, $doc_obj, $sortmeta);
547 }
548 }
549 else
550 {
551 $self->{'classifiers'}->{$node_name}->{'classifyobj'}
552 ->classify($doc_obj);
553 }
554 } else { # this key is not in the hash
555 my $outhandle=$self->{outhandle};
556 print $outhandle "Warning: AZCompactList::reclassify ";
557 print $outhandle "could not find sub-node for metadata=`$metavalue' with doc_OID $doc_OID\n";
558 }
559 }
560}
561
562
563
564sub get_reclassify_info
565{
566 my $self = shift (@_);
567
568 my $node_name;
569 foreach $node_name (keys %{$self->{'classifiers'}})
570 {
571 my $classifyinfo
572 = $self->{'classifiers'}->{$node_name}->{'classifyobj'}
573 ->get_classify_info();
574 $self->{'classifiers'}->{$node_name}->{'classifyinfo'}
575 = $classifyinfo;
576 $self->{'reclassifylist'}->{"CLASSIFY.$node_name"}
577 = $self->{'classifiers'}->{$node_name}->{'formattednode'};
578 }
579}
580
581
582sub alpha_numeric_cmp
583{
584 my ($self,$a,$b) = @_;
585
586 my $title_a = $self->{'reclassifylist'}->{$a};
587 my $title_b = $self->{'reclassifylist'}->{$b};
588
589 if ($title_a =~ m/^(\d+(\.\d+)?)/)
590 {
591 my $val_a = $1;
592 if ($title_b =~ m/^(\d+(\.\d+)?)/)
593 {
594 my $val_b = $1;
595 if ($val_a != $val_b)
596 {
597 return ($val_a <=> $val_b);
598 }
599 }
600 }
601
602 return ($title_a cmp $title_b);
603}
604
605sub frequency_cmp
606{
607 my ($self,$a,$b) = @_;
608
609
610 my $title_a = $self->{'reclassifylist'}->{$a};
611 my $title_b = $self->{'reclassifylist'}->{$b};
612
613 my $a_freq = 1;
614 my $b_freq = 1;
615
616 if ($a =~ m/^CLASSIFY\.(.*)$/)
617 {
618 my $a_node = $1;
619 my $a_nodeinfo = $self->{'classifiers'}->{$a_node}->{'classifyinfo'};
620 $a_freq = scalar(@{$a_nodeinfo->{'contains'}});
621 }
622
623 if ($b =~ m/^CLASSIFY\.(.*)$/)
624 {
625 my $b_node = $1;
626 my $b_nodeinfo = $self->{'classifiers'}->{$b_node}->{'classifyinfo'};
627 $b_freq = scalar(@{$b_nodeinfo->{'contains'}});
628 }
629
630 return $b_freq <=> $a_freq;
631}
632
633sub get_classify_info {
634 my $self = shift (@_);
635
636 my @classlist =keys %{$self->{'list_mvpair'}}; # list all doc oids
637
638 my ($single_cl_ref,$multiple_cl_ref) = $self->reinit(\@classlist);
639 $self->reclassify($multiple_cl_ref);
640 $self->get_reclassify_info();
641
642 my @reclassified_classlist;
643 if ($self->{'freqsort'})
644 {
645 @reclassified_classlist
646 = sort { $self->frequency_cmp($a,$b) } keys %{$self->{'reclassifylist'}};
647 # supress sub-grouping by alphabet
648 map { $self->{'reclassifylist'}->{$_} = "A".$self->{'reclassifylist'}; } keys %{$self->{'reclassifylist'}};
649 }
650 else
651 {
652# @reclassified_classlist
653# = sort {$self->{'reclassifylist'}->{$a} cmp $self->{'reclassifylist'}->{$b};} keys %{$self->{'reclassifylist'}};
654
655 # alpha_numeric_cmp is slower than "cmp" but handles numbers better ...
656
657 @reclassified_classlist
658 = sort { $self->alpha_numeric_cmp($a,$b) } keys %{$self->{'reclassifylist'}};
659
660 }
661
662 return $self->splitlist (\@reclassified_classlist);
663}
664
665sub get_entry {
666 my $self = shift (@_);
667 my ($title, $childtype, $metaname, $thistype) = @_;
668 # organise into classification structure
669 my %classifyinfo = ('childtype'=>$childtype,
670 'Title'=>$title,
671 'contains'=>[],
672 'mdtype'=>$metaname);
673
674 $classifyinfo{'thistype'} = $thistype
675 if defined $thistype && $thistype =~ /\w/;
676
677 return \%classifyinfo;
678}
679
680
681
682# splitlist takes an ordered list of classifications (@$classlistref) and
683# splits it up into alphabetical sub-sections.
684sub splitlist {
685 my $self = shift (@_);
686 my ($classlistref) = @_;
687 my $classhash = {};
688
689 # top level
690 my @metanames = split(/\/|\|/,$self->{'metadata'});
691 my $metaname = shift(@metanames);
692
693 my $childtype = "HList";
694 $childtype = "VList" if (scalar (@$classlistref) <= $self->{'minnesting'});
695
696 my $title = $self->{'buttonname'}; # should always be defined by now.
697 my $classifyinfo;
698 if (!defined($self->{'recopt'}))
699 {
700 $classifyinfo
701 = $self->get_entry ($title, $childtype, $metaname, "Invisible");
702 }
703 else
704 {
705 $classifyinfo
706 = $self->get_entry ($title, $childtype, $metaname, "VList");
707 }
708
709 # don't need to do any splitting if there are less than 'minnesting' classifications
710 if ((scalar @$classlistref) <= $self->{'minnesting'}) {
711 foreach my $subOID (@$classlistref) {
712 if ($subOID =~ /^CLASSIFY\.(.*)$/
713 && defined $self->{'classifiers'}->{$1})
714 {
715 push (@{$classifyinfo->{'contains'}},
716 $self->{'classifiers'}->{$1}->{'classifyinfo'});
717 }
718 else
719 {
720 $subOID =~ s/^Metavalue_(\d+)\.//;
721 my $metaname_offset = $1 -1;
722 my $oid_rec = {'OID'=>$subOID, 'offset'=>$metaname_offset};
723 push (@{$classifyinfo->{'contains'}}, $oid_rec);
724 }
725 }
726 return $classifyinfo;
727 }
728
729 # first split up the list into separate A-Z and 0-9 classifications
730 foreach my $classification (@$classlistref) {
731 my $title = $self->{'reclassifylist'}->{$classification};
732 $title =~ s/&(.){2,4};//g; # remove any HTML special chars
733 $title =~ s/^(\W|_)+//g; # remove leading non-word chars
734
735 # only want first character for classification
736 $title =~ m/^(.)/; # always a char, or first byte of wide char?
737 if (defined($1) && $1 ne "") {
738 $title=$1;
739
740 # remove any accents on initial character by mapping to Unicode's
741 # normalized decomposed form (accents follow initial letter)
742 # and then pick off the initial letter
743 my $title_decomposed = NFD($title);
744 $title = substr($title_decomposed,0,1);
745 } else {
746 print STDERR "no first character found for \"$title\" - \"" .
747 $self->{'reclassifylist'}->{$classification} . "\"\n";
748 }
749 $title =~ tr/[a-z]/[A-Z]/;
750
751 if ($title =~ /^[0-9]$/) {$title = '0-9';}
752 elsif ($title !~ /^[A-Z]$/) {
753 my $outhandle = $self->{'outhandle'};
754 print $outhandle "AZCompactList: WARNING $classification has badly formatted title ($title)\n";
755 }
756 $classhash->{$title} = [] unless defined $classhash->{$title};
757 push (@{$classhash->{$title}}, $classification);
758 }
759 $classhash = $self->compactlist ($classhash);
760
761 my @tmparr = ();
762 foreach my $subsection (sort keys (%$classhash)) {
763 push (@tmparr, $subsection);
764 }
765
766 # if there's a 0-9 section it will have been sorted to the beginning
767 # but we want it at the end
768 if ($tmparr[0] eq '0-9') {
769 shift @tmparr;
770 push (@tmparr, '0-9');
771 }
772 foreach my $subclass (@tmparr)
773 {
774 my $tempclassify
775 = (scalar(@tmparr)==1)
776 ? ($self->get_entry(" ", "VList", $metaname))
777 : ($self->get_entry($subclass, "VList", $metaname));
778
779
780 foreach my $subsubOID (@{$classhash->{$subclass}})
781 {
782 if ($subsubOID =~ /^CLASSIFY\.(.*)$/
783 && defined $self->{'classifiers'}->{$1})
784 {
785 # this is a "bookshelf" node... >1 entry compacted
786 push (@{$tempclassify->{'contains'}},
787 $self->{'classifiers'}->{$1}->{'classifyinfo'});
788 # set the metadata field name, for mdoffset to work
789 $self->{'classifiers'}->{$1}->{'classifyinfo'}->{'mdtype'}=
790 $metaname;
791 }
792 else
793 {
794 $subsubOID =~ s/^Metavalue_(\d+)\.//;
795 # record the offset if this metadata type has multiple values
796 my $metaname_offset = $1 -1;
797 my $oid_rec = {'OID'=>$subsubOID, 'offset'=>$metaname_offset};
798 push (@{$tempclassify->{'contains'}}, $oid_rec);
799 }
800 }
801 push (@{$classifyinfo->{'contains'}}, $tempclassify);
802 }
803
804 return $classifyinfo;
805}
806
807sub compactlist {
808 my $self = shift (@_);
809 my ($classhashref) = @_;
810 my $compactedhash = {};
811 my @currentOIDs = ();
812 my $currentfirstletter = "";
813 my $currentlastletter = "";
814 my $lastkey = "";
815
816 # minimum and maximum documents to be displayed per page.
817 # the actual maximum will be max + (min-1).
818 # the smallest sub-section is a single letter at present
819 # so in this case there may be many times max documents
820 # displayed on a page.
821 my $min = $self->{'mincompact'};
822 my $max = $self->{'maxcompact'};
823
824 foreach my $subsection (sort keys %$classhashref) {
825 if ($subsection eq '0-9') {
826 @{$compactedhash->{$subsection}} = @{$classhashref->{$subsection}};
827 next;
828 }
829 $currentfirstletter = $subsection if $currentfirstletter eq "";
830 if ((scalar (@currentOIDs) < $min) ||
831 ((scalar (@currentOIDs) + scalar (@{$classhashref->{$subsection}})) <= $max)) {
832 push (@currentOIDs, @{$classhashref->{$subsection}});
833 $currentlastletter = $subsection;
834 } else {
835
836 if ($currentfirstletter eq $currentlastletter) {
837 @{$compactedhash->{$currentfirstletter}} = @currentOIDs;
838 $lastkey = $currentfirstletter;
839 } else {
840 @{$compactedhash->{"$currentfirstletter-$currentlastletter"}} = @currentOIDs;
841 $lastkey = "$currentfirstletter-$currentlastletter";
842 }
843 if (scalar (@{$classhashref->{$subsection}}) >= $max) {
844 $compactedhash->{$subsection} = $classhashref->{$subsection};
845 @currentOIDs = ();
846 $currentfirstletter = "";
847 $lastkey=$subsection;
848 } else {
849 @currentOIDs = @{$classhashref->{$subsection}};
850 $currentfirstletter = $subsection;
851 $currentlastletter = $subsection;
852 }
853 }
854 }
855
856 # add final OIDs to last sub-classification if there aren't many otherwise
857 # add final sub-classification
858
859 # don't add if there aren't any oids
860 if (! scalar (@currentOIDs)) {return $compactedhash;}
861
862 if (scalar (@currentOIDs) < $min) {
863 my ($newkey) = $lastkey =~ /^(.)/;
864 @currentOIDs = (@{$compactedhash->{$lastkey}}, @currentOIDs);
865 delete $compactedhash->{$lastkey};
866 @{$compactedhash->{"$newkey-$currentlastletter"}} = @currentOIDs;
867 } else {
868 if ($currentfirstletter eq $currentlastletter) {
869 @{$compactedhash->{$currentfirstletter}} = @currentOIDs;
870 } else {
871 @{$compactedhash->{"$currentfirstletter-$currentlastletter"}} = @currentOIDs;
872 }
873 }
874
875 return $compactedhash;
876}
877
8781;
879
880
Note: See TracBrowser for help on using the repository browser.