56 |
|
|
57 |
$webpac->open_import_xml(type => 'isis_hidra_ths'); |
$webpac->open_import_xml(type => 'isis_hidra_ths'); |
58 |
|
|
59 |
|
if(0) { # XXX |
60 |
|
|
61 |
while (my $rec = $webpac->fetch_rec) { |
while (my $rec = $webpac->fetch_rec) { |
62 |
|
|
63 |
my @ds = $webpac->data_structure($rec); |
my @ds = $webpac->data_structure($rec); |
148 |
} |
} |
149 |
} |
} |
150 |
|
|
151 |
|
} # XXX if(0) |
152 |
|
|
153 |
$log->info("lookup hash: ",Dumper($webpac->{'lookup'})); |
$log->info("lookup hash: ",Dumper($webpac->{'lookup'})); |
154 |
|
|
155 |
# |
# |
170 |
<ul> |
<ul> |
171 |
}; |
}; |
172 |
|
|
173 |
foreach my $code (sort keys %{$webpac->{'lookup'}}) { |
my $l = $webpac->{'lookup'} || $log->logconfess("can't find lookup"); |
|
|
|
|
my $l = $webpac->{'lookup'} || $log->logconfess("can't find lookup"); |
|
|
|
|
|
if ($code =~ m/^root:/) { |
|
|
my $v900 = shift @{ $l->{$code} } || $log->logconfess("can't lookup '$code'"); |
|
|
$code =~ s/^root:// || die; |
|
|
|
|
|
my $term = shift @{ $l->{"d:${v900}"} } || die; |
|
|
my $mfn = shift @{ $l->{"900_mfn:${v900}"} } || die; |
|
|
|
|
|
$log->debug("$code -> $v900 : $term [$mfn]"); |
|
|
|
|
|
print HTML qq{ <li><a href="#mfn$mfn" onClick="return hide_show('mfn$mfn');">$term</a> <a href="thes/$mfn.html">»</a></li>\n} if (-e "out/thes/$mfn.html"); |
|
|
|
|
|
unless ($l->{"a:${code}::"}) { |
|
|
$log->warn("can't find 'a:${code}::'"); |
|
|
next; |
|
|
} |
|
174 |
|
|
175 |
print HTML qq{ <a name="mfn$mfn"></a><ul id="mfn$mfn" style="display: none">\n}; |
my @tree = ({ |
176 |
|
# level 0 |
177 |
|
code_arr => sub { sort keys %{$l} }, |
178 |
|
filter_code => sub { |
179 |
|
my $t = shift; |
180 |
|
return $t if ($t =~ s/root://); |
181 |
|
}, |
182 |
|
lookup_v900 => sub { shift @{$l->{"root:".$_[0]}} }, |
183 |
|
lookup_term => sub { shift @{$l->{"d:".$_[1]}} }, |
184 |
|
lookup_mfn => sub { shift @{$l->{"900_mfn:".$_[1]}} }, |
185 |
|
have_children => sub { $l->{"a:".$_[0]."::" } }, |
186 |
|
child_code => sub { return $_[0] }, |
187 |
|
style => 'display: none', |
188 |
|
},{ |
189 |
|
# 1 |
190 |
|
code_arr => sub { @{$l->{"a:".$_[0]."::"}} }, |
191 |
|
filter_code => sub { shift }, # nop |
192 |
|
lookup_v900 => sub { shift @{$l->{"code:".$_[0]}} }, |
193 |
|
lookup_term => sub { shift @{$l->{"d:".$_[0]}} }, |
194 |
|
lookup_mfn => sub { shift @{$l->{"900_mfn:".$_[0]}} }, |
195 |
|
have_children => sub { $l->{"a:".$_[1].":" } }, |
196 |
|
child_code => sub { return $_[1] }, |
197 |
|
style => 'display: none', |
198 |
|
},{ |
199 |
|
# 2 |
200 |
|
code_arr => sub { @{$l->{"a:".$_[0].":"}} }, |
201 |
|
filter_code => sub { shift }, |
202 |
|
lookup_v900 => sub { shift }, |
203 |
|
lookup_term => sub { shift @{$l->{"d:".$_[0]}} }, |
204 |
|
lookup_mfn => sub { shift @{$l->{"900_mfn:".$_[0]}} }, |
205 |
|
have_children => sub { 0 }, |
206 |
|
child_code => sub { 0 }, |
207 |
|
|
208 |
|
}); |
209 |
|
|
210 |
|
unroll(0,''); |
211 |
|
|
212 |
|
$log->debug("test filter: ",$tree[0]->{'filter_code'}->("root:99")); |
213 |
|
|
214 |
|
sub unroll { |
215 |
|
my ($level,$start_code) = @_; |
216 |
|
|
217 |
|
$log->logconfess("need level") unless (defined($level)); |
218 |
|
|
219 |
|
# all levels passed? |
220 |
|
return if (! defined($tree[$level])); |
221 |
|
|
222 |
|
$log->debug("unroll level $level, start code $start_code"); |
223 |
|
|
224 |
|
foreach my $code ($tree[$level]->{'code_arr'}->($start_code)) { |
225 |
|
|
226 |
|
if ($code = $tree[$level]->{'filter_code'}->($code)) { |
227 |
|
|
228 |
|
$log->debug("# $level filter passed code $code"); |
229 |
|
|
230 |
|
my $v900 = $tree[$level]->{'lookup_v900'}->($code) || $log->logdie("can't lookup_v900 '$code'"); |
231 |
|
$log->debug("# $level lookup_v900($code) = $v900"); |
232 |
|
my $term = $tree[$level]->{'lookup_term'}->($code,$v900) || $log->logdie("can't lookup_term '$v900'"); |
233 |
|
$log->debug("# $level lookup_term($code,$v900) = $term"); |
234 |
|
my $mfn = $tree[$level]->{'lookup_mfn'}->($code,$v900) || $log->logdie("can't lookup_mfn '$v900'"); |
235 |
|
$log->debug("# $level lookup_mfn($code,$v900) = $mfn"); |
236 |
|
|
237 |
foreach my $l2_v900 (@{ $l->{"a:${code}::"} }) { |
$log->debug("$code -> $v900 : $term [$mfn]"); |
|
|
|
|
my $l2_code = shift @{ $l->{"code:${l2_v900}"} } || die; |
|
|
my $l2_term = shift @{ $l->{"d:$l2_v900"} } || die; |
|
|
my $l2_mfn = shift @{ $l->{"900_mfn:${l2_v900}"} } || die; |
|
238 |
|
|
239 |
$log->debug("$l2_code -> $l2_v900 : $l2_term [$l2_mfn]"); |
print HTML " " x $level . |
240 |
|
qq{<li><a href="#mfn$mfn" onClick="return hide_show('mfn$mfn');">$term</a> <a href="thes/$mfn.html">»</a></li>\n} if (-e "out/thes/$mfn.html"); |
241 |
|
|
242 |
print HTML qq{ <li><a href="#mfn$l2_mfn" onClick="return hide_show('mfn$l2_mfn');">$l2_term</a> <a href="thes/$mfn.html">»</a></li>\n} if (-e "out/thes/$l2_mfn.html"); |
unless ($tree[$level]->{'have_children'}->($code,$v900)) { |
243 |
|
$log->warn("can't find children of $code at level $level"); |
|
unless ($l->{"a:${l2_code}:"}) { |
|
|
$log->warn("can't find 'a:${l2_code}:'"); |
|
244 |
next; |
next; |
245 |
} |
} |
246 |
|
|
247 |
|
print HTML " " x $level . |
248 |
|
qq{<a name="mfn$mfn"></a>\n <ul id="mfn$mfn"}. |
249 |
|
($tree[$level]->{'style'} ? ' style="'.$tree[$level]->{'style'}.'"' : ''). |
250 |
|
qq{>\n}; |
251 |
|
|
252 |
print HTML qq{ <a name="mfn$l2_mfn"></a><ul id="mfn$l2_mfn" style="display: none">\n}; |
unroll($level+1, $tree[$level]->{'child_code'}->($code,$v900)); |
253 |
|
|
254 |
foreach my $l3_v900 (@{ $l->{"a:${l2_code}:"} }) { |
print HTML " " x $level . qq{</ul>\n}; |
|
|
|
|
my $l3_term = shift @{ $l->{"d:$l3_v900"} } || die; |
|
|
my $l3_mfn = shift @{ $l->{"900_mfn:${l3_v900}"} } || die; |
|
|
|
|
|
$log->debug(" -> $l3_v900 : $l3_term [$l3_mfn]"); |
|
|
|
|
|
print HTML qq{ <li><a href="#mfn$l3_mfn.html">$l3_term</a> <a href="thes/$mfn.html">»</a></li>\n} if (-e "out/thes/$l3_mfn.html"); |
|
|
} |
|
255 |
|
|
|
print HTML qq{ </ul>\n}; |
|
256 |
} |
} |
|
print HTML qq{ </ul>\n}; |
|
257 |
} |
} |
258 |
} |
} |
259 |
|
|