File Coverage

blib/lib/Dezi/Utils.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

line	stmt	sub	time	code
1				package Dezi::Utils;
2	15	15	182	use Moose;
	15		28
	15		258
3	15	15	100847	use Carp;
	15		35
	15		1085
4	15	15	88	use Data::Dump qw( dump );
	15		30
	15		794
5	15	15	82	use File::Basename;
	15		33
	15		1007
6	15	15	1968	use Search::Tools::XML;
	15		200778
	15		506
7	15	15	227499	use SWISH::3 qw( :constants );
	0
	0
8
9				# this class differs from SWISH::Prog::Utils chiefly in that
10				# it uses SWISH::3::Config rather than hardcoding mime types
11				# and parser mappings. This is to ensure consistency with
12				# the SWISH::3 parser used in Indexer and Aggregator.
13
14				# singletons
15				my $SWISH3 = SWISH::3->new();
16				my $XML = Search::Tools::XML->new;
17
18				our $VERSION = '0.014';
19
20				=pod
21
22				=head1 NAME
23
24				Dezi::Utils - utility variables and methods
25
26				=head1 SYNOPSIS
27
28				use Dezi::Utils;
29
30				my $ext = Dezi::Utils->get_file_ext( $filename );
31				my $mime = Dezi::Utils->get_mime( $filename );
32				if (Dezi::Utils->looks_like_gz( $filename )) {
33				$mime = Dezi::Utils->get_real_mime( $filename );
34				}
35				my $parser = Dezi::Utils->get_parser_for_mime( $mime );
36
37				=head1 DESCRIPTION
38
39				This class provides commonly used variables and methods
40				shared by many classes in the Dezi project.
41
42				=head1 VARIABLES
43
44				=over
45
46				=item $ExtRE
47
48				Regular expression of common file type extensions.
49
50				=item %ParserTypes
51
52				Hash of MIME types to their equivalent parser. This hash is
53				used to cache lookups in get_parser_for_mime().
54				You really don't want to mess with this, but documented
55				in case you're brave or foolish.
56
57				=item $DefaultExtension
58
59				Defaults to C<html>.
60
61				=item $DefaultMIME
62
63				Defaults to C<text/html>.
64
65				=back
66
67				=cut
68
69				our $ExtRE = qr{\.(\w+)(\.gz)?$}io;
70				our %ParserTypes = ();
71				our $DefaultExtension = 'html';
72				our $DefaultMIME = 'text/html';
73
74				# internal cache to avoid hitting SWISH::3 each time
75				# and to map common extensions that SWISH::3 may not define
76				my %ext2mime = (
77				doc => 'application/msword',
78				pdf => 'application/pdf',
79				ppt => 'application/vnd.ms-powerpoint',
80				html => 'text/html',
81				htm => 'text/html',
82				txt => 'text/plain',
83				text => 'text/plain',
84				xml => 'application/xml',
85				mp3 => 'audio/mpeg',
86				gz => 'application/x-gzip',
87				xls => 'application/vnd.ms-excel',
88				zip => 'application/zip',
89				json => 'application/json',
90				yml => 'application/x-yaml',
91				php => 'text/html',
92
93				);
94
95				=head1 METHODS
96
97				=head2 get_mime( I<url> [, I<swish3>] )
98
99				Returns MIME type for I<url>, using optional I<swish3> instance to look it up.
100				If I<swish3> is missing, will use the L<SWISH::3> default mapping.
101
102				=cut
103
104				sub get_mime {
105				my $self = shift;
106				my $url = shift;
107				confess "url required" unless defined $url;
108				my $s3 = shift;
109				if ($s3) {
110
111				if ( !$s3->isa('SWISH::3') ) {
112				confess "s3 object must be instance of SWISH::3, not " . ref($s3);
113				}
114
115				# look it up
116				my $ext = $s3->get_file_ext($url) \|\| $DefaultExtension;
117				return
118				$s3->get_mime($url)
119				\|\| $ext2mime{$ext}
120				\|\| $DefaultMIME;
121				}
122				else {
123				# check our cache first
124				my $ext = $SWISH3->get_file_ext($url) \|\| $DefaultExtension;
125				if ( exists $ext2mime{$ext} ) {
126				return $ext2mime{$ext};
127				}
128
129				# no cache? look it up and cache
130				my $mime = $SWISH3->get_mime($url);
131				$ext2mime{$ext} = $mime;
132				return $mime \|\| $DefaultMIME;
133				}
134				}
135
136				=head2 mime_type( I<url> [, I<ext> ] )
137
138				Backcompat for SWISH::Prog::Utils. Use get_mime() instead,
139				which is what this does internally.
140
141				=cut
142
143				sub mime_type {
144				my $self = shift;
145				my $url = shift or return;
146				return $self->get_mime($url);
147				}
148
149				=head2 get_parser_for_mime( I<mime> [, I<swish3_object>] )
150
151				Returns the SWISH::3 parser type for I<mime>. This can be
152				configured via the C<%ParserTypes> class variable.
153
154				=cut
155
156				sub get_parser_for_mime {
157				my $self = shift;
158				my $mime = shift;
159				confess "mime required" unless defined($mime);
160				my $s3 = shift;
161				if ($s3) {
162				return
163				$s3->config->get_parsers->get($mime)
164				\|\| $s3->config->get_parsers->get( SWISH_DEFAULT_PARSER() )
165				\|\| $ParserTypes{$mime};
166				}
167				else {
168				return $ParserTypes{$mime} if exists $ParserTypes{$mime};
169				$ParserTypes{$mime} = $SWISH3->config->get_parsers->get($mime)
170				\|\| $SWISH3->config->get_parsers->get( SWISH_DEFAULT_PARSER() );
171				return $ParserTypes{$mime};
172				}
173				}
174
175				=head2 parser_for( I<url> )
176
177				Backcompat for SWISH::Prog::Utils. Use get_parser_for_mime() instead,
178				which is what this does internally.
179
180				=cut
181
182				sub parser_for {
183				my $self = shift;
184				my $url = shift;
185				confess "url required" unless defined($url);
186				return $self->get_parser_for_mime( $self->get_mime($url) );
187				}
188
189				=head2 path_parts( I<url> [, I<regex> ] )
190
191				Returns array of I<path>, I<file> and I<extension> using the
192				File::Basename module. If I<regex> is missing or false,
193				uses $ExtRE.
194
195				=cut
196
197				sub path_parts {
198				my $self = shift;
199				my $url = shift;
200				my $re = shift \|\| $ExtRE;
201
202				# TODO build regex from ->config
203				my ( $file, $path, $ext ) = fileparse( $url, $re );
204				return ( $path, $file, $ext );
205				}
206
207				=head2 merge_swish3_config( I<key> => I<value> [, I<swish3>] )
208
209				The L<SWISH::3> class currently does not allow for modification
210				of the internal C structs from Perl space. Instead,
211				the SWISH::3::Config->merge method can be used to parse
212				XML strings. Since hand-crafting XML is tedious,
213				this method eases the pain.
214
215				I<key> should be a SWISH::3::Config reserved word. Use
216				the SWISH::3::Constants for safety.
217
218				I<value> is passed through perl_to_xml().
219				If I<value> is a hashref, it should be a simple key/value set with strings.
220				You may use arrayref values, where items in the array are strings.
221
222				The optional I<swish3> object is modified, or the internal
223				singleton SWISH::3 object will be modified if I<swish3>
224				is missing.
225
226				Example:
227
228				use SWISH::3 qw( :constants );
229				$utils->merge_swish3_config(
230				SWISH_PARSERS() => {
231				'XML' => [ 'application/x-bar', 'application/x-foo' ],
232				'HTML' => [ 'application/x-blue', 'application/x-red' ]
233				}
234				);
235				$utils->merge_swish3_config(
236				'foo' => 'bar'
237				);
238				$utils->get_parser_for_mime( 'application/x-foo' ); # returns 'XML'
239
240				=cut
241
242				sub merge_swish3_config {
243				my $self = shift;
244				my $key = shift or confess "key required";
245				my $hashref = shift or confess "hashref required";
246				my $s3 = shift \|\| $SWISH3;
247				my $xml = $XML->perl_to_xml( { $key => $hashref },
248				{ root => 'swish', wrap_array => 0 } );
249
250				#warn "xml=" . $XML->tidy($xml) . "\n";
251				$s3->config->merge($xml);
252				return $xml;
253				}
254
255				=head2 get_swish3
256
257				Returns the class singleton.
258
259				=cut
260
261				sub get_swish3 {$SWISH3}
262
263				=head2 perl_to_xml( I<ref>, I<root_element> [, I<strip_plural> ] )
264
265				Similar to the XML::Simple XMLout() feature, perl_to_xml()
266				will take a Perl data structure I<ref> and convert it to XML,
267				using I<root_element> as the top-level element.
268
269				As of version 0.38 this method is now part of Search::Tools
270				and included here simply as a backcompat feature.
271
272				=cut
273
274				sub perl_to_xml {
275				my $self = shift;
276				return $XML->perl_to_xml(@_);
277				}
278
279				=head2 write_log( I<args> )
280
281				Logging method. By default writes to stderr via warn().
282
283				I<args> is a key/value pair hash, with keys B<uri> and B<msg>.
284
285				=cut
286
287				sub write_log {
288				my $self = shift;
289				my %args = @_;
290				my $uri = delete $args{uri} or croak "uri required";
291				my $msg = delete $args{msg} or croak "msg required";
292				warn sprintf( "[%s][%s] %s [%s]\n", scalar localtime(), $$, $uri, $msg );
293				}
294
295				=head2 write_log_line([I<char>, I<width>])
296
297				Writes I<char> x I<width> to stderr, to provide some visual separation when viewing logs.
298				I<char> defaults to C<-> and I<width> to C<80>.
299
300				=cut
301
302				sub write_log_line {
303				my $self = shift;
304				my $char = shift \|\| '-';
305				my $width = shift \|\| 80;
306				warn $char x $width, "\n";
307				}
308
309				__PACKAGE__->meta->make_immutable;
310
311				1;
312
313				__END__
314
315				=head1 AUTHOR
316
317				Peter Karman, E<lt>karpet@dezi.orgE<gt>
318
319				=head1 BUGS
320
321				Please report any bugs or feature requests to C<bug-dezi-app at rt.cpan.org>, or through
322				the web interface at L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Dezi-App>.
323				I will be notified, and then you'll automatically be notified of progress on your bug as I make changes.
324
325				=head1 SUPPORT
326
327				You can find documentation for this module with the perldoc command.
328
329				perldoc Dezi::Utils
330
331				You can also look for information at:
332
333				=over 4
334
335				=item * Website
336
337				L<http://dezi.org/>
338
339				=item * IRC
340
341				#dezisearch at freenode
342
343				=item * Mailing list
344
345				L<https://groups.google.com/forum/#!forum/dezi-search>
346
347				=item * RT: CPAN's request tracker
348
349				L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=Dezi-App>
350
351				=item * AnnoCPAN: Annotated CPAN documentation
352
353				L<http://annocpan.org/dist/Dezi-App>
354
355				=item * CPAN Ratings
356
357				L<http://cpanratings.perl.org/d/Dezi-App>
358
359				=item * Search CPAN
360
361				L<https://metacpan.org/dist/Dezi-App/>
362
363				=back
364
365				=head1 COPYRIGHT AND LICENSE
366
367				Copyright 2014 by Peter Karman
368
369				This library is free software; you can redistribute it and/or modify
370				it under the terms of the GPL v2 or later.
371
372				=head1 SEE ALSO
373
374				L<http://dezi.org/>, L<http://swish-e.org/>, L<http://lucy.apache.org/>