"Fossies" - the Fresh Open Source Software Archive 
Member "install-tl-20231127/tlpkg/TeXLive/TeXCatalogue.pm" (21 Dec 2021, 11529 Bytes) of package /linux/misc/install-tl-unx.tar.gz:
As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style:
standard) with prefixed line numbers and
code folding option.
Alternatively you can here
view or
download the uninterpreted source code file.
1 # $Id: TeXCatalogue.pm 61372 2021-12-21 22:46:16Z karl $
2 # TeXLive::TeXCatalogue - module for accessing the TeX Catalogue
3 # Copyright 2007-2021 Norbert Preining
4 # This file is licensed under the GNU General Public License version 2
5 # or any later version.
6 #
7 # Loads of code adapted from the catalogue checking script of Robin Fairbairns.
8
9 use strict; use warnings;
10
11 use XML::Parser;
12 use XML::XPath;
13 use XML::XPath::XMLParser;
14 use Text::Unidecode;
15
16 package TeXLive::TeXCatalogue::Entry;
17
18 my $svnrev = '$Revision: 61372 $';
19 my $_modulerevision = ($svnrev =~ m/: ([0-9]+) /) ? $1 : "unknown";
20 sub module_revision { return $_modulerevision; }
21
22 =pod
23
24 =head1 NAME
25
26 C<TeXLive::TeXCatalogue> - TeX Live access to the TeX Catalogue from CTAN
27
28 =head1 SYNOPSIS
29
30 use TeXLive::TeXCatalogue;
31 my $texcat = TeXLive::TLTREE->new();
32
33 $texcat->initialize();
34 $texcat->beautify();
35 $texcat->name();
36 $texcat->license();
37 $texcat->version();
38 $texcat->caption();
39 $texcat->description();
40 $texcat->ctan();
41 $texcat->texlive();
42 $texcat->miktex();
43 $texcat->docs();
44 $texcat->entry();
45 $texcat->alias();
46 $texcat->also();
47 $texcat->topics();
48 $texcat->contact();
49 $texcat->new();
50 $texcat->initialize();
51 $texcat->quest4texlive();
52 $texcat->location();
53 $texcat->entries();
54
55 =head1 DESCRIPTION
56
57 The L<TeXLive::TeXCatalogue> module provides access to the data stored
58 in the TeX Catalogue.
59
60 DOCUMENTATION MISSING, SORRY!!!
61
62 =cut
63
64 my $_parser = XML::Parser->new(
65 ErrorContext => 2,
66 ParseParamEnt => 1,
67 NoLWP => 1
68 );
69
70 sub new {
71 my $class = shift;
72 my %params = @_;
73 my $self = {
74 ioref => $params{'ioref'},
75 entry => defined($params{'entry'}) ? $params{'entry'} : {},
76 docs => defined($params{'docs'}) ? $params{'docs'} : {},
77 name => $params{'name'},
78 caption => $params{'caption'},
79 description => $params{'description'},
80 license => $params{'license'},
81 ctan => $params{'ctan'},
82 texlive => $params{'texlive'},
83 miktex => $params{'miktex'},
84 version => $params{'version'},
85 also => defined($params{'also'}) ? $params{'also'} : [],
86 topic => defined($params{'topic'}) ? $params{'topic'} : [],
87 alias => defined($params{'alias'}) ? $params{'alias'} : [],
88 contact => defined($params{'contact'}) ? $params{'contact'} : {},
89 };
90 bless $self, $class;
91 if (defined($self->{'ioref'})) {
92 $self->initialize();
93 }
94 return $self;
95 }
96
97 sub initialize {
98 my $self = shift;
99 # parse all the files
100 my $parser
101 = new XML::XPath->new(ioref => $self->{'ioref'}, parser => $_parser)
102 || die "Failed to parse given ioref";
103 $self->{'entry'}{'id'} = $parser->findvalue('/entry/@id')->value();
104 $self->{'entry'}{'date'} = $parser->findvalue('/entry/@datestamp')->value();
105 $self->{'entry'}{'modder'} = $parser->findvalue('/entry/@modifier')->value();
106 $self->{'name'} = $parser->findvalue("/entry/name")->value();
107 $self->{'caption'} = beautify($parser->findvalue("/entry/caption")->value());
108 $self->{'description'} = beautify($parser->findvalue("/entry/description")->value());
109 # there can be multiple entries of licenses, collected them all
110 # into one string
111 my $licset = $parser->find('/entry/license');
112 my @liclist;
113 foreach my $node ($licset->get_nodelist) {
114 my $lictype = $parser->find('./@type',$node);
115 push @liclist, "$lictype";
116 }
117 $self->{'license'} = join(' ', @liclist);
118 # was before
119 # $self->{'license'} = $parser->findvalue('/entry/license/@type')->value();
120 $self->{'version'} = Text::Unidecode::unidecode(
121 $parser->findvalue('/entry/version/@number')->value());
122 $self->{'ctan'} = $parser->findvalue('/entry/ctan/@path')->value();
123 if ($parser->findvalue('/entry/texlive/@location') ne "") {
124 $self->{'texlive'} = $parser->findvalue('/entry/texlive/@location')->value();
125 }
126 if ($parser->findvalue('/entry/miktex/@location') ne "") {
127 $self->{'miktex'} = $parser->findvalue('/entry/miktex/@location')->value();
128 }
129 # parse all alias entries
130 my $alset = $parser->find('/entry/alias');
131 for my $node ($alset->get_nodelist) {
132 my $id = $parser->find('./@id', $node);
133 push @{$self->{'alias'}}, "$id";
134 }
135 # parse the documentation entries
136 my $docset = $parser->find('/entry/documentation');
137 foreach my $node ($docset->get_nodelist) {
138 my $docfileparse = $parser->find('./@href',$node);
139 # convert to string
140 my $docfile = "$docfileparse";
141 # see comments at end of beautify()
142 my $details
143 = Text::Unidecode::unidecode($parser->find('./@details',$node));
144 my $language = $parser->find('./@language',$node);
145 $self->{'docs'}{$docfile}{'available'} = 1;
146 if ($details) { $self->{'docs'}{$docfile}{'details'} = "$details"; }
147 if ($language) { $self->{'docs'}{$docfile}{'language'} = "$language"; }
148 }
149 # parse the also entries
150 foreach my $node ($parser->find('/entry/also')->get_nodelist) {
151 my $alsoid = $parser->find('./@refid',$node);
152 push @{$self->{'also'}}, "$alsoid";
153 }
154 # parse the contact entries
155 foreach my $node ($parser->find('/entry/contact')->get_nodelist) {
156 my $contacttype = $parser->findvalue('./@type',$node);
157 my $contacthref = $parser->findvalue('./@href',$node);
158 if ($contacttype && $contacthref) {
159 $self->{'contact'}{$contacttype} = $contacthref;
160 }
161 }
162 # parse the keyval/topic entries
163 foreach my $node ($parser->find('/entry/keyval')->get_nodelist) {
164 my $k = $parser->findvalue('./@key',$node);
165 my $v = $parser->findvalue('./@value',$node);
166 # for now we only support evaluating the 'topic' key
167 if ("$k" eq 'topic') {
168 push @{$self->{'topic'}}, "$v";
169 }
170 }
171 }
172
173 sub beautify {
174 my ($txt) = @_;
175 # transliterate to ascii: it allows the final tlpdb to be pure ascii,
176 # avoiding problems since we don't control the user's terminal encoding
177 # Do first in case spaces are output by the transliteration.
178 $txt = Text::Unidecode::unidecode($txt);
179 #
180 $txt =~ s/\n/ /g; # make one line
181 $txt =~ s/^\s+//g; # rm leading whitespace
182 $txt =~ s/\s+$//g; # rm trailing whitespace
183 $txt =~ s/\s\s+/ /g; # collapse multiple whitespace characters to one
184 $txt =~ s/\t/ /g; # tabs to spaces
185
186 # one last bit of horribleness: there is one url in the descriptions
187 # which is longer than our multilineformat format (in TLPOBJ). The
188 # result is that it is forcibly broken. Apparently there is no way in
189 # Perl to override that. This makes it impossible to get identical
190 # longdesc results. Turns out that removing the "http://" prefix
191 # shortens it enough to fit, so do that. The better solution would be
192 # to use Text::Wrap or some other text-filling code, but going for
193 # quick and dirty here.
194 $txt =~ s,http://grants.nih.gov/,grants.nih.gov/,g;
195
196 return $txt;
197 }
198
199 sub name {
200 my $self = shift;
201 if (@_) { $self->{'name'} = shift }
202 return $self->{'name'};
203 }
204 sub license {
205 my $self = shift;
206 if (@_) { $self->{'license'} = shift }
207 return $self->{'license'};
208 }
209 sub version {
210 my $self = shift;
211 if (@_) { $self->{'version'} = shift }
212 return $self->{'version'};
213 }
214 sub caption {
215 my $self = shift;
216 if (@_) { $self->{'caption'} = shift }
217 return $self->{'caption'};
218 }
219 sub description {
220 my $self = shift;
221 if (@_) { $self->{'description'} = shift }
222 return $self->{'description'};
223 }
224 sub ctan {
225 my $self = shift;
226 if (@_) { $self->{'ctan'} = shift }
227 return $self->{'ctan'};
228 }
229 sub texlive {
230 my $self = shift;
231 if (@_) { $self->{'texlive'} = shift }
232 return $self->{'texlive'};
233 }
234 sub miktex {
235 my $self = shift;
236 if (@_) { $self->{'miktex'} = shift }
237 return $self->{'miktex'};
238 }
239 sub docs {
240 my $self = shift;
241 my %newdocs = @_;
242 if (@_) { $self->{'docs'} = \%newdocs }
243 return $self->{'docs'};
244 }
245 sub entry {
246 my $self = shift;
247 my %newentry = @_;
248 if (@_) { $self->{'entry'} = \%newentry }
249 return $self->{'entry'};
250 }
251 sub alias {
252 my $self = shift;
253 my @newalias = @_;
254 if (@_) { $self->{'alias'} = \@newalias }
255 return $self->{'alias'};
256 }
257 sub also {
258 my $self = shift;
259 my @newalso = @_;
260 if (@_) { $self->{'also'} = \@newalso }
261 return $self->{'also'};
262 }
263 sub topics {
264 my $self = shift;
265 my @newtopics = @_;
266 if (@_) { $self->{'topic'} = \@newtopics }
267 return $self->{'topic'};
268 }
269 sub contact {
270 my $self = shift;
271 my %newcontact = @_;
272 if (@_) { $self->{'contact'} = \%newcontact }
273 return $self->{'contact'};
274 }
275
276
277 ################################################################
278 #
279 # TeXLive::TeXCatalogue
280 #
281 ################################################################
282 package TeXLive::TeXCatalogue;
283
284 sub new {
285 my $class = shift;
286 my %params = @_;
287 my $self = {
288 location => $params{'location'},
289 entries => defined($params{'entries'}) ? $params{'entries'} : {},
290 };
291 bless $self, $class;
292 if (defined($self->{'location'})) {
293 $self->initialize();
294 $self->quest4texlive();
295 }
296 return $self;
297 }
298
299 sub initialize {
300 my $self = shift;
301 # chdir to the location of the DTD file, otherwise it cannot be found
302 # furthermore we have to open the xml file from a file handle otherwise
303 # the catalogue.dtd is searched in a/catalogue.dtd etc, see above
304 my $cwd = `pwd`;
305 chomp($cwd);
306 chdir($self->{'location'} . "/entries")
307 || die "chdir($self->{location}/entries failed: $!";
308 # parse all the files
309 foreach (glob("?/*.xml")) {
310 # for debugging, nice to skip everything but: next unless /pst-node/;
311 open(my $io,"<$_") or die "open($_) failed: $!";
312 our $tce;
313 # the XML parser die's on malformed xml entries, so we catch
314 # that and continue, simply skipping the entry
315 eval { $tce = TeXLive::TeXCatalogue::Entry->new( 'ioref' => $io ); };
316 if ($@) {
317 warn "TeXCatalogue.pm:$_: cannot parse, skipping: $@\n";
318 close($io);
319 next;
320 }
321 close($io);
322 $self->{'entries'}{lc($tce->{'entry'}{'id'})} = $tce;
323 }
324 chdir($cwd) || die ("Cannot change back to $cwd: $!");
325 }
326
327 # Copy every catalogue $entry under the name $entry->{'texlive'}
328 # if it makes sense.
329 #
330 sub quest4texlive {
331 my $self = shift;
332
333 # The catalogue has a partial mapping from catalogue entries to
334 # texlive packages: $id --> $texcat->{$id}{'texlive'}
335 my $texcat = $self->{'entries'};
336
337 # Try to build the inverse mapping:
338 my (%inv, %count);
339 for my $id (keys %{$texcat}) {
340 my $tl = $texcat->{$id}{'texlive'};
341 if (defined($tl)) {
342 $tl =~ s/^bin-//;
343 $count{$tl}++;
344 $inv{$tl} = $id;
345 }
346 }
347 # Go through texlive names
348 for my $name (keys %inv) {
349 # If this name is free and there is only one corresponding catalogue
350 # entry then copy the entry under this name
351 if (!exists($texcat->{$name}) && $count{$name} == 1) {
352 $texcat->{$name} = $texcat->{$inv{$name}};
353 }
354 }
355 }
356
357 sub location {
358 my $self = shift;
359 if (@_) { $self->{'location'} = shift }
360 return $self->{'location'};
361 }
362
363 sub entries {
364 my $self = shift;
365 my %newentries = @_;
366 if (@_) { $self->{'entries'} = \%newentries }
367 return $self->{'entries'};
368 }
369
370 1;
371 __END__
372
373 =head1 SEE ALSO
374
375 The other modules in C<Master/tlpkg/TeXLive/> (L<TeXLive::TLConfig> and
376 the rest), and the scripts in C<Master/tlpkg/bin/> (especially
377 C<tl-update-tlpdb>), the documentation in C<Master/tlpkg/doc/>, etc.
378
379 =head1 AUTHORS AND COPYRIGHT
380
381 This script and its documentation were written for the TeX Live
382 distribution (L<https://tug.org/texlive>) and both are licensed under the
383 GNU General Public License Version 2 or later.
384
385 =cut
386
387 ### Local Variables:
388 ### perl-indent-level: 2
389 ### tab-width: 2
390 ### indent-tabs-mode: nil
391 ### End:
392 # vim:set tabstop=2 expandtab: #