diff options
Diffstat (limited to 'macros/latex/exptl/graphicp/img_bbox.pl')
| -rwxr-xr-x | macros/latex/exptl/graphicp/img_bbox.pl | 2079 |
1 files changed, 2079 insertions, 0 deletions
diff --git a/macros/latex/exptl/graphicp/img_bbox.pl b/macros/latex/exptl/graphicp/img_bbox.pl new file mode 100755 index 0000000000..12c1b951c7 --- /dev/null +++ b/macros/latex/exptl/graphicp/img_bbox.pl @@ -0,0 +1,2079 @@ +#! /bin/sh +eval '(exit $?0)' && eval 'PERL_BADLANG=x;export PERL_BADLANG;: \ +;exec perl -x -S -- "$0" ${1+"$@"};#'if 0; +eval 'setenv PERL_BADLANG x;exec perl -x -S -- "$0" $argv:q;#'.q+ +#!perl -w +package Htex::img_bbox; $0=~/(.*)/s;unshift@INC,'.';do($1);die$@if$@;__END__+if !1; +# This Perl script was generated by JustLib2 at Sun Feb 9 23:57:24 2003. +# Don't touch/remove any lines above; http://www.inf.bme.hu/~pts/justlib +package just; BEGIN{$INC{'just.pm'}='just.pm'} +BEGIN{ $just::VERSION=2 } +sub end(){1} +sub main(){} + +BEGIN{$ INC{'integer.pm'}='integer.pm'} { +package integer; +use just; +# by pts@fazekas.hu at Wed Jan 10 12:42:08 CET 2001 +sub import { $^H |= 1 } +sub unimport { $^H &= ~1 } +just::end} + +BEGIN{$ INC{'strict.pm'}='strict.pm'} { +package strict; +use just; +# by pts@fazekas.hu at Wed Jan 10 12:42:08 CET 2001 +require 5.002; +sub bits { + (grep{'refs'eq$_}@_ && 2)| + (grep{'subs'eq$_}@_ && 0x200)| + (grep{'vars'eq$_}@_ && 0x400)| + ($@ || 0x602) +} +sub import { shift; $^H |= bits @_ } +sub unimport { shift; $^H &= ~ bits @_ } +just::end} + +BEGIN{$ INC{'Pts/string.pm'}='Pts/string.pm'} { +package Pts::string; +# by pts@fazekas.hu at Sat Dec 21 21:32:18 CET 2002 +use just; +use integer; +use strict; + +#** @param $_[0] a string +#** @param $_[1] index of first bit to return. Bit 128 of byte 0 is index 0. +#** @param $_[2] number of bits to return (<=32) +#** @return an integer (negative on overflow), bit at $_[1] is its MSB +sub get_bits_msb($$$) { + # assume: use integer; + my $loop=$_[1]; + my $count=$_[2]; + my $ret=0; + ($ret+=$ret+(1&(vec($_[0],$loop>>3,8)>>(7-($loop&7)))), $loop++) while $count--!=0; + $ret +} + +#** @param $_[0] a string +#** @return value if $_[0] represents a floating point numeric constant +#** in the C language (without the LU etc. modifiers) -- or undef. Returns +#** undef for integer constants +sub c_floatval($) { + my $S=$_[0]; + no integer; # very important; has local scope + return 0.0+$S if $S=~/\A[+-]?(?:[0-9]*\.[0-9]+|[0-9]+\.])(?:[eE][+-]?[0-9]+)?\Z(?!\n)/; + undef +} + +#** @param $_[0] a string +#** @return value if $_[0] represents a floating point or integer numeric +#** constant in the C language (without the LU etc. modifiers) -- or undef +sub c_numval($) { + my $S=$_[0]; + no integer; # very important; has local scope + return 0+$S if $S=~/\A[+-]?(?:[0-9]*\.[0-9]+(?:[eE][+-]?[0-9]+)?|[0-9]+\.?)\Z(?!\n)/; + undef +} + +#** @param $_[0] a string +#** @return the integer value of $_[0] in C -- or undef +sub c_intval($) { + my $S=$_[0]; + my $neg=1; + $neg=-1 if $S=~s@\A([+-])@@ and '-'eq$1; + return $neg*hex $1 if $S=~/\A0[xX]([0-9a-fA-F]+)\Z(?!\n)/; + return $neg*oct $1 if $S=~/\A0([0-7]+)\Z(?!\n)/; + return $neg*$1 if $S=~/\A([0-9]+)\Z(?!\n)/; + undef +} + +sub import { + no strict 'refs'; + my $package = (caller())[0]; + shift; # my package + for my $p (@_ ? @_ : qw{get_bits_msb c_floatval c_numval c_intval}) { *{$package."::$p"}=\&{$p} } +} + +just::end} + +BEGIN{$ INC{'Htex/dimen.pm'}='Htex/dimen.pm'} { +package Htex::dimen; +# by pts@fazekas.hu at Sat Dec 21 21:26:15 CET 2002 +use just; +use integer; +use strict; +use Pts::string qw(c_numval); + +my %bp_mul; +{ no integer; %bp_mul=( + 'bp'=>1, # 1 bp = 1 bp (big point) + 'in'=>72, # 1 in = 72 bp (inch) + 'pt'=>72/72.27, # 1 pt = 72/72.27 bp (point) + 'pc'=>12*72/72.27, # 1 pc = 12*72/72.27 bp (pica) + 'dd'=>1238/1157*72/72.27, # 1 dd = 1238/1157*72/72.27 bp (didot point) [about 1.06601110141206 bp] + 'cc'=>12*1238/1157*72/72.27, # 1 cc = 12*1238/1157*72/72.27 bp (cicero) + 'sp'=>72/72.27/65536, # 1 sp = 72/72.27/65536 bp (scaled point) + 'cm'=>72/2.54, # 1 cm = 72/2.54 bp (centimeter) + 'mm'=>7.2/2.54, # 1 mm = 7.2/2.54 bp (millimeter) +) } + +#** @param $_[0] a (real or integer) number, optionally postfixed by a +#** TeX dimension specifier (default=bp) +#** @return the number in bp, or undef +sub dimen2bp($) { + no integer; + my $S=$_[0]; + my $mul; + $mul=$bp_mul{$1} if $S=~s/\s*([a-z][a-z0-9]+)\Z(?!\n)// and exists $bp_mul{$1}; + my $val=c_numval($S); + $val*=$mul if defined $val and defined $mul; + $val +} + +just::end} + +BEGIN{$ INC{'Htex/ImgBBox.pm'}='Htex/ImgBBox.pm'} { +package Htex::ImgBBox; +# +# ImgBBox -- extract file format and size from image files +# by pts@fazekas.hu at Sat Dec 7 21:31:01 CET 2002 +# JustLib2 at Sat Dec 21 21:29:21 CET 2002 +# +# Dat: we know most of xloadimage-1.16, most of of file(1)-debian-potato, +# all of sam2p-0.40, all of xv-3.10 +# Dat: only in xloadimage: g3Ident, g3Load, "G3 FAX Image", (hard to identify file format) +# Dat: only in xloadimage: macIdent, macLoad, "MacPaint Image", (stupid, black-white) +# Imp: multiple paper sizes +# +use just; +use integer; +use strict; +use Htex::dimen; +use Pts::string; +# use Data::Dumper; + +# Dat: BBoxInfo is a hashref: +# Dat: Info.* keys has FileFormat-dependent meaning (thus Info.depth may have +# different meanings for different FileFormats) +# { 'FileFormat' => 'TIFF' # ... +# 'SubFormat' => 'PPM' +# 'Error' => 0 +# 'LLX' => ... # lower left x (usually 0) +# 'LLY' => ... # lower left y (usually 0) +# 'URX' => ... # upper right x (usually width) +# 'URY' => ... # upper right y (usually height) +# } + +# Dat: \usepackage[hiresbb]{graphicx} +# Dat: pdfTeX graphicx.sty doesn't respect PDF CropBox. For +# /MediaBox[a b c d], \ht=d, \wd=c, and no overwrite below (a,b) + +# --- + +#** import will set them +my $have_pdf; +my $have_paper; + +#** May moves the file offset, but only relatively (SEEK_CUR). +#** @param $_[0] \*FILE +#** @return BBoxInfo +sub calc($) { + my $F=$_[0]; + my $dummy; + my @L; + my $head; + #** BBoxInfo to return + my $bbi={ + # 'FileFormat' => '.IO.error', + 'FileFormat' => 'unknown', + 'LLX' => 0, 'LLY' => 0, # may be float; in `bp' + # 'URX' => 0, 'URY' => 0 # default: missing; may be float; in `bp' + }; + binmode $F; + if (0>read $F, $head, 256) { IOerr: $bbi->{Error}="IO: $!"; goto done } + if (length($head)==0) { $bbi->{FileFormat}='Empty'; return $bbi } + if ($head=~m@\A\s*/[*]\s+XPM\s+[*]/@) { # XPM + $bbi->{FileFormat}='XPM'; + goto IOerr if !seek $F, -length($head), 1; + select($F); $/='"'; select(STDOUT); <$F>; + $head=<$F>; + if ($head!~/\s*(\d+)\s+(\d+)\s+(\d+)\s+(\d+).*"\Z(?!\n)/s) { SYerr: $bbi->{Error}='syntax'; goto done } + # width, height, length(palette), length(pixelchar) + $bbi->{URX}=0+$1; + $bbi->{URY}=0+$2; + } elsif ($head=~m@\A\s*\/\*\s*Format_version=\S*\s+@i) { + $bbi->{FileFormat}='XBM1'; # ?? + goto IOerr if 0>read $F, $head, 256-length($head), length($head); + $head=~s@\*\/.*@@s; # keep only header + goto SYerr if $head!~m@\s+Width=(\d+)@i; + $bbi->{URX}=0+$1; + goto SYerr if $head!~m@\s+Height=(\d+)@i; + $bbi->{URY}=0+$1; + } elsif ($head=~m@\A(?:/[*].*?[*]/)?\s*#define\s+.*?_width\s+(\d+)\s*#define\s+.*?_height\s+(\d+)\s*@) { # XBM (1) + # Dat: this `if' must be after checking XPM + # Imp: recognise a longer comment (that does not fit into $head) + $bbi->{FileFormat}='XBM'; + $bbi->{URX}=0+$1; + $bbi->{URY}=0+$2; + } elsif ($head=~m@\A(?:/[*].*?[*]/)?\s*#define\s+.*?_height\s+(\d+)\s*#define\s+.*?_width\s+(\d+)\s*@) { # XBM (2) + $bbi->{FileFormat}='XBM'; + $bbi->{URX}=0+$2; + $bbi->{URY}=0+$1; + } elsif ($head=~m@\AP([1-6])[\s#]@) { # PNM + $bbi->{FileFormat}='PNM'; + my @subformats=qw{- PBM.text PGM.text PPM.text PBM.raw PGM.raw PPM.raw}; + $bbi->{SubFormat}=$subformats[0+$1]; + goto IOerr if 0>read $F, $head, 1024-length($head), length($head); + $head=~s@#.*@@g; # remove comments + goto SYerr if ($head!~/\AP[1-6]\s+(\d+)\s+(\d+)\s/); + $bbi->{URX}=0+$1; $bbi->{URY}=0+$2; + } elsif (substr($head, 0, 4) eq "MM\000\052" or substr($head, 0, 4) eq "II\052\000") { + $bbi->{FileFormat}='TIFF'; + my $LONG="N"; + my $SHORT="n"; + if (substr($head, 0, 1) eq "I") { + $bbi->{SubFormat}='LSBfirst'; + $LONG="V"; $SHORT="v"; + } else { + $bbi->{SubFormat}='MSBfirst'; + } + my($dummy,$ifd_ofs)=unpack $LONG.$LONG, $head; + goto IOerr if !seek $F, $ifd_ofs-length($head), 1; + my $ifd_len; + goto IOerr if 2!=read $F, $ifd_len, 2; + $ifd_len=unpack($SHORT,$ifd_len); + while ($ifd_len--!=0) { + my($entry,$tag,$type,$count,$value); + goto IOerr if 12!=read $F, $entry, 12; + ($tag,$type,$count)=unpack($SHORT.$SHORT.$LONG, $entry); + # vvv Dat: we discard tags with $value longer than 4 bytes + # Unfortunately BitsPerSample may be such a tag for RGB + if ($type==3) { $value=unpack($SHORT,substr($entry,8,2)) } + elsif ($type==4) { $value=unpack($LONG, substr($entry,8,4)) } + else { $value=vec($entry,8,8); } + if ($tag==256 and $count==1) { $bbi->{URX}=$value } # ImageWidth + elsif ($tag==257 and $count==1) { $bbi->{URY}=$value } # ImageLength + elsif ($tag==258 and $count<=2) { $bbi->{BitsPerSample}=$value } + elsif ($tag==259) { $bbi->{"Info.Compression"}=$value } + elsif ($tag==254) { $bbi->{"Info.NewSubfileType"}=$value } + elsif ($tag==255) { $bbi->{"Info.SubfileType"}=$value } + elsif ($tag==262) { $bbi->{"Info.PhotometricInterpretation"}=$value } + elsif ($tag==263) { $bbi->{"Info.Thresholding"}=$value } + elsif ($tag==264) { $bbi->{"Info.CellWidth"}=$value } + elsif ($tag==265) { $bbi->{"Info.CellLength"}=$value } + elsif ($tag==266) { $bbi->{"Info.FillOrder"}=$value } + elsif ($tag==274) { $bbi->{"Info.Orientation"}=$value } + elsif ($tag==277) { $bbi->{SamplesPerPixel}=$value } + elsif ($tag==278) { $bbi->{"Info.RowsPerStrip"}=$value } + elsif ($tag==280) { $bbi->{"Info.MinSampleValue"}=$value } + elsif ($tag==281) { $bbi->{"Info.MaxSampleValue"}=$value } + elsif ($tag==284) { $bbi->{"Info.PlanarConfiguration"}=$value } + elsif ($tag==290) { $bbi->{"Info.GrayResponseUnit"}=$value } + elsif ($tag==296) { $bbi->{"Info.ResolutionUnit"}=$value } + elsif ($tag==338 and $count<=2) { $bbi->{"Info.ExtraSamples"}=$value } + } + } elsif ($head=~/\A\12[\0-\005]\001[\001-\10]/) { + $bbi->{FileFormat}='PCX'; # PC Paintbrush image + ($dummy,$bbi->{LLX},$bbi->{LLY},$bbi->{URX},$bbi->{URY})=unpack("A4vvvv",$head); + $bbi->{URX}++; $bbi->{URY}++; + # pinfo->w = 1+ (hdr[PCX_XMAXL] + ((int) hdr[PCX_XMAXH]<<8)) - (hdr[PCX_XMINL] + ((int) hdr[PCX_XMINH]<<8)); + # pinfo->h = 1+ (hdr[PCX_YMAXL] + ((int) hdr[PCX_YMAXH]<<8)) - (hdr[PCX_YMINL] + ((int) hdr[PCX_YMINH]<<8)); + } elsif ($head=~/\AGIF(8[79]a)/) { + $bbi->{FileFormat}='GIF'; + $bbi->{SubFormat}=$1; + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("A6vv",$head); + } elsif ($head=~/\A(\377+\330)\377/g) { + $bbi->{FileFormat}='JPEG'; + die if !seek $F, length($1)-length($head), 1; + my $id_rgb=0; + my $had_jfif=0; + my $cpp; + my $colortransform=-1; # as defined by the Adobe APP14 marker + my $tag; + my $w; + while (1) { + goto IOerr if !defined($tag=getc($F)) or ord($tag)!=255; + 1 while defined($tag=getc($F)) and 255==($tag=ord($tag)); + goto IOerr if !defined($tag); + if ($tag==0xC0) { # SOF0 marker: Baseline JPEG file + $bbi->{SubFormat}='Baseline'; + goto IOerr if 2!=read $F, $w, 2; + $dummy=unpack('n',$w)-2; # length includes itself + goto IOerr if $dummy<9 or $dummy!=read($F, $w, $dummy); + $bbi->{BitsPerSample}=vec($w,0,8); + $bbi->{URY}=(vec($w,1,8)<<8)|vec($w,2,8); + $bbi->{URX}=(vec($w,3,8)<<8)|vec($w,4,8); + $cpp=vec($w,5,8); + goto SYerr if ($dummy-=6)!=3*$cpp or $cpp>6 or $cpp<1; + $bbi->{'Info.hvs'}=vec($w,7,8); # HVSamples ? + $id_rgb=1 if $cpp==3 and $w=~/\A......R..G..B/s; + } elsif (0xC1<=$tag and $tag<=0xCF and $tag!=0xC4 and $tag!=0xC8) { # SOFn + $bbi->{Subformat}="SOF".($tag-0xC0); + last + } elsif ($tag==0xD9 or $tag==0xDA) { # EOI or SOS marker; we're almost done + if (!defined $cpp) { + } elsif ($cpp==1) { + $bbi->{'ColorSpace'}='Gray'; + } elsif ($cpp==3) { + $bbi->{'ColorSpace'}='YCbCr'; + if ($had_jfif!=0 or $colortransform==1) {} + elsif ($colortransform==0 or $id_rgb) { $bbi->{'ColorSpace'}='RGB' } + } elsif ($cpp==4) { + $bbi->{'ColorSpace'}='CMYK'; + if ($colortransform==2) { $bbi->{'ColorSpace'}='YCCK' } + } + last + } else { + # skip over a variable-length block; assumes proper length marker + # ($tag==0xE0) # APP0: JFIF application-specific marker + # ($tag==0xEE) # APP14: Adobe application-specific marker + goto IOerr if 2!=read $F, $w, 2; + $dummy=unpack('n',$w)-2; # length includes itself + goto IOerr if $dummy!=read $F, $w, $dummy; + $colortransform=ord($1) if + $tag==0xEE and $dummy==12 and $w=~/\AAdobe[\001-\377].....(.)/s; + $had_jfif=1 if + $tag==0xE0 and $dummy==14 and $w=~/\AJFIF\0/; + } ## IF + } ## WHILE + $bbi->{'Info.id_rgb'}=$id_rgb; + $bbi->{'Info.had_jfif'}=$had_jfif; + $bbi->{'Info.ColorTransform'}=$colortransform; + $bbi->{SamplesPerPixel}=$cpp; + } elsif (substr($head,0,8) eq "\211PNG\r\n\032\n") { + $bbi->{FileFormat}='PNG'; + goto SYerr if $head!~/\A........\0\0\0[\15-\77]IHDR/s; + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("A16NN",$head); + } elsif (substr($head,0,5) eq "%PDF-") { + $bbi->{FileFormat}='PDF'; # Adobe Portable Document Format + # Dat: this routine cannot read encrypted PDF files + # Dat: example $bbi return: { + # 'URY' => 792, 'LLX' => '0', 'LLY' => '0', 'URX' => 612 + # 'FileFormat' => 'PDF', 'SubFormat' => '1.2', 'Info.linearized' => 1, 'Info.binary' => 'Binary', + # 'Info.MediaBox' => [ 0, 0, 612, 792 ], + # 'Info.CropBox' => [ 41, 63, 572, 729 ], + # }; + # Dat: $bbi->{'Info.num_pages'} is not reported for Linearized PDF. + # Imp: report much more specific error messages + # Imp: better distinguish between IOerr and SYerr + $bbi->{SubFormat}=$1 if $head=~/\A%PDF-([\d.]+)/; + $bbi->{'Info.binary'}=($head=~/\A[^\r\n]+[\r\n]+[ -~]*[^\n\r -~]/) ? 'Binary' : 'Clean7Bit'; + # die $have_pdf; + goto done if !$have_pdf; + # if ($head=~m@\A(?:%[^\r\n]*[\r\n])*.{0,40}/Linearized@s and $head=~m@\A(?:%[^\r\n]*[\r\n])*.{0,200}/O\s+(\d+)@s) { + my $had_pdfboxes=($head=~m@/Type\s*/pdfboxes%@); # `%' is important + $head=pdf_rewrite($head,1); + my $page1obj; + $bbi->{'Info.linearized'}=0; + $bbi->{'Info.pdfboxes'}=0; + if (defined $head) { + $head=~s@\bendobj.*@@s; + if ($had_pdfboxes) { + # a hint of very strict format, by + $head=""; + goto IOerr if !seek($F, 0, 0) or 20>read($F, $head, 2048); + goto SYerr unless $head=~/\d\s+\d+\s+obj\s*(.*?)\bendobj/s; + $head=$1; goto SYerr unless $head=~m@/Type\s*/pdfboxes%@; + while ($head=~m@^\s*/(\w+Box)\s*\[\s*(-?[\d.]+)\s+(-?[\d.]+)\s+(-?[\d.]+)\s+(-?[\d.]+)\s*\]@gm) { + ## print "($1) ($2) ($3) ($4) ($5)\n"; + ($bbi->{LLX},$bbi->{LLY},$bbi->{URX},$bbi->{URY})=($2,$3,$4,$5) if $1 eq 'MediaBox'; + $bbi->{"Info.$1"}=[$2,$3,$4,$5]; + } + $bbi->{'Info.pdfboxes'}=1; + goto done; + } elsif ($head=~m@/Linearized\s+@ and $head=~m@/O\s+(\d+)@) { + $bbi->{'Info.linearized'}=1; + $page1obj=$bbi->{'Info.page1obj'}=$1+0; + } + } + goto IOerr if !seek $F, -1024, 2 and !seek $F, 0, 0; + goto IOerr if 1>read $F, $head, 1024; + goto SYerr if $head!~/startxref\s+(\d+)\s*%%EOF\s*\Z(?!\n)/ + and $head!~/startxref\s+(\d+)\s*%%EOF/; + # ^^^ Dat: some PDF files contain binary junk at the end + my $xref_ofs=$1+0; + goto IOerr if !seek $F, $xref_ofs, 0; + # die pdf_read_obj($F); + my $xref=[]; + my $trailer=pdf_read_xref($F,$xref); + goto SYerr if !defined $trailer; + + my $pages; + my $type; + if (!defined $page1obj) { do_pdf_slow: + ## die $trailer; + ## die pdf_ref($F,$xref,37550,0); + ## die pdf_get($F,$xref,$trailer,'/ID'); + ## die pdf_get($F,$xref,$trailer,'/Root'); + ## die pdf_get($F,$xref,$trailer,'/Size'); + ## die pdf_get($F,$xref,$trailer,'/Sizez'); + + my $root=pdf_get($F,$xref,$trailer,'/Root'); + goto IOerr if !defined $root; goto SYerr if !length $root; + $type=pdf_get($F,$xref,$root,'/Type'); + goto IOerr if !defined $type; goto SYerr if $type ne ' /Catalog'; + # die $root; + # vvv Dat: reading xref for /Pages in a linearized PDF is quite slow + $pages=pdf_get($F,$xref,$root,'/Pages'); + goto IOerr if !defined $pages; goto SYerr if !length $pages; + ## die $pages; + my $kids; + + while (1) { + $type=pdf_get($F,$xref,$pages,'/Type'); + goto IOerr if !defined $type; + last if $type ne ' /Pages'; + pdf_get_boxes($F, $xref, $pages, $bbi); + $kids=pdf_get($F,$xref,$pages,'/Kids'); + goto IOerr if !defined $kids; goto SYerr if !length $kids; + ## die $kids; + $pages=pdf_get($F,$xref,$kids,0); + ## die $pages; + goto IOerr if !defined $pages; goto SYerr if !length $pages; + } + goto SYerr if $type ne ' /Page'; + # Dat: cannot set $page1obj properly here, because it might be a direct object + $bbi->{'Info.page1obj'}=$Htex::PDFread::pdf_last_ref0; + } else { + # die $page1obj; + $pages=pdf_ref($F, $xref, $page1obj, 0); + goto IOerr if !defined $pages; + $type=pdf_get($F,$xref,$pages,'/Type'); + goto IOerr if !defined $type; + goto SYerr if $type ne ' /Page'; + my $mediabox=pdf_get($F,$xref,$pages,'/MediaBox'); + goto IOerr if !defined $mediabox; + goto do_pdf_slow if !length $mediabox; + } + pdf_get_boxes($F, $xref, $pages, $bbi); + } elsif (substr($head,0,4) eq "%!PS") { + # Dat: the user should not trust Val.languagelevel blindly. There are far + # too many PS files hanging around that do not conform to any standard. + $bbi->{FileFormat}=$bbi->{SubFormat}= + ($head=~/\A[^\n\r]*?\bEPSF-/) ? "EPS" : "PS"; + goto SYerr if $head!~s@[^\n\r]*[\n\r]+@@; + # vvv Dat `+' is `or' with full boolean eval + until ($head=~s@[\n\r]%%EndComments.*@@s + $head=~s@[\n\r](?:[^%]|%[^%]).*@@s) { + goto IOerr if 0>read $F, $head, 1024, length($head); + } + my $headlen=length($head); + $head=~s@(?:\r\n|\n\r|[\n\r])@\n@g; # uniformize newlines + $head=~s@\s*\n%%[+]\s*@ @g; # unify line continuations + my %H; + my $had_hires=0; # HiresBoundingBox overrides normal + my $val; + while ($head=~/^%%([A-Za-z]+):?\s*((?:.*\S)?)/gm) { + next if $2 ne '(atend)'; + # read additional ADSC comments from the last 1024 bytes of the file + goto IOerr if !seek $F, -1024, 2 and !seek $F, 0, 0; # Dat: seek to EOF + $dummy=tell $F; + goto IOerr if $dummy<$headlen and $headlen-$dummy!=read $F, $val, $headlen-$dummy; + goto IOerr if 0>read $F, $val, 1024; + $val=~s@(?:\r\n|\n\r|[\n\r])@\n@g; # uniformize newlines + $val=~s@\s*\n%%[+]\s*@ @g; # unify line continuations + $val=~s@^(?:[^%]|%[^%]).*\n?@@mg; # remove non-DSC lines + # vvv Dat: appending is schemantically correct here + $head.="\n$val"; last + } + while ($head=~/^%%([A-Za-z]+):?[ \t]*((?:.*\S)?)/gm) { # iterate over Adobe DSC comments + $dummy=lc($1); $val=$2; + next if $dummy eq 'enddata' or $dummy eq 'trailer' or $dummy eq 'eof'; + $bbi->{"Val.$dummy"}=$2; + if ($dummy eq 'documentdata') { + $dummy=lc($2); + $bbi->{'Info.binary'}='Clean7Bit' if $dummy eq 'clean7bit'; + $bbi->{'Info.binary'}='Clean8Bit' if $dummy eq 'clean8bit'; + $bbi->{'Info.binary'}='Binary' if $dummy eq 'binary'; + } elsif ($dummy eq 'creator' and $val=~/\bMetaPost\b/) { + $bbi->{FileFormat}='EPS'; + $bbi->{SubFormat}='MPS'; # useful for graphicP.sty + } elsif ($dummy eq 'boundingbox' and $val=~/\A([+-]?\d+)\s+([+-]?\d+)\s+([+-]?\d+)\s+([+-]?\d+)\Z(?!\n)/) { + ($bbi->{LLX},$bbi->{LLY},$bbi->{URX},$bbi->{URY})=($1+0,$2+0,$3+0,$4+0) if !$had_hires; + } elsif (($dummy eq 'hiresboundingbox' or $dummy eq 'exactboundingbox') + and $val=~/\A([+-]?[0-9eE.-]+)\s+([+-]?[0-9eE.-]+)\s+([+-]?[0-9eE.-]+)\s+([+-]?[0-9eE.-]+)\Z(?!\n)/ + and defined c_numval($1) and defined c_numval($2) and defined c_numval($3) and defined c_numval($4) + ) { + # Dat: capitalized names are: HiResBoundingBox, ExactBoundingBox + no integer; + ($bbi->{LLX},$bbi->{LLY},$bbi->{URX},$bbi->{URY})=($1+0,$2+0,$3+0,$4+0); + $had_hires=1; + } + } + } elsif ($head=~/\AFORM....ILBMBMHD/s) { + $bbi->{FileFormat}='LBM'; + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("A20nn",$head); + } elsif ($head=~/\AFORM....(RGB[8N])/s) { # /etc/magic + $bbi->{FileFormat}="IFF.$1"; + # dimension info not available + } elsif ($head=~/\ABM....\0\0\0\0....[\014-\177]\0\0\0/s) { # PC bitmaps (OS/2, Windoze BMP files) (Greg Roelofs, newt@uchicago.edu) + $bbi->{FileFormat}='BMP'; + if (vec($head,14,8)==12) { + $bbi->{SubFormat}='OS/2 1.x'; + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("A18vv",$head); + } elsif (vec($head,14,8)==64) { + $bbi->{SubFormat}='OS/2 2.x'; + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("A18vv",$head); + } elsif (vec($head,14,8)==40) { + $bbi->{SubFormat}='Windows'; + ($dummy,$bbi->{URX},$bbi->{URY},$dummy,$bbi->{"Info.depth"})=unpack("A18VVvv",$head); + } else { goto SYerrr } + #0 string BM PC bitmap data + #>14 leshort 12 \b, OS/2 1.x format + #>>18 leshort x \b, %d x + #>>20 leshort x %d + #>14 leshort 64 \b, OS/2 2.x format + #>>18 leshort x \b, %d x + #>>20 leshort x %d + #>14 leshort 40 \b, Windows 3.x format + #>>18 lelong x \b, %d x + #>>22 lelong x %d x + #>>28 leshort x %d + } elsif (substr($head,0,10) eq "\367\002\001\203\222\300\34;\0\0") { FF__DVI: + $bbi->{FileFormat}='DVI'; + # read 1st page of the DVI file, look for TeX \special{papersize=21cm,29.7cm}, + # as understood by dvips and xdvi + ($dummy,$bbi->{'Info.version_id'},$bbi->{'Info.numerator'}, + $bbi->{'Info.denominator'},$bbi->{'Info.magnification'})=unpack('CCNNN',$head); + goto IOerr if !seek $F, 15-length($head), 1; + $dummy=vec($head,14,8); + goto IOerr if $dummy!=read $F, $bbi->{'Info.jobname'}, $dummy; + my($tag,$action); + my @actions=(0)x256; # skip that char + $actions[139]=15; # Bop + @actions[248,249,140,223]=(16,16,16,16); # stop parsing file + @actions[128,133,143,148,153,157,162,167,235]=(1,1,1,1,1,1,1,1,1); # read 1 extra bytes + @actions[129,134,144,149,154,158,163,168,236]=(2,2,2,2,2,2,2,2,2); # read 2 extra bytes + @actions[130,135,145,150,155,159,164,169,237]=(3,3,3,3,3,3,3,3,3); # read 2 extra bytes + @actions[131,136,146,151,156,160,165,170,238]=(4,4,4,4,4,4,4,4,4); # read 2 extra bytes + @actions[132,137]=(8,8); # read 8 extra bytes + @actions[243,244,245,246]=(17,18,19,20); # Fnt_def + @actions[239,240,241,242]=(33,34,35,26); # Special (XXX) + while (1) { + goto IOerr if !defined($tag=getc($F)); # Dat: EOF is error + $tag=$actions[ord($tag)]; + if ($tag==0) { + } elsif ($tag==16) { + last + } elsif ($tag==15) { # Bop + last if exists $bbi->{'Info.page1_nr'}; + goto IOerr if 44!=read $F, $dummy, 44; + $bbi->{'Info.page1_nr'}=unpack "N", $dummy; + } else { + # read number of ($tag&15) bytes in MSBfirst byte order + $dummy="\0\0\0\0"; + goto IOerr if ($tag&15)!=read $F, $dummy, ($tag&15), 4; + $dummy=unpack("N",substr($dummy,-4)); + if ($tag>=33) { # Special + goto IOerr if $dummy!=read $F, $tag, $dummy; + @L=split /\s*=\s*/, $tag, 2; + if ($#L) { + $bbi->{"Val.$L[0]"}=$L[1]; + if ($L[0] eq 'papersize') { + @L=split /,/, $L[1], 2; + $bbi->{URX}=Htex::dimen::dimen2bp($L[0]); + $bbi->{URY}=Htex::dimen::dimen2bp($L[1]); + if (!defined $bbi->{URX} or !defined $bbi->{URY}) { + delete $bbi->{URX}; delete $bbi->{URY}; + } + } + } else { $bbi->{'Info.special'}=$tag; } + } elsif ($tag>=17) { # Fnt_def + goto IOerr if 14!=read $F, $tag, 14; + $dummy=vec($tag,12,8)+vec($tag,13,8); + goto IOerr if $dummy!=read $F, $tag, $dummy; + } + } # IF + } # WHILE + } elsif ($head=~/\Aid=ImageMagick\r?\n/) { + $bbi->{FileFormat}='MIFF'; + # goto IOerr if 0>read $F, $head, 128-length($head), length($head); + goto SYerr if $head!~/\bcolumns=(\d+)\s+rows=(\d+)/; + $bbi->{URX}=0+$1; $bbi->{URY}=0+$2; + } elsif (substr($head,0,3) eq 'FWS') { + $bbi->{FileFormat}='SWF'; # Macromedia ShockWave Flash + my $nbits=get_bits_msb($head, 64, 5); + no integer; + $bbi->{URX}=get_bits_msb($head, 69+ $nbits, $nbits)/20.0; + $bbi->{LLX}=get_bits_msb($head, 69, $nbits)/20.0; + $bbi->{URY}=get_bits_msb($head, 69+3*$nbits, $nbits)/20.0; + $bbi->{LLY}=get_bits_msb($head, 69+2*$nbits, $nbits)/20.0; + } elsif (substr($head,0,14) eq "gimp xcf file\0") { # GIMP XCF image data + $bbi->{SubFormat}='version.000'; + do_XCF: + $bbi->{FileFormat}='XCF'; + ($dummy,$bbi->{URX},$bbi->{URY},$dummy)=unpack("A14NNN", $head); + if ($dummy==0) { $bbi->{ColorSpace}='RGB' } + elsif ($dummy==1) { $bbi->{ColorSpace}='Gray' } + elsif ($dummy==2) { $bbi->{ColorSpace}='Indexed' } + } elsif ($head=~/\Agimp xcf v(\d\d\d)\0/) { + $bbi->{SubFormat}="version.$1"; + goto do_XCF; + } elsif ($head=~/\A\0\0\001\0[\001-\50]\0/) { # Windows ICO icon + $bbi->{FileFormat}='ICO'; + # An .ico file may contain multiple icons (hence [\001-50]); we report the + # properties of the very first one. Code based on ImageMagick. + # Imp: WinXP True color icons + ($dummy,$bbi->{URX},$bbi->{URY},$bbi->{'Info.colors'},$bbi->{'Info.reserved'}, + $bbi->{'Info.planes'},$bbi->{BitsPerSample})=unpack("A6CCCCvv", $head); + # more precisely: BitsPerSample is bits per pixel; + # Dat: Info.reserved, BitsPerSample and Info.planes are often 0 + } elsif (substr($head,0,4)eq"8BPS") { # PSD image data (Adobe Photoshop bitmap) + # based on PHP 4.2 image.c; untested + $bbi->{FileFormat}='PSD'; + ($dummy,$bbi->{URY},$bbi->{URX})=unpack("A14NN",$head); + } elsif (substr($head,0,8) eq "\%bitmap\0") { # Fuzzy Bitmap (FBM) image; untested + $bbi->{FileFormat}='FBM'; + @L=unpack("A8A8A8A8A8A8A12A12A12A12A80A80",$head); # <=256 chars OK + for (@L) { s@\0.*@@s } # make strings null-terminated + $bbi->{"Info.credits"}=pop(@L); # string + $bbi->{"Info.title"}=pop(@L); # string + goto SYerr if !defined ($bbi->{aspect}=c_numval(pop(@L))); + shift(@L); # magic + for my $item (@L) { goto SYerr if !defined($item=c_intval($item)) } + ( $bbi->{URX},$bbi->{URY},$bbi->{"Info.planes"},$bbi->{"Info.bits"}, + $bbi->{"Info.physbits"},$bbi->{"Info.rowlen"},$bbi->{"Info.plnlen"}, + $bbi->{"Info.clrlen"})=@L; + # char cols[8]; /* Width in pixels */ + # char rows[8]; /* Height in pixels */ + # char planes[8]; /* Depth (1 for B+W, 3 for RGB) */ + # char bits[8]; /* Bits per pixel */ + # char physbits[8]; /* Bits to store each pixel */ + # char rowlen[12]; /* Length of a row in bytes */ + # char plnlen[12]; /* Length of a plane in bytes */ + # char clrlen[12]; /* Length of colormap in bytes */ + # char aspect[12]; /* ratio of Y to X of one pixel */ + } elsif (substr($head,0,4)eq"\x59\xa6\x6a\x95") { # Sun raster images; untested + $bbi->{FileFormat}='SunRaster'; + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("NNN",$head); + #0 belong 0x59a66a95 Sun raster image data + #>4 belong >0 \b, %d x + #>8 belong >0 %d, + #>12 belong >0 %d-bit, + ##>16 belong >0 %d bytes long, + #>20 belong 0 old format, + ##>20 belong 1 standard, + #>20 belong 2 compressed, + #>20 belong 3 RGB, + #>20 belong 4 TIFF, + #>20 belong 5 IFF, + #>20 belong 0xffff reserved for testing, + #>24 belong 0 no colormap + #>24 belong 1 RGB colormap + #>24 belong 2 raw colormap + #>28 belong >0 colormap is %d bytes long + } elsif (substr($head,0,4)eq"\xf1\x00\40\xbb") { + $bbi->{FileFormat}='CMUWM'; # from xloadimage; untested + ($dummy,$bbi->{URX},$bbi->{URY},$bbi->{"Info.depth"})=unpack("NNNn",$head); + } elsif (substr($head,0,4) eq "\361\0\100\273") { # CMU window manager raster image data + # from xvl untested + $bbi->{FileFormat}='CMUWM'; + ($dummy,$bbi->{URX},$bbi->{URY},$bbi->{'Info.num_bits'})=unpack("VVVV",$head); + } elsif (substr($head,0,2)eq"\x52\xCC") { # Utah Raster Toolkit RLE images; untested + $bbi->{FileFormat}='RLE'; # from xloadimage + ($dummy,$bbi->{URX},$bbi->{URY},$bbi->{LLX},$bbi->{LLY})=unpack("A6vvvv",$head); + $bbi->{BitsPerSample}=vec($head,12,8)/vec($head,11,8); + $bbi->{SamplesPerPixel}=vec($head,11,8); + #0 leshort 0xcc52 RLE image data, + #>6 leshort x %d x + #>8 leshort x %d + #>2 leshort >0 \b, lower left corner: %d + #>4 leshort >0 \b, lower right corner: %d + #>10 byte&0x1 =0x1 \b, clear first + #>10 byte&0x2 =0x2 \b, no background + #>10 byte&0x4 =0x4 \b, alpha channel + #>10 byte&0x8 =0x8 \b, comment + #>11 byte >0 \b, %d color channels + #>12 byte >0 \b, %d bits per pixel + #>13 byte >0 \b, %d color map channels + } elsif (substr($head,0,32)eq"\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377\377") { # Kodak Photograph on CD Image + # derived from xloadimage; untested + $dummy=3587-length($head); + goto IOerr if $dummy=read $F, $head, $dummy, length($head); + goto SYerr if substr($head,2048,7) ne "PCD_IPI"; + $bbi->{FileFormat}='PCD'; + # vvv funny: an image format with fixed (hard-wired) image size + if ((vec($head,3586,8)&1)!=0) { ($bbi->{URY},$bbi->{URX})=(768,512) } + else { ($bbi->{UXY},$bbi->{URY})=(768,512) } + } elsif ($head=~/\A\0\0..\0\0\0[\001-\50]\0\0\0[\0-\002]\0\0\0([\001-\77])/s) { + $bbi->{FileFormat}='XWD'; + $bbi->{SubFormat}='MSBfirst'; + $bbi->{'Info.depth'}=ord($1); + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("A16NN",$head); + } elsif ($head=~/\A..\0\0[\001-\50]\0\0\0[\0-\002]\0\0\0([\001-\77])\0\0\0/s) { + $bbi->{FileFormat}='XWD'; + $bbi->{SubFormat}='LSBfirst'; + $bbi->{'Info.depth'}=ord($1); + ($dummy,$bbi->{URX},$bbi->{URY})=unpack("A16VV",$head); + } elsif ($head=~/\A\0\001\0[\010-\377](?:\0.|\001\0)\0.....(?:[\001-\37].|\0[^\0]|\40\0){2}/s) { # GEM Bit image + # from xloadimage; untested + $bbi->{FileFormat}='GEM'; + ($dummy,$bbi->{'Info.hlen'},$bbi->{'Info.colors'},$bbi->{'Info.patlen'}, + $bbi->{URX},$bbi->{URY},$bbi->{'Info.llen'},$bbi->{'Info.lines'})=unpack("nnnnnnnn",$head); + } elsif ($head=~/\A....\0\0\0\004....\0\0[\0-\001].\0\0[\0-\003]./s) { # McIDAS areafile + # from xloadimage; untested + $bbi->{FileFormat}='McIDAS'; + $bbi->{SubFormat}='MSBfirst'; + ($dummy,$bbi->{URY},$bbi->{URX})=unpack("A32NN",$head); + } elsif ($head=~/\A....\004\0\0\0.....[\0-\001]\0\0.[\0-\003]\0\0/s) { # McIDAS areafile + # from xloadimage; untested + $bbi->{FileFormat}='McIDAS'; + $bbi->{SubFormat}='LSBfirst'; + ($dummy,$bbi->{URY},$bbi->{URX})=unpack("A32VV",$head); + } elsif ($head=~/\AVIEW/) { + # from xv; untested + $dummy="NNNNNN"; $bbi->{SubFormat}='MSBfirst'; + do_PM: + $bbi->{FileFormat}='PM'; + ($dummy,$bbi->{'Info.num_planes'},$bbi->{URX},$bbi->{URY}, + $bbi->{'Info.num_bands'}, $bbi->{'Info.pixel_format'})=unpack($dummy,$head); + } elsif ($head=~/\AWEIV/) { + $dummy="VVVVVV"; $bbi->{SubFormat}='LSBfirst'; + goto do_PM; + } elsif ($head=~/\A\001\332/) { # SGI 'rgb' image data + $bbi->{SubFormat}='MSBfirst'; $dummy="nCCnnnn"; + do_SGI: + $bbi->{FileFormat}='SGI'; # from xv IRIS; untested + ($dummy,$bbi->{'Info.compression'},$bbi->{'Info.precision'},$bbi->{'Info.dimension'}, + $bbi->{URX},$bbi->{URY},$bbi->{SamplesPerPixel})=unpack($dummy,$head); + if ($bbi->{'Info.compression'}==0) { $bbi->{'Info.compression'}='None' } + elsif ($bbi->{'Info.compression'}==1) { $bbi->{'Info.compression'}='RLE' } + $dummy=substr($head,80); + $bbi->{'Info.comment'}=$1 if $dummy=~m@\A([^\0])\0@s; + # Dat: Info.dimension is 2 or 3 + ## See http://reality.sgi.com/grafica/sgiimage.html + } elsif ($head=~/\A\332\001/) { # SGI 'rgb' image data + $bbi->{SubFormat}='MSBfirst'; $dummy="vCCvvvvv"; + goto do_SGI; + } elsif (substr($head,0,9) eq "SIMPLE =") { + $bbi->{FileFormat}='FITS'; + while ($head!~/\bEND/) { + goto IOerr if 1>read $F, $head, 1024, length($head); + } + $bbi->{'Info.bits_per_pixel'}=$1 if $head=~/\bBITPIX\s*=\s*(\d+)/; + $bbi->{'Info.num_axis'}=$1 if $head=~/\bNAXIS\s*=\s*(\d+)/; + $bbi->{URX}=$1 if $head=~/\bNAXIS1\s*=\s*(\d+)/; + $bbi->{URY}=$1 if $head=~/\bNAXIS2\s*=\s*(\d+)/; + $bbi->{'Info.depth'}=$1 if $head=~/\bNAXIS3\s*=\s*(\d+)/; + $bbi->{'Info.data_max'}=$1 if $head=~/\bDATAMAX\s*=\s*(\d+)/; + $bbi->{'Info.data_min'}=$1 if $head=~/\bDATAMIN\s*=\s*(\d+)/; + # Dat: it would be quite hard to extract the dimensions... + ## FITS is the Flexible Image Transport System, the de facto standard for + ## data and image transfer, storage, etc., for the astronomical community. + ## (FITS floating point formats are big-endian.) + #0 string SIMPLE\ \ = FITS image data + #>109 string 8 \b, 8-bit, character or unsigned binary integer + #>108 string 16 \b, 16-bit, two's complement binary integer + #>107 string \ 32 \b, 32-bit, two's complement binary integer + #>107 string -32 \b, 32-bit, floating point, single precision + #>107 string -64 \b, 64-bit, floating point, double precision + } elsif ($head=~/\A(?:NJPL1I|CCSD3Z|LBLSIZE=)/) { + # from xv, imagemagick; untested + $bbi->{FileFormat}='VICAR'; + while ($head!~/\bEND/) { + goto IOerr if 1>read $F, $head, 1024, length($head); + } + $bbi->{URX}=$1 if $head=~/\b(?:IMAGE_LINES|LINES|NL)\s*=\s*(\d+)/; + $bbi->{URY}=$1 if $head=~/\b(?:LINE_SAMPLES|NS)\s*=\s*(\d+)/; + ##------------------------------------------------------------------------------ + ## vicar: file(1) magic for VICAR files. + ## + ## From: Ossama Othman <othman@astrosun.tn.cornell.edu + ## VICAR is JPL's in-house spacecraft image processing program + ## VICAR image + #0 string LBLSIZE= VICAR image data + #>32 string BYTE \b, 8 bits = VAX byte + #>32 string HALF \b, 16 bits = VAX word = Fortran INTEGER*2 + #>32 string FULL \b, 32 bits = VAX longword = Fortran INTEGER*4 + #>32 string REAL \b, 32 bits = VAX longword = Fortran REAL*4 + #>32 string DOUB \b, 64 bits = VAX quadword = Fortran REAL*8 + #>32 string COMPLEX \b, 64 bits = VAX quadword = Fortran COMPLEX*8 + ## VICAR label file + #43 string SFDU_LABEL VICAR label file + } elsif (substr($head,0,4) eq "IT01" or substr($head,0,4) eq "IT02") { # untested + $bbi->{FileFormat}='FIT'; # do not cunfuse FIT and FITS + ($dummy,$bbi->{URX},$bbi->{URY},$bbi->{'Info.num_bits'})=unpack("NNNN",$head); + } elsif (substr($head,0,4) eq "#FIG") { + $bbi->{FileFormat}='FIG'; + $bbi->{SubFormat}=$1 if $head=~/\A....[ \t]+(\S+)/s; + ## FIG (Facility for Interactive Generation of figures), an object-based format + ## (as handled by xfig). There is no size information, fig2dev saves bounding + ## box as EPS + #0 string #FIG FIG image text + #>5 string x \b, version %.3s + +## These file formats below are known to the Debian potato file(1) command, +## but the magic(5) file doesn't tell us how to extract size information +## +## NITF is defined by United States MIL-STD-2500A +#0 string NITF National Imagery Transmission Format +#>25 string >\0 dated %.14s +# +## NIFF (Navy Interchange File Format, a modification of TIFF) images +#0 string IIN1 NIFF image data +## ITC (CMU WM) raster files. It is essentially a byte-reversed Sun raster, +## 1 plane, no encoding. +## Artisan +#0 long 1123028772 Artisan image data +#>4 long 1 \b, rectangular 24-bit +#>4 long 2 \b, rectangular 8-bit with colormap +#>4 long 3 \b, rectangular 32-bit (24-bit with matte) +# +# +## PHIGS +#0 string ARF_BEGARF PHIGS clear text archive +#0 string @(#)SunPHIGS SunPHIGS +## version number follows, in the form m.n +##>40 string SunBin binary +##>32 string archive archive +## +## GKS (Graphics Kernel System) +#0 string GKSM GKS Metafile +#>24 string SunGKS \b, SunGKS +# +## CGM image files +#0 string BEGMF clear text Computer Graphics Metafile +## XXX - questionable magic +#0 beshort&0xffe0 0x0020 binary Computer Graphics Metafile +#0 beshort 0x3020 character Computer Graphics Metafile +# +## MGR bitmaps (Michael Haardt, u31b3hs@pool.informatik.rwth-aachen.de) +#0 string yz MGR bitmap, modern format, 8-bit aligned +#0 string zz MGR bitmap, old format, 1-bit deep, 16-bit aligned +#0 string xz MGR bitmap, old format, 1-bit deep, 32-bit aligned +#0 string yx MGR bitmap, modern format, squeezed +# +## image file format (Robert Potter, potter@cs.rochester.edu) +#0 string Imagefile\ version- iff image data +## this adds the whole header (inc. version number), informative but longish +#>10 string >\0 %s +# +## other images +#0 string This\ is\ a\ BitMap\ file Lisp Machine bit-array-file +#0 string \!\! Bennet Yee's "face" format +# +## From SunOS 5.5.1 "/etc/magic" - appeared right before Sun raster image +## stuff. +## +#0 beshort 0x1010 PEX Binary Archive +# +## Visio drawings +#03000 string Visio\ (TM)\ Drawing %s +# +#0 string IC PC icon data +#0 string PI PC pointer image data +#0 string CI PC color icon data +#0 string CP PC color pointer image data + + } elsif (substr($head,0,2) eq "\37\x9d") { + # .Z compress(1)ed file; may be an image (i.e pbm.Z) + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='compress'; + } elsif (substr($head,0,2) eq "\37\x8b") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='gzip'; + } elsif (substr($head,0,2) eq "\37\x36") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='pack'; + } elsif ($head=~/\A(?:\377\037|\037\377)/) { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='compact'; + } elsif (substr($head,0,3) eq "BZh") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='bzip2'; + } elsif (substr($head,0,2) eq "BZ") { # check must be after bzip + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='bzip1'; + } elsif (substr($head,0,2) eq "\x76\xff") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='squeeze'; + } elsif (substr($head,0,2) eq "\x76\xfe") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='crunch'; + } elsif (substr($head,0,2) eq "\x76\xfd") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='LZH'; + } elsif (substr($head,0,2) eq "\037\237") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='freeze2'; + } elsif (substr($head,0,2) eq "\037\236") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='freeze1'; + } elsif (substr($head,0,2) eq "\037\240") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='SCO.LZH'; + } elsif (substr($head,0,9) eq "\x89\x4c\x5a\x4f\x00\x0d\x0a\x1a\x0a") { + $bbi->{FileFormat}='compress'; $bbi->{SubFormat}='lzop'; + + } elsif (substr($head,0,2) eq "\x60\xEA") { + $bbi->{FileFormat}='archive'; $bbi->{SubFormat}='ARJ'; + } elsif ($head=~/\A..-l[hz]/s) { + $bbi->{FileFormat}='archive'; $bbi->{SubFormat}='LHA'; + } elsif (substr($head,0,4) eq "Rar!") { + $bbi->{FileFormat}='archive'; $bbi->{SubFormat}='RAR'; + } elsif (substr($head,0,4) eq "UC2\x1A") { + $bbi->{FileFormat}='archive'; $bbi->{SubFormat}='UC2'; + } elsif (substr($head,0,4) eq "PK\003\004") { + $bbi->{FileFormat}='archive'; $bbi->{SubFormat}='ZIP'; + } elsif (substr($head,0,4) eq "\xDC\xA7\xC4\xFD") { + $bbi->{FileFormat}='archive'; $bbi->{SubFormat}='ZOO'; + + } elsif ($head=~/\A.PC Research, Inc/s) { + $bbi->{FileFormat}='G3'; + $bbi->{SubFormat}='Digifax'; + # Dat: determining $bbi->{URX} and $bbi->{URY} would require a complex + # and full parsing of the G3 facsimile data + } elsif ($head=~/\A\367[\002-\005]/) { + # Dat: \005 is rather arbitrary here + goto FF__DVI; + } elsif ($head=~/\A[\36-\77](?:\001[\001\11]|\0[\002\12\003\13])\0\0/ and + vec($head, 1, 8)<=11 and (vec($head, 16, 8)<=8 or vec($head, 16, 8)==24)) { # potato magic + my @types=(0,'Map','RGB','Gray',0,0,0,0,0,'Map.RLE','RGB.RLE','Gray.RLE'); + $bbi->{FileFormat}='TGA'; + $bbi->{SubFormat}=$types[vec($head,2,8)]; + ($dummy,$bbi->{LLX},$bbi->{LLY},$bbi->{URX},$bbi->{URY})=unpack("A8vvvv",$head); + # Imp: verify LLX!=0 URX-LLX + } elsif (30<=vec($head, 0, 8) and vec($head, 0, 8)<=63 and + vec($head, 1, 8)<=11 and (vec($head, 16, 8)<=8 or vec($head, 16, 8)==24)) { + # ^^^ Dat: TGA doesn't have a fixed-format header, so this detection is quite + # weak. That's why it is the last one we perform. + $bbi->{FileFormat}='TGA'; + $bbi->{SubFormat}='fallback'; + ($dummy,$bbi->{LLX},$bbi->{LLY},$bbi->{URX},$bbi->{URY})=unpack("A8vvvv",$head); + # Imp: verify LLX!=0 URX-LLX + } elsif ($head=~/^PicData:\s*(\d+)\s*(\d+)\s*(\d+)/m) { # grayscale Faces Project imagegrayscale Faces Project image; untested + # ^^^ Dat: regexp match is quite weak; perform check last + $bbi->{FileFormat}='Faces'; # from xloadimage + $bbi->{URX}=$1+0; $bbi->{URY}=$2+0; $bbi->{"Info.bitdepth"}=$3+0; + } elsif ($head=~/\A\001\0/s) { # really weak + $bbi->{FileFormat}='G3'; + $bbi->{SubFormat}='MSBfirst.bytepad'; + } elsif ($head=~/\A\0\001/s) { # really weak + $bbi->{FileFormat}='G3'; + $bbi->{SubFormat}='LSBfirst.bytepad'; + } elsif ($head=~/\A\24\0/s) { # really weak + $bbi->{FileFormat}='G3'; + $bbi->{SubFormat}='MSBfirst.raw'; + } elsif ($head=~/\A\0\24/s) { # really weak + $bbi->{FileFormat}='G3'; + $bbi->{SubFormat}='LSBfirst.raw'; + # Dat: determining $bbi->{URX} and $bbi->{URY} would require a complex + # and full parsing of the G3 facsimile data + } else { + $bbi->{Error}='unrecognised FileFormat' + } + done: + if ($have_paper and exists $bbi->{URX} and exists $bbi->{URY}) { + ($bbi->{Paper},$bbi->{PaperWidth},$bbi->{PaperHeight})=@L[0,1,2] if + @L=Htex::papers::valid_bp($bbi->{URX},$bbi->{URY},$bbi->{LLX},$bbi->{LLY}); + } else { + delete $bbi->{LLX} if !exists $bbi->{URX}; + delete $bbi->{LLY} if !exists $bbi->{URY}; + } + $bbi +} + +sub import { + no strict 'refs'; + my $package=(caller())[0]; + shift; + ($have_paper,$have_pdf)=(1,1); + for my $p (@_) { + if ($p eq '-PDF') { $have_pdf=0 } + elsif ($p eq '-paper') { $have_paper=0 } + else { *{$package."::$p"}=\&{$p} } + } + if ($have_pdf) { require Htex::PDFread; import Htex::PDFread } + if ($have_paper) { require Htex::papers; import Htex::papers } +} + +just::end} + +BEGIN{$ INC{'vars.pm'}='vars.pm'} { +package vars; +use just; +# by pts@fazekas.hu at Wed Jan 10 12:42:08 CET 2001 +require 5.002; +sub import { + my $callpack = caller; + my ($sym, $ch, $sym9); + shift; + for $sym0 (@_) { + die("Can't declare another package's variables") if $sym0 =~ /::/; + ($ch, $sym) = unpack('a1a*', $sym0); + *{"${callpack}::$sym"} = + ( $ch eq "\$" ? \$ {"${callpack}::$sym"} + : $ch eq "\@" ? \@ {"${callpack}::$sym"} + : $ch eq "\%" ? \% {"${callpack}::$sym"} + : $ch eq "\*" ? \* {"${callpack}::$sym"} + : $ch eq "\&" ? \& {"${callpack}::$sym"} + : die("'$ch$sym' is not a valid variable name\n") + ); + } +} +just::end} + +BEGIN{$ INC{'Htex/PDFread.pm'}='Htex/PDFread.pm'} { +package Htex::PDFread; +# by pts@fazekas.hu at Sat Dec 21 21:28:09 CET 2002 +use just; +use integer; +use strict; +use Pts::string; +use vars qw($pdf_last_ref0); + +my @pdf_classify; +#** @param $_[0] a string in PDF source format +#** @return a rewritten string, or "" if $_[0] is truncated, or undef if +#** there is a parse error +sub pdf_rewrite($;$) { + my $explicit_term_p=$_[1]; + my $L=length($_[0]); + return "" if $L==0; + my $S="$_[0]\n>> "; # add sentinel + my $I=0; + my $O; + my $RET=""; + if (!@pdf_classify) { + # Dat: PDF whitespace(0) is [\000\011\012\014\015\040] + # Dat: PDF separators(10) are < > { } [ ] ( ) / % + # Dat: PDF regular(40) character is any of [\000-\377] which is not whitespace or separator + @pdf_classify=(40)x256; + @pdf_classify[ord('<'),ord('>'),ord('{'),ord('}'),ord('['),ord(']'), + ord('('),ord(')'),ord('/'),ord('%')]=(10,11,12,13,14,15,16,17,18,19); + @pdf_classify[000,011,012,014,015,040]=(0,0,0,0,0,0); + } + while ($I<$L) { + $O=$pdf_classify[vec($S,$I,8)]; + if ($O==0) { # whitespace + } elsif (12<=$O and $O<=15) { # one-char token + $RET.=" ".substr($S,$I,1); + } elsif ($O==18 or $O==40) { # name or /name + my $P=0; + if ($O==18) { $I++; $RET.=" /" } else { $RET.=" "; $P=1 } + my $T=""; + $T.=chr($O) while $pdf_classify[$O=vec($S,$I++,8)]==40; + $I--; + ## die $I; + $T=~s@([^A-Za-z0-9_.-])@sprintf"#%02x",ord$1@ge; # make name safe + $RET.=$T; + return $RET if $P and ($T eq "stream" or $T eq "endobj" or $T eq "startxref"); + next + } elsif ($O==11) { # `>' + return "" if ++$I==$L; # only `>' has arrived + return undef if vec($S,$I,8)!=62; # err(">> expected"); + $RET.=" >>"; + } elsif ($O==16) { # string + my $T=""; + my $depth=1; $I++; + while ($I<$L) { + $O=vec($S,$I++,8); bcont: + ## print chr($O),":$depth\n"; + if ($O==40) { $depth++ } + elsif ($O==41) { last unless --$depth } + elsif ($O==92) { # a backslash + $O=vec($S,$I++,8); + if (48<=$O && $O<=55) { + my $P=$O-48; $O=vec($S,$I++,8); + if (48<=$O && $O<=55) { + my $Q=$O-48; $O=vec($S,$I++,8); + if (48<=$O && $O<=55) { $T.=chr(255&($P<<6|$Q<<3|($O-48))) } + else { $T.=chr($P<<3|$Q); goto bcont } + } else { $T.=chr($P); goto bcont } + } elsif ($O==110) { $O=10 } + elsif ($O==114) { $O=13 } + elsif ($O==116) { $O=9 } + elsif ($O== 98) { $O=8 } + elsif ($O==102) { $O=12 } + } + $T.=chr($O) + } # WHILE + return "" if $depth; # err("unterminated string") + $T=~s@([^A-Za-z0-9_.-])@sprintf"\\%03o",ord$1@ge; # make string safe + $RET.=" ($T)"; next + } elsif ($O==10) { # hex string + $O=vec($S,++$I,8); + if ($O==60) { $RET.=" <<"; $I++; next } + # parse hexadecimal string + my $half=0x100; + my $T=""; + while (1) { + 1 until $pdf_classify[$O=vec($S,$I++,8)]; # skip whitespace + if ($O==62) { $T.=chr($half&0xFF) if $half&0x1000; last } # '>' + return undef if $pdf_classify[$O]!=40; # err("unexpected token in hex") + if (65<=$O and $O<=70) { $half+=$O-55 } + elsif (97<=$O and $O<=102) { $half+=$O-87 } + elsif (48<=$O and $O<=57) { $half+=$O-48 } + else { return undef } # err("illegal hex digit") + if ($half&0x1000) { $T.=chr($half&0xFF); $half=0x100 } + else { $half<<=4 } + } + $T=~s@([^A-Za-z0-9_.-])@sprintf"\\%03o",ord$1@ge; # make string safe + $RET.=" ($T)"; next + } elsif ($O==19) { # single-line comment + $I++ while ($O=vec($S,$I,8))!=13 && $O!=10; + ## print STDERR "I=$I L=$L\n"; + next + } else { return undef } # err("token expected") # $O==11, $O==17 + $I++ + } ## WHILE + ## print STDERR "XI=$I L=$L\n"; + # die $explicit_term_p; + return "" if $explicit_term_p; + ($I>$L) ? "" : $RET +} + +# Unit test: +#die unless pdf_rewrite("hello \n\t world\n\t") eq " hello world"; +#die unless pdf_rewrite('(hel\)lo\n\bw(or)ld)') eq ' (hel\051lo\012\010w\050or\051ld)'; +#die unless pdf_rewrite('(hel\)lo\n\bw(orld)') eq ''; +#die unless pdf_rewrite('[ (hel\)lo\n\bw(or)ld)>>') eq ' [ (hel\051lo\012\010w\050or\051ld) >>'; +#die unless pdf_rewrite('>') eq ""; +#die unless pdf_rewrite('<') eq ""; +#die unless pdf_rewrite('< ') eq ""; +#die unless !defined pdf_rewrite('< <'); +#die unless !defined pdf_rewrite('> >'); +#die unless pdf_rewrite('[ (hel\)lo\n\bw(or)ld) <') eq ""; +#die unless pdf_rewrite("<\n3\t1\r4f5C5 >]") eq ' (1O\134P) ]'; +#die unless pdf_rewrite("<\n3\t1\r4f5C5") eq ""; +#die unless !defined pdf_rewrite("<\n3\t1\r4f5C5]>"); +#die unless pdf_rewrite("% he te\n<\n3\t1\r4f5C5 >]endobj<<") eq ' (1O\134P) ] endobj'; +#die unless pdf_rewrite("") eq ""; +#die unless pdf_rewrite("<<") eq " <<"; +#die unless pdf_rewrite('%hello') eq ''; +#die unless pdf_rewrite("alma\n%korte\n42") eq ' alma 42'; +#die unless pdf_rewrite('/Size 42') eq ' /Size 42'; +#die "OK"; + +#** Reads a single PDF indirect object (without its stream) from a PDF file. +#** Does some trivial transformations on it to make later regexp matching +#** easier. Stops at `stream', `endobj' and `startxref'. +#** @param $_[0] a filehandle (e.g \*STDIN), correctly positioned in the PDF +#** file to the beginning of the object data (i.e just before `5 0 obj') +#** @return string containing PDF source code, or undef on error +sub pdf_read_obj($) { + my $F=$_[0]; my $L=1024; my $M; my $S=""; my $RET; + while (1) { # read as much data as necessary + return undef if 0>($M=read $F, $S, $L, length($S)); + $RET=pdf_rewrite($S,1); + ## print "($S)\n"; + return undef if !defined $RET; # parse error + return $RET if length $RET; # OK, found object + return undef if $M==0; # cannot read more, reached EOF + $L<<=1; + } + #$S=~m@[\000\011\012\014\015\040]*( + # %[^\r\n]*[\r\n]| + # /?[^\000\011\012\014\015\040<>{}\[\]()/%]*(?=[\000\011\012\014\015\040<>{}\[\]()/%])| # unterminated + # <<|>>|\{|}|\[|]| + # <[a-fA-F0-9\000\011\012\014\015\040]*>| # hex string + # \((?:[^\\()]+|\\[\000-\377])*\)| # literal string, the easy way + # \( # an unfinished string, needs special care + #)@gx +} + +#** @param $_[0] a filehandle (e.g \*STDIN), containing a PDF file, positioned +#** just before an `xref' table +#** @param $_[1] an xref table: $_[1][4][56] is the file offset of object 56 +#** from generation 4; will be extended +#** @return the `trailer' section after the `xref'; or undef +sub pdf_read_xref($$) { + # made much faster at Wed Dec 18 09:50:23 CET 2002 + my $T; + my $E; + my $F=$_[0]; + my $XREF=$_[1]; + return undef if 8>read $F, $T, 1024; + return undef unless $T=~s@\A\s*xref\s+(\d+)\s+(\d+)\s+(?=\S)@@; + my ($first,$len,$flen); + while (1) { + ($first,$len)=($1+0,$2+0); + ## print " $first + $len\n"; + $flen=($len*=20)-length($T)+20; + return undef unless $flen<1 or $flen==read $F, $T, $flen, length($T); + for (my $I=0;$I<$len;$I+=20, $first++) { + $E=substr($T, $I, 20); + return undef unless $E=~/\A(\d{10})\s(\d{5})\s([nf])\s\s/; + ## print "($1 $2 $3)\n"; + $XREF->[$2+0][$first]=$1+0 if $3 eq 'n'; + } + $E=substr($T, $len); + last if $E!~s@\A\s*(\d+)\s*(\d+)\s+(?=\S)@@; # next section + $T=$E; + } + + # die(-length($T)+$len); + ## die tell($F); + return undef if length($T)!=$len and !seek $F, -length($T)+$len, 1; + ## die tell($F); + return undef unless defined($T=pdf_read_obj($F)); + $XREF->[0][0]=undef if defined $XREF->[0]; + $XREF->[0][0]=$1+0 if $T=~m@ /Prev (\d+)@; # remember /Prev xref table + return undef unless $T=~m@\A trailer( .*) startxref\Z(?!\n)@s; + $1 +} + +$pdf_last_ref0=0; +#** @param $_[0] a filehandle (e.g \*STDIN), containing a PDF file +#** @param $_[1] an xref table: $_[1][4][56] is the file offset of object 56 +#** from generation 4 +#** @param $_[2] an object number +#** @param $_[3] a generation number +#** @return PDF source code of the reference, or undef +sub pdf_ref($$$$) { + my $F=$_[0]; my $XREF=$_[1]; my $ON=$_[2]+0; my $GN=$_[3]+0; + my $T; + $pdf_last_ref0=$ON if $GN==0; + ## print "REF $ON $GN;\n"; + until (ref $XREF->[$GN] and defined ($T=$XREF->[$GN][$ON])) { + return undef if !ref $XREF->[0] or !defined $XREF->[0][0]; # no /Prev entry, `$ON $GN R' not found + return undef unless seek $F, $XREF->[0][0], 0; + return undef if !defined pdf_read_xref($F,$XREF); + } + ## print "REF at $T;\n"; + return undef unless seek $F, $T, 0; + return undef unless defined($T=pdf_read_obj($F)); + ## print "REF=($T);\n"; + return undef unless $T=~s@\A (\d+) (\d+) obj\b(.*) (endobj|stream)\Z(?!\n)@$3@s; + $T +} + +#** Gets a key from a direct dict, and resolves it if it is an indirect object +#** @param $_[0] a filehandle (e.g \*STDIN), containing a PDF file +#** @param $_[1] an xref table: $_[1][4][56] is the file offset of object 56 +#** from generation 4 +#** @param $_[2] a PDF source dict (`<< ... >>') or array +#** @param $_[3] a key (`/...') +sub pdf_get($$$$) { + my $F=$_[0]; my $XREF=$_[1]; my $S=$_[2]; my $KEY=$_[3]; my $POS=0; + my $DEPTH=0; my $IS_DICT; my $C=0; my $N=0; + ## print "\n"; + while ($S=~/\G (\S+)/g) { + $C=vec($1,0,8); $POS=pos($S); + ## print "($1) $DEPTH $N\n"; + if ($1 eq '>>' or $1 eq ']') { + return undef if 0==$DEPTH--; + last if !$DEPTH; + $N++ if 1==$DEPTH; + } + elsif ($DEPTH==1 and !$IS_DICT and $KEY==$N) { $POS=pos($S)-=length($1)+1; goto do_ret } + elsif ($1 eq '<<') { $IS_DICT=1 if 0==$DEPTH++ } + elsif ($1 eq '[') { + if (0==$DEPTH++) { + $IS_DICT=0; + return undef if $KEY!~/\A(\d+)\Z(?!\n)/; # err("non-numeric key in array") + } + } + elsif (0==$DEPTH) { return undef } # not in a composite object + elsif (1!=$DEPTH) { next } + elsif (!$IS_DICT) { $N++ } + elsif ($C==40) { $N++ } # `(': string or bare name + elsif ($C>=47 and $C<=57) { # '/': /name 0..9: number + ## print "TRY ($1) KEY=$KEY.\n"; + next if ($N++&1)==1 or $1 ne $KEY; + do_ret: + ## print substr($S,pos($S)),";;\n"; + return pdf_ref $F, $XREF, $1, $2 if $S=~/\G (\d+) (\d+) R\b/gc; + ## print substr($S,pos($S)),"::\n"; + $DEPTH=0; + while ($S=~/\G( \S+)/g) { + if ($1 eq ' <<' or $1 eq ' [') { $DEPTH++ } + elsif ($1 eq ' >>' or $1 eq ' ]') { + ## die "($1)\n"; + return undef if 0==$DEPTH--; # err("nesting") + return substr($S,$POS,pos($S)-$POS) if 0==$DEPTH; + } elsif ($DEPTH==0) { return $1 } + } + } else { $N++ } # bare name + } + return undef if $POS!=length($S); # err("invalid source dict"); + "" # not found +} + +# Unit test: +#die unless pdf_get(\*STDIN, 0, ' [ al makorte 42 ]', 0) eq ' al'; +#die unless pdf_get(\*STDIN, 0, ' [ al makorte 42 ]', 1) eq ' makorte'; +#die unless pdf_get(\*STDIN, 0, ' [ al makorte 42 ]', 2) eq ' 42'; +#die unless pdf_get(\*STDIN, 0, ' [ al makorte 42 ]', 3) eq ''; +#die unless pdf_get(\*STDIN, 0, ' [ << >> ]', 0) eq ' << >>'; +#die unless pdf_get(\*STDIN, 0, ' [ << >> ]', 1) eq ''; +#die unless pdf_get(\*STDIN, 0, ' [ << >> [ al makorte 42 ] ]', 1) eq ' [ al makorte 42 ]'; +#die unless pdf_get(\*STDIN, 0, ' << /Alma [ 1 2 ] /Korte [ 3 4 ] >>', '/Korte') eq ' [ 3 4 ]'; +#die unless !defined pdf_get(\*STDIN, 0, ' [ al makorte 42 ]', '/Name'); +#die unless !defined pdf_get(\*STDIN, 0, ' << al makorte 42 >>', 42); +#die unless pdf_get(\*STDIN, 0, ' << al makorte 42 137 >>', 42) eq ' 137'; +#die unless pdf_get(\*STDIN, 0, ' << al makorte >>', 'al') eq ""; +#die "OK"; + +#** Reported boxes: /MediaBox /CropBox /BleedBox /TrimBox /ArtBox +#** @param $_[0] a filehandle (e.g \*STDIN), containing a PDF file +#** @param $_[1] an xref table: $_[1][4][56] is the file offset of object 56 +#** from generation 4 +#** @param $_[2] a PDF source dict (`<< ... >>') of /Type/Catalog +#** /Type/Pages or /Type/Page +#** @param $_[3] hashref to update. $_[3]{BleedBox}[2] will be the URX corner +#** of the BleedBox +sub pdf_get_boxes($$$$) { + my $F=$_[0]; my $XREF=$_[1]; my $S=$_[2]; my $bbi=$_[3]; + return if !defined $S; + for my $name (qw{MediaBox CropBox BleedBox TrimBox ArtBox}) { + my $box=pdf_get($F, $XREF, $S, "/$name"); + next if !defined $box or !length $box + or $box!~m@ \[ ([0-9eE.-]+) ([0-9eE.-]+) ([0-9eE.-]+) ([0-9eE.-]+) \]\Z(?!\n)@ + or !defined c_numval($1) or !defined c_numval($2) or !defined c_numval($3) or !defined c_numval($4); + ($bbi->{LLX},$bbi->{LLY},$bbi->{URX},$bbi->{URY})=($1+0,$2+0,$3+0,$4+0) if $name eq 'MediaBox'; + my $name2="Info.$name"; + ($bbi->{$name2}[0],$bbi->{$name2}[1],$bbi->{$name2}[2],$bbi->{$name2}[3])=($1+0,$2+0,$3+0,$4+0); + } +} + +sub import { + no strict 'refs'; + my $package=(caller())[0]; + shift; + for my $p (@_ ? @_ : qw{pdf_get_boxes pdf_get pdf_read_xref pdf_read_obj + pdf_rewrite pdf_ref}) { *{$package."::$p"}=\&{$p} } +} + +just::end} + +BEGIN{$ INC{'Htex/papers.pm'}='Htex/papers.pm'} { +package Htex::papers; +# contains paper size information +# by pts@fazekas.hu at Sun Dec 22 00:30:58 CET 2002 +use just; +use integer; +use strict; +use Htex::dimen; + +my @papers=( +# +# paper.txt +# by pts@fazekas.hu at Tue Jan 16 18:21:59 CET 2001 +# by pts@fazekas.hu at Tue Jan 16 19:13:16 CET 2001 +# +# Examined: dvips, gs, libpaperg +# +# all units are measured in Big Points (bp) +# 72 bp == 1 in +# 2.54 cm == 1 in +# +# papername width height +qw{Comm10 297 684}, +qw{Monarch 279 540}, +qw{halfexecutive 378 522}, + +qw{Legal 612 1008}, +qw{Statement 396 612}, +qw{Tabloid 792 1224}, +qw{Ledger 1224 792}, +qw{Folio 612 936}, +qw{Quarto 610 780}, +qw{7x9 504 648}, +qw{9x11 648 792}, +qw{9x12 648 864}, +qw{10x13 720 936}, +qw{10x14 720 1008}, +qw{Executive 540 720}, +qw{ISOB0 2835 4008}, +qw{ISOB1 2004 2835}, +qw{ISOB2 1417 2004}, +qw{ISOB3 1001 1417}, +qw{ISOB4 709 1001}, +qw{ISOB5 499 709}, +qw{ISOB6 354 499}, +qw{ISOB7 249 354}, +qw{ISOB8 176 249}, +qw{ISOB9 125 176}, +qw{ISOB10 88 125}, +qw{C7 230 323}, +qw{DL 312 624}, + +qw{a3 842 1190}, # defined by Adobe +qw{a4 595 842}, # defined by Adobe; must precede a4small + +# a4small should be a4 with an ImagingBBox of [25 25 570 817].}, +qw{a4small 595 842}, +qw{letter 612 792}, # must precede lettersmall +# lettersmall should be letter with an ImagingBBox of [25 25 587 767]. +qw{lettersmall 612 792}, +# note should be letter (or some other size) with the ImagingBBox +# shrunk by 25 units on all 4 sides. +qw{note 612 792}, +qw{letterLand 792 612}, +# End of Adobe-defined page sizes + +qw{a0 2380 3368}, +qw{a1 1684 2380}, +qw{a2 1190 1684}, +qw{a5 421 595}, +qw{a6 297 421}, +qw{a7 210 297}, +qw{a8 148 210}, +qw{a9 105 148}, +qw{a10 74 105}, +qw{b0 2836 4008}, +qw{b1 2004 2836}, +qw{b2 1418 2004}, +qw{b3 1002 1418}, +qw{b4 709 1002}, +qw{b5 501 709}, # defined by Adobe + +qw{a0Land 3368 2380}, +qw{a1Land 2380 1684}, +qw{a2Land 1684 1190}, +qw{a3Land 1190 842}, +qw{a4Land 842 595}, +qw{a5Land 595 421}, +qw{a6Land 421 297}, +qw{a7Land 297 210}, +qw{a8Land 210 148}, +qw{a9Land 148 105}, +qw{a10Land 105 74}, +qw{b0Land 4008 2836}, +qw{b1Land 2836 2004}, +qw{b2Land 2004 1418}, +qw{b3Land 1418 1002}, +qw{b4Land 1002 709}, +qw{b5Land 709 501}, + +qw{c0 2600 3677}, +qw{c1 1837 2600}, +qw{c2 1298 1837}, +qw{c3 918 1298}, +qw{c4 649 918}, +qw{c5 459 649}, +qw{c6 323 459}, + +# vvv U.S. CAD standard paper sizes +qw{archE 2592 3456}, +qw{archD 1728 2592}, +qw{archC 1296 1728}, +qw{archB 864 1296}, +qw{archA 648 864}, + +qw{flsa 612 936}, # U.S. foolscap +qw{flse 612 936}, # European foolscap +qw{halfletter 396 612}, +qw{csheet 1224 1584}, # ANSI C 17x22 +qw{dsheet 1584 2448}, # ANSI D 22x34 +qw{esheet 2448 3168}, # ANSI E 34x44 +qw{17x22 1224 1584}, # ANSI C 17x22 +qw{22x34 1584 2448}, # ANSI D 22x34 +qw{34x44 2448 3168}, # ANSI E 34x44 +); + +#** @param $_[0] width, in bp +#** @param $_[1] height, in bp +#** @return () or ("papername", width.bp, height.bp) +sub valid_bp($$;$$) { + no integer; + my ($W1,$H1)=(defined$_[2]?$_[2]:0,defined$_[3]?$_[3]:0); + my ($WW,$HH)=(Htex::dimen::dimen2bp($_[0]-$W1), Htex::dimen::dimen2bp($_[1]-$H1)); + # Dat: 1mm == 720/254bp; 3mm =~ 8.5bp + no integer; + for (my $I=0; $I<@papers; $I+=3) { + return @papers[$I,$I+1,$I+2] if abs($papers[$I+1]-$WW)<=8.5 and abs($papers[$I+2]-$HH)<=8.5; + } + () +} + +#** @param $_[0] "width width_unit, height, height_unit" +#** @return () or ("papername", width.bp, height.bp) +sub valid($) { # valid_papersize + my $S=lc shift; + $S=~/^\s*(\d+(\.\d+)?)\s*([a-z][a-z0-9]+)\s*,\s*(\d+(\.\d+)?)\s*([a-z][a-z0-9]+)\s*\Z(?!\n)/ ? + valid_bp("$1$3","$4$6") : (); +} + +just::end} + +BEGIN{$ INC{'Htex/img_bbox.pm'}='Htex/img_bbox.pm'} + +package Htex::img_bbox; +# img_bbox.pa -- extract file format and size from image files +# This file contains embedded perldoc(1) POD documentation. +# by pts@fazekas.hu at Sat Dec 7 21:31:01 CET 2002 +# JustLib2 at Sat Dec 21 21:29:21 CET 2002 +# +# img_bbox.pl is a standalone Perl script that can extract file format, +# width, height, bounding box and +# other meta-information from image files. Supported vector formats are: +# PDF, Flash SWF, EPS, PS, DVI and FIG. Supported raster image formats are: +# GIF, JPEG, PNG, TIFF, XPM, XBM1, XBM, PNM, PBM, PGM, PPM, PCX, LBM, other +# IFF, Windows and OS/2 BMP, MIFF, Gimp XCF, Windows ICO, Adobe PSD, FBM, +# SunRaster, CMUWM, Utah RLE, Photo CD PCD, XWD, GEM, McIDAS, PM, SGI IRIS, +# FITS, VICAR, PDS, FIT, Fax G3, Targa TGA and Faces. +# +# This program is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or +# (at your option) any later version. +# +# This program is distributed in the hope that it will be useful, +# but WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +# GNU General Public License for more details. +# +# Extracting the image size is not supported for: other IFF, FIG. +# +# +use just 1; +use integer; # important +use strict; # not so important +# use Htex::ImgBBox qw(calc -PDF -paper); +use Htex::ImgBBox qw(calc); + +sub delete0($$) { + delete $_[0]{$_[1]}; + "" +} + +#** @param $_[0] $bbi hashref +#** @return a multiline dump of all key--value pairs, sorted by key +sub all($) { + my $bbi=$_[0]; + my $RET=""; + for my $key (sort keys %$bbi) { if (1<length $key) { + my $val=$bbi->{$key}; + $RET.=" $key = ".(ref($val)eq'ARRAY' ? "[ @$val ]\n" : "$val\n"); + } } + $RET +} + +my %texq; +#** @param $_[0] arbitrary binary string +#** @return the string quoted, so it can be safely placed inside TeX +#** \message{...} or \special{...} +sub texq($) { + if (!keys %texq) { + $texq{' '}='\iftrue\space\fi '; # won't collapse two spaces into one + $texq{'\\'}='\expandafter\@secondoftwo\string\\\\'; + $texq{'{'}='\expandafter\@secondoftwo\string\{'; + $texq{'}'}='\expandafter\@secondoftwo\string\}'; + $texq{'%'}='\expandafter\@secondoftwo\string\%'; + $texq{'#'}='\expandafter\@secondoftwo\string\#'; + $texq{'^'}='\expandafter\@secondoftwo\string\^'; # no danger of ^^ + $texq{'~'}='\expandafter\@secondoftwo\string\~'; + $texq{'`'}='\expandafter\@secondoftwo\string\`'; + $texq{'"'}='\expandafter\@secondoftwo\string\"'; + # vvv will work only if the token is expanded only once + #$texq{'~'}='\noexpand~'; + #$texq{'`'}='\noexpand`'; + #$texq{'"'}='\noexpand"'; + } + my $S=$_[0]; + $S=~s@(\W)@exists$texq{$1}?$texq{$1}:$1@ge; + $S=~s~([\000-\037\177-\377])~sprintf"\\expandafter\\\@secondoftwo\\string\\^^%02x",ord$1~ge; + $S +} + +sub aq($$) { + $_[0] eq ":t" ? texq($_[1]) : $_[1] +} + +my $t_short="%{FileName} %{FileFormat:-??} %{LLX:-??} %{LLY:-??} %{URX:-??} %{URY:-??}%{Paper?+ %{Paper}}%{Error?+ error:%{Error}}\n"; +my $t_long="%{FileName}%{FileName?0}\n%{all}"; +# my $t_tex='\graphicPmeta{%{FileName:t}%{c}{%{FileFormat:-?}%{c}{%{LLX:-?}%{c}{%{LLY:-?}%{c}{%{URX:-?}%{c}{%{URY:-?}%{c}%{n}'; +my $t_tex='\graphicPmeta{%{FileName:t}%{c}{%{FileFormat:-?}%{SubFormat?+.%{SubFormat}}%{c}{%{LLX:-?}%{c}{%{LLY:-?}%{c}{%{URX:-?}%{c}{%{URY:-?}%{c}%{n}'; + +sub compile_template($) { + my $template=$_[0]; + # convert $template to Perl code + $template=~s@([\\'])@\\$1@g; + $template=~s@([}])|[%][{]([\w.-]+)(:t)?(:-|[?][+0-]|)@ + defined($1) ? "').'" : + $4 eq "" && $2 eq "all" ? "'.(all(\$bbi).'" : + $4 eq "" ? "'.(!defined\$bbi->{'$2'}?'':aq('".($3||"")."',\$bbi->{'$2'}).'" : + $4 eq "?+" ? "'.(!defined\$bbi->{'$2'}?'':'" : + $4 eq "?-" ? "'.(defined\$bbi->{'$2'}?'':'" : + $4 eq ":-" ? "'.(defined\$bbi->{'$2'}?aq('".($3||"")."',\$bbi->{'$2'}):'" : + $4 eq "?0" ? "'.(delete0(\$bbi,'$2').'" : + "[$1]($2)($4)" # should never happen + @ge; + my $sub=eval "sub { my \$bbi=\$_[0]; '$template' }"; + die "$0: template syntax error: $@" if $@ or ref($sub) ne 'CODE'; + $sub +} + +sub work($$) { + my($sub,$filename)=@_; + my $bbi; + # die "$0: $filename: $!\n" unless open F, "< $filename"; + if (open F, "< $filename") { + ## print STDERR "$filename\n"; + $bbi=calc(\*F); + } else { + $bbi->{Error}="open: $!" + } + $bbi->{FileName}=$filename; + $bbi->{n}="\n"; + $bbi->{p}="%"; + $bbi->{c}="}"; + print $sub->($bbi); +} + +sub usage() { + die "This is img_bbox.pl by pts\@fazekas.hu, version 0.08 +This program is free software, licensed under the GNU GPL. +This software comes with absolutely NO WARRANTY. Use at your own risk! + +Usage: $0 [<template>] <filename.image> [...] +Template is one of: -- --short --long --tex --template <t> + +I can extract file format, width, height, bounding box and other +meta-information from image files. Run this to get more docs: + perldoc '$0'\n" +} + +just::main; + +usage if !@ARGV; + +my $template=$t_short; +if ($ARGV[0] eq '--' or $ARGV[0] eq '--short') { } +elsif ($ARGV[0] eq '--long') { $template=$t_long; shift @ARGV } +elsif ($ARGV[0] eq '--tex') { $template=$t_tex; shift @ARGV } +elsif ($ARGV[0] eq '--template') { usage if @ARGV<2; $template=$ARGV[1]; splice @ARGV, 0, 2 } +elsif ($ARGV[0]=~/\A--/) { goto usage } + +my $sub=compile_template($template); +for my $filename (@ARGV) { work $sub, $filename } + +__END__ + +=begin man + +.ds pts-dev \*[.T] +.do if '\*[.T]'ascii' .ds pts-dev tty +.do if '\*[.T]'ascii8' .ds pts-dev tty +.do if '\*[.T]'latin1' .ds pts-dev tty +.do if '\*[.T]'nippon' .ds pts-dev tty +.do if '\*[.T]'utf8' .ds pts-dev tty +.do if '\*[.T]'cp1047' .ds pts-dev tty +.do if '\*[pts-dev]'tty' \{\ +.ll 79 +.pl 33333v +.nr IN 2n +.\} +.ad n + +=end + +=head1 NAME + +img_bbox.pl - Extract file format and size from image files + +=head1 SYNOPSIS + +C<B<img_bbox.pl>> + S<[ C<--> | C<--short>> + S<| C<--long>> + S<| C<--tex>> + S<| C<--template> I<template> ]> + S<I<filename.image>> S<[ ... ]> + +=head1 DESCRIPTION + +img_bbox.pl is a standalone Perl script that can extract file format, +width, height, bounding box and +other meta-information from image files. Supported vector formats are: +PDF, Flash SWF, EPS, PS, DVI and FIG. Supported raster image formats are: +GIF, JPEG, PNG, TIFF, XPM, XBM1, XBM, PNM, PBM, PGM, PPM, PCX, LBM, other +IFF, Windows and OS/2 BMP, MIFF, Gimp XCF, Windows ICO, Adobe PSD, FBM, +SunRaster, CMUWM, Utah RLE, Photo CD PCD, XWD, GEM, McIDAS, PM, SGI IRIS, +FITS, VICAR, PDS, FIT, Fax G3, Targa TGA and Faces. + +img_bbox.pl writes the extracted information to STDOUT, in a format +determined by the template specified on the command line. The default +template is C<--short>. Templates are: + +=over 10 + +=item C<--short> + +writes the file name, file format and the four +bounding box coordinates (lower left x, lower left y, upper right x, upper +right y), separated by spaces. + +=item C<--long> + +writes a multi-line entry for each file containing all key--value pairs +that img_bbox.pl was able to extract. + +=item C<--tex> + +writes output suitable for C<\input> in TeX. The file name, file format and +bounding box is dumped + +=item C<--pat> + +lets the user specify an individual pattern, see later. + +=back + +=head1 PATTERNS + +Individual patterns can be specified after C<--pat>. Built-in patterns are: + + --short: %{FileName} %{FileFormat:-??} %{LLX:-??} %{LLY:-??} %{URX:-??} %{URY:-??}%{Paper?+ %{Paper}}%{Error?+ error:%{Error}}%{n} + --long : %{FileName}%{FileName?0}%{n}%{all} + --tex : \graphicPmeta{%{FileName:t}%{c}{%{FileFormat:-?}%{c}{%{LLX:-?}%{c}{%{LLY:-?}%{c}{%{URX:-?}%{c}{%{URY:-?}%{c}%{n} + +Expressions of the form + C<%{> I<key> [ I<quoting> ] I<method> I<body> C<}> + are substituted. + +I<key>s of interest will be enumerated later in this subsection. + +I<quoting> is one of + +=over 7 + +=item (none) + +The string is inserted as-is. + +=item C<:t> + +Quotes all TeX and LaTeX control characters. + +=back + +The interpretation of I<body> depends on I<method>. The default action is to +append the contents of I<body> verbatim after the substitution. I<body> is +an empty string most of the time. + +I<method> is one of + +=over 7 + +=item (none) + +Expands to the value of I<key>, or an empty string. I<body> must be empty. + +=item C<:-> + +Expands to the value of I<key>, or I<body>. + +=item C<?0> + +Deletes I<key>, and expands to I<body>. + +=item C<?+> + +Expands to I<body> if I<key> exists, or an empty string. + +=item C<?-> + +Expands to I<body> if I<key> is missing, or an empty string. + +=back + +I<key>s of interest are: + +=over 20 + +=item n + +a newline + +=item p + +a percent sign + +=item c + +a close brace + +=item all + +A detailed, multi-line key--value listing of all information extracted, as +output by the C<--long> template. + +=item FileName + +=item FileFormat + +=item SubFormat + +=item LLX + +Zero for most file formats. + +=item LLY + +Zero for most file formats. + +=item URX + +The width for most file formats. + +=item URY + +The height for most file formats. + +=item SamplesPerPixel + +=item BitsPerSample + +=item ColorSpace + +Gray, RGB, YCbCr, CMYK, YCCK, Indexed etc. + +=item Error + +the first I/O or other error + +=item Info. + +various file format specific keys begin with C<Info.> + +=item Val. + +various key--value pairs read from the file, beginning with C<Val.> + +=item Info.MediaBox + +PDF only + +=item Info.CropBox + +PDF only + +=item Info.BleedBox + +PDF only + +=item Info.TrimBox + +PDF only + +=item Info.ArtBox + +PDF only + +=item Info.Compression + +TIFF only + +=item Info.NewSubfileType + +TIFF only + +=item Info.PhotometricInterpretation + +TIFF only + +=item Info.Thresholding + +TIFF only + +=item Info.CellWidth + +TIFF only + +=item Info.CellLength + +TIFF only + +=item Info.FillOrder + +TIFF only + +=item Info.Orientation + +TIFF only + +=item Info.RowsPerStrip + +TIFF only + +=item Info.MinSampleValue + +TIFF only + +=item Info.MaxSampleValue + +TIFF only + +=item Info.PlanarConfiguration + +TIFF only + +=item Info.GrayResponseUnit + +TIFF only + +=item Info.ResolutionUnit + +TIFF only + +=item Info.ExtraSamples + +TIFF only + +=item Info.hvs + +JPEG only + +=item Info.id_rgb + +JPEG only + +=item Info.had_jfif + +JPEG only + +=item Info.ColorTransform + +JPEG only + +=item Info.binary + +Clean7Bit, Clean8Bit or Binary. PDF and PS only + +=item Info.linearized + +PDF only + +=item Info.denominator + +DVI only + +=item Info.nominator + +DVI only + +=item Info.version_id + +DVI only + + +=item Info.maginification + +DVI only + + +=item Info.jobname + +DVI only + +=item Info.page1_nr + +DVI only + +=item Info.special + +DVI only + +=item Info.colors + +ICO only + +=item Info.reserved + +ICO only + + +=item Info.planes + +ICO only + + +=item Info.credits + +FBM only + +=item Info.title + +FBM only + +=item Info.planes + +FBM only + +=item Info.bits + +FBM only + +=item Info.rowlen + +FBM only + +=item Info.plnlen + +FBM only + +=item Info.clrlen + +FBM only + +=item Info.hlen + +GEM only + +=item Info.colors + +GEM only + +=item Info.patlen + +GEM only + +=item Info.llen + +GEM only + +=item Info.lines + +GEM only + +=item Info.num_planes + +PM only + +=item Info.num_bands + +PM only + +=item Info.pixel_format + +PM only + +=item Info.compression + +SGI only + +=item Info.comment + +SGI only + +=item Info.bits_per_pixel + +FITS only + +=item Info.num_axis + +FITS only + +=item Info.depth + +FITS only + +=item Info.data_max + +FITS only + +=item Info.data_min + +FITS only + +=back + +=head1 LICENSE + +This program is free software; you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation; either version 2 of the License, or +(at your option) any later version. + +This program is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +=head1 AUTHOR + +Szabó Péter <F<pts@fazekas.hu>> + +=head1 SEE ALSO + +file(1) |