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 bran cond sub pod 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/>