File Coverage

blib/lib/SWISH/Filters/ImageToMD5Xml.pm
Criterion Covered Total %
statement 36 37 97.3
branch 5 10 50.0
condition 1 3 33.3
subroutine 9 9 100.0
pod 2 2 100.0
total 53 61 86.8


line stmt bran cond sub pod time code
1             package SWISH::Filters::ImageToMD5Xml;
2 2     2   25505 use strict;
  2         3  
  2         52  
3 2     2   10 use warnings;
  2         5  
  2         69  
4 2     2   12 use base 'SWISH::Filters::Base';
  2         8  
  2         4340  
5 2     2   7402 use Digest::MD5 qw(md5);
  2         4  
  2         116  
6 2     2   2913 use XML::Simple;
  2         20213  
  2         14  
7              
8             =head1 NAME
9              
10             SWISH::Filters::ImageToMD5Xml - Adds MD5 information when filtering an image for SWISHE.
11              
12             =head1 VERSION
13              
14             Version 0.04
15              
16             =cut
17              
18             our $VERSION = '0.04';
19              
20             =head1 SYNOPSIS
21              
22             A L that takes an incoming image XML and applies a MD5 checksum
23             against the binary content of the image.
24              
25             The XML structure this filter expects includes an C element containing
26             the Base64 string representing the image. If that element (tag) is not found,
27             no filter is applied.
28              
29             =head1 METHODS
30              
31             =head2 new ( $class )
32              
33             Constructor.
34              
35             =cut
36              
37             sub new {
38 1     1 1 465 my ( $class ) = @_;
39              
40 1   33     9 $class = ref $class || $class;
41              
42 1         3 my $self = bless { }, $class;
43              
44 1         4 return $self->_init;
45             }
46              
47             sub _init {
48 1     1   2 my ( $self ) = @_;
49              
50 1         440 $self->use_modules(qw/MIME::Base64 Search::Tools::XML XML::Simple/);
51              
52 1         416 my @mimetypes = (
53             'application/xml'
54             );
55              
56 1         7 $self->{mimetypes} = \@mimetypes;
57              
58 1         4 return $self;
59             }
60              
61             sub _parse_xml {
62 1     1   4 my ( $self, $xml ) = @_;
63              
64 1 50       5 if ( $xml ) {
65 1         9 return XMLin($xml);
66             }
67             }
68              
69             =head2 filter( $self, $doc )
70              
71             Generates XML meta data for indexing. If I<$doc> contains the C element (tag)
72             then a MD5 checksum string will be added to the XML and returned with a new root element C.
73              
74             =cut
75              
76             sub filter {
77 1     1 1 50329 my ( $self, $doc ) = @_;
78              
79 1 50       8 return if $doc->is_binary;
80              
81 1 50       32 if ( my $xml = $doc->fetch_filename ) {
82 1 50       2591 if ( my $ds = $self->_parse_xml($xml) ) {
83 1 50       144875 return unless exists $ds->{b64_data};
84 1         3551 $ds->{md5} = md5($ds->{b64_data});
85 1         19 my $xml = Search::Tools::XML->perl_to_xml($ds, { root => 'image_data' });
86 1         16857 $doc->set_content_type('application/xml');
87 1         13 return ( \$xml );
88             }
89             }
90              
91 0           return;
92             }
93              
94              
95             =head1 AUTHOR
96              
97             Logan Bell, C<< >>
98              
99             =head1 BUGS
100              
101             Please report any bugs or feature requests to C, or through
102             the web interface at L. I will be notified, and then you'll
103             automatically be notified of progress on your bug as I make changes.
104              
105              
106              
107              
108             =head1 SUPPORT
109              
110             You can find documentation for this module with the perldoc command.
111              
112             perldoc SWISH::Filters::ImageToMD5Xml
113              
114              
115             You can also look for information at:
116              
117             =over 4
118              
119             =item * RT: CPAN's request tracker (report bugs here)
120              
121             L
122              
123             =item * AnnoCPAN: Annotated CPAN documentation
124              
125             L
126              
127             =item * CPAN Ratings
128              
129             L
130              
131             =item * Search CPAN
132              
133             L
134              
135             =back
136              
137              
138             =head1 ACKNOWLEDGEMENTS
139              
140              
141             =head1 LICENSE AND COPYRIGHT
142              
143             Copyright 2011 Logan Bell.
144              
145             This program is free software; you can redistribute it and/or modify it
146             under the terms of either: the GNU General Public License as published
147             by the Free Software Foundation; or the Artistic License.
148              
149             See http://dev.perl.org/licenses/ for more information.
150              
151              
152             =cut
153              
154             1; # End of SWISH::Filters::ImageToMD5Xml