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