1# -*- perl -*- 2 3# 4# Copyright (C) 2013 Slaven Rezic. All rights reserved. 5# This package is free software; you can redistribute it and/or 6# modify it under the same terms as Perl itself. 7# 8 9package Image::Info::WBMP; 10 11use strict; 12use vars qw($VERSION @EXPORT_OK); 13$VERSION = '0.01'; 14 15require Exporter; 16*import = \&Exporter::import; 17 18@EXPORT_OK = qw(wbmp_image_info); 19 20sub process_file { 21 my($info, $fh) = @_; 22 23 # wbmp files have no magic, so no signature check 24 25 $info->push_info(0, 'file_media_type' => 'image/vnd.wap.wbmp'); 26 $info->push_info(0, 'file_ext' => 'wbmp'); 27 28 # logic taken from netpbm's wbmptopbm.c and adapted to perl 29 30 my $readint = sub { 31 my $sum = 0; 32 my $pos = 0; 33 my $c; 34 do { 35 $c = ord(getc $fh); 36 $sum = ($sum << 7*$pos++) | ($c & 0x7f); 37 } while($c & 0x80); 38 return $sum; 39 }; 40 41 my $readheader = sub { 42 my $h = shift; 43 if ($h & 0x60 == 0) { 44 # type 00: read multi-byte bitfield 45 my $c; 46 do { $c = ord(getc $fh) } while($c & 0x80); 47 } elsif ($h & 0x60 == 0x60) { 48 # type 11: read name/value pair 49 for(my $i=0; $i < (($h & 0x70) >> 4) + ($h & 0x0f); $i++) { getc $fh } 50 } 51 }; 52 53 my $c; 54 $c = $readint->(); 55 $c == 0 56 or die "Unrecognized WBMP type (got $c)"; 57 $c = ord(getc $fh); # FixHeaderField 58 while($c & 0x80) { # ExtheaderFields 59 $c = ord(getc $fh); 60 $readheader->($c); 61 } 62 my $w = $readint->(); 63 my $h = $readint->(); 64 $info->push_info(0, 'width', $w); 65 $info->push_info(0, 'height', $h); 66} 67 68sub wbmp_image_info { 69 my $source = Image::Info::_source(shift); 70 return $source if ref $source eq 'HASH'; # Pass on errors 71 72 return Image::Info::_image_info_for_format('WBMP', $source); 73} 74 751; 76 77__END__ 78 79=head1 NAME 80 81Image::Info::WBMP - WBMP support for Image::Info 82 83=head1 SYNOPSIS 84 85 use Image::Info qw(dim); 86 use Image::Info::WBMP qw(wbmp_image_info); 87 88 my $info = wbmp_image_info("image.xpm"); 89 if (my $error = $info->{error}) { 90 die "Can't parse image info: $error\n"; 91 } 92 my($w, $h) = dim($info); 93 94=head1 DESCRIPTION 95 96wbmp is a magic-less file format, so using L<Image::Info>'s 97C<image_info> or C<image_type> does not work here. Instead, the user 98has to determine the file type himself, e.g. by relying on the file 99suffix or mime type, and use the C<wbmp_image_info> function instead. 100The returned value looks the same like L<Image::Info>'s C<image_info> 101and may be used in a call to the C<dim> function. 102 103=head1 AUTHOR 104 105Slaven Rezic <srezic@cpan.org> 106 107=begin register 108 109NO MAGIC: true 110 111wbmp files have no magic, so cannot be used with the normal 112Image::Info functions. See L<Image::Info::WBMP> for more information. 113 114=end register 115 116=cut 117