1 | ## PJFileNameList.pm A version of List that correctly sorts Taonga catalogue numbers
|
---|
2 | package PJFileNameList;
|
---|
3 |
|
---|
4 | use BaseClassifier;
|
---|
5 |
|
---|
6 | use strict;
|
---|
7 |
|
---|
8 | sub BEGIN {
|
---|
9 | @PJFileNameList::ISA = ('BaseClassifier');
|
---|
10 | }
|
---|
11 |
|
---|
12 | my $arguments = [];
|
---|
13 |
|
---|
14 | my $options = { 'name' => "PJfileNameList",
|
---|
15 | 'desc' => "{PJFileNameList.desc}",
|
---|
16 | 'abstract' => "no",
|
---|
17 | 'inherits' => "yes",
|
---|
18 | 'args' => $arguments };
|
---|
19 |
|
---|
20 |
|
---|
21 |
|
---|
22 | sub new {
|
---|
23 | my ($class) = shift (@_);
|
---|
24 | my ($classifierslist,$inputargs,$hashArgOptLists) = @_;
|
---|
25 | push(@$classifierslist, $class);
|
---|
26 |
|
---|
27 | push(@{$hashArgOptLists->{"ArgList"}},@{$arguments});
|
---|
28 | push(@{$hashArgOptLists->{"OptList"}},$options);
|
---|
29 |
|
---|
30 | my $self = new BaseClassifier($classifierslist, $inputargs, $hashArgOptLists);
|
---|
31 |
|
---|
32 | if ($self->{'info_only'}) {
|
---|
33 | # don't worry about any options etc
|
---|
34 | return bless $self, $class;
|
---|
35 | }
|
---|
36 |
|
---|
37 | # Manually set $self parameters.
|
---|
38 | $self->{'list'} = {};
|
---|
39 |
|
---|
40 | $self->{'childtype'} = "HList";
|
---|
41 |
|
---|
42 | return bless $self, $class;
|
---|
43 | }
|
---|
44 |
|
---|
45 | sub init
|
---|
46 | {
|
---|
47 | my $self = shift(@_);
|
---|
48 |
|
---|
49 | }
|
---|
50 |
|
---|
51 | sub classify {
|
---|
52 |
|
---|
53 | my $self = shift (@_);
|
---|
54 | my ($doc_obj) = @_;
|
---|
55 |
|
---|
56 | my $doc_OID = $doc_obj->get_OID();
|
---|
57 | my $filename = $doc_obj->get_sourcefile();
|
---|
58 | return unless $filename =~ /\.item$/; # only classify the item files here
|
---|
59 | $filename =~ s/\.item$//; # remove the file extension
|
---|
60 | print STDERR "classifying $filename\n";
|
---|
61 | if (defined $self->{'list'}->{$doc_OID}) {
|
---|
62 | my $outhandle = $self->{'outhandle'};
|
---|
63 | print $outhandle "WARNING: PJFileNameList::classify called multiple times for $doc_OID\n";
|
---|
64 | return;
|
---|
65 | }
|
---|
66 |
|
---|
67 | $self->{'list'}->{$doc_OID} = "$filename";
|
---|
68 |
|
---|
69 |
|
---|
70 | }
|
---|
71 |
|
---|
72 | sub get_classify_info {
|
---|
73 | my $self = shift (@_);
|
---|
74 |
|
---|
75 | #my @classlist = sort {$self->{'list'}->{$a} alpha_numeric_cmp $self->{'list'}->{$b};} keys %{$self->{'list'}};
|
---|
76 | my @classlist = sort {$self->{'list'}->{$a} cmp $self->{'list'}->{$b};} keys %{$self->{'list'}};
|
---|
77 |
|
---|
78 | return $self->splitlist(\@classlist);
|
---|
79 | }
|
---|
80 |
|
---|
81 | sub get_entry {
|
---|
82 | my $self = shift (@_);
|
---|
83 | my ($title, $childtype, $thistype) = @_;
|
---|
84 |
|
---|
85 | # organise into classification structure
|
---|
86 | my %classifyinfo = ('childtype'=>$childtype,
|
---|
87 | 'Title'=>$title,
|
---|
88 | 'contains'=>[],
|
---|
89 | 'mdtype'=>'filename');
|
---|
90 | $classifyinfo{'thistype'} = $thistype
|
---|
91 | if defined $thistype && $thistype =~ /\w/;
|
---|
92 |
|
---|
93 | return \%classifyinfo;
|
---|
94 | }
|
---|
95 |
|
---|
96 | # splitlist takes an ordered list of classifications (@$classlistref) and
|
---|
97 | # splits it up into sub-sections by date
|
---|
98 | sub splitlist {
|
---|
99 | my $self = shift (@_);
|
---|
100 | my ($classlistref) = @_;
|
---|
101 | my $classhash = {};
|
---|
102 |
|
---|
103 | # top level
|
---|
104 | #my $childtype = "HList";
|
---|
105 |
|
---|
106 | # the top level node
|
---|
107 | my $classifyinfo = $self->get_entry ("FileNames", "HList", "Invisible");
|
---|
108 |
|
---|
109 | # make the classifications
|
---|
110 | foreach my $item (@$classlistref) {
|
---|
111 | my $filename = $self->{'list'}->{$item};
|
---|
112 | print STDERR "filename=$filename\n";
|
---|
113 | my ($first, $second) = $filename =~ m@^(3[A-Z])(\d+)-(\d+)(.*)$@;
|
---|
114 | $classhash->{$first} = () unless defined $classhash->{$first};
|
---|
115 | $classhash->{$first}->{$second} = [] unless defined $classhash->{$first}->{$second};
|
---|
116 | push (@{$classhash->{$first}->{$second}}, $item);
|
---|
117 | }
|
---|
118 |
|
---|
119 | ##### UP to here!!!
|
---|
120 | my @subclasslist = sort keys %$classhash;
|
---|
121 | foreach my $subclass (@subclasslist) {
|
---|
122 | my $topclassify = $self->get_entry($subclass, "HList");
|
---|
123 | my @subsubclasslist = sort {$a <=> $b} (keys %{$classhash->{$subclass}});
|
---|
124 | foreach my $subsubclass (@subsubclasslist) {
|
---|
125 | my $secondclassify = $self->get_entry($subsubclass, "VList");
|
---|
126 | push (@{$topclassify->{'contains'}}, $secondclassify);
|
---|
127 | foreach my $subsubOID
|
---|
128 | (@{$classhash->{$subclass}->{$subsubclass}}) {
|
---|
129 | push (@{$secondclassify->{'contains'}},
|
---|
130 | {'OID'=>$subsubOID});
|
---|
131 | }
|
---|
132 |
|
---|
133 |
|
---|
134 | }
|
---|
135 | push (@{$classifyinfo->{'contains'}}, $topclassify);
|
---|
136 |
|
---|
137 | }
|
---|
138 | return $classifyinfo;
|
---|
139 | }
|
---|
140 |
|
---|
141 | # sort items like 3A01-13_Part_1 properly
|
---|
142 | # 3A08-05
|
---|
143 | # 3A08-02_Part_1
|
---|
144 | # 3A05-04_Photo_1
|
---|
145 | # 3A08-28_Part_A
|
---|
146 | # 3A08-15_No_03
|
---|
147 | #3A09-10a_Part_1
|
---|
148 | #3A09-11e
|
---|
149 | sub alpha_numeric_cmp
|
---|
150 | {
|
---|
151 | my ($self,$a,$b) = @_;
|
---|
152 | my ($a1, $a2, $a3, $a4) = $a =~ m@^3([A-Z])(\d+)-(\d+)(.*)$@;
|
---|
153 | my ($b1, $b2, $b3, $b4) = $b =~ m@^3([A-Z])(\d+)-(\d+)(.*)$@;
|
---|
154 | if ($a1 && $b1) {
|
---|
155 | if ($a1 != $b1) { # letter
|
---|
156 | return ($a1 cmp $b1);
|
---|
157 | }
|
---|
158 | if ($a2 && $b2) {
|
---|
159 | if ($a2 != $b2) { # numeric
|
---|
160 | return ($a2 <=> $b2);
|
---|
161 | }
|
---|
162 | if ($a3 && $b3) {
|
---|
163 | if ($a3 != $b3) { # numeric
|
---|
164 | return ($a3 <=> $b3);
|
---|
165 | } else {
|
---|
166 | # both strings start with the same thing eg 3A01-01
|
---|
167 | return ($a4 cmp $b4);
|
---|
168 |
|
---|
169 | }
|
---|
170 | }
|
---|
171 | }
|
---|
172 | }
|
---|
173 | return $a cmp $b;
|
---|
174 | }
|
---|
175 |
|
---|
176 |
|
---|
177 |
|
---|
178 | 1;
|
---|