1#! perl -w 2# A PBM/PGM/PPM library. 3# Benjamin Elijah Griffin 28 Feb 2012 4# elijah@cpan.org 5 6package Image::PBMlib; 7use 5.010000; 8use strict; 9use warnings; 10 11use vars qw( @ISA @EXPORT ); 12require Exporter; 13@ISA = qw(Exporter); 14 15@EXPORT = qw( readpnmfile checkpnminfo readpnmheader readpnmpixels 16 makepnmheader encodepixels writepnmfile inspectpixels 17 explodetriple rescaleval rescaletriple 18 hextripletofloat dectripletofloat 19 hexvaltofloat decvaltofloat 20 floattripletodec floattripletohex 21 floatvaltodec floatvaltohex 22 comparefloatval comparefloattriple 23 comparepixelval comparepixeltriple 24 ); 25 26$Image::PBMlib::VERSION = '2.00'; 27 28=head1 NAME 29 30Image::PBMlib - Helper functions for PBM/PGM/PPM image file formats 31 32=head1 SYNOPSIS 33 34 use Image::PBMlib; 35 36 ... open(PNM, '<:raw', "image.ppm")... 37 38 my (%info, @pixels); 39 # fourth is encoding of float, dec, or hex 40 readpnmfile( \*PNM, \%info, \@pixels, 'float' ); 41 # sets $info{error} if an error 42 43 readpnmheader( \*PNM, \%info ); 44 # sets $info{error} if an error 45 46 checkpnminfo( \%info ); 47 # sets $info{error} if an error 48 49 # float, dec, or hex 50 readpnmpixels( \*PNM, \%info, \@pixels, 'float') 51 # sets $info{error} if an error 52 53 # R/G/B to RRRR/GGGG/BBBB, max 1 to 65535 54 my $rgb = hextripletofloat( "F00/B/A4", $maxvalue ); 55 56 # R:G:B, max 1 to 65535 57 my $rgb = dectripletofloat( "3840:11:164", $maxvalue ); 58 59 # returns the number of bytes written, as a positive 60 # number if no error, and zero or -1*bytes if error 61 my $return = writepnmfile(\*PNM, \%info, \@pixels); 62 63 # this header can contain comments 64 my $header = makepnmheader(\%info); 65 66 # this header will not contain comments 67 # 1 for ascii PBM, 2 for ascii PGM, 3 for ascii PPM, 68 # 4 for raw PBM, 5 for raw PGM, 6 for raw PPM 69 my $header = makepnmheader('5', $width, $height, $maxvalue); 70 71 # raw, dec, or hex format pixels, in 'raw' or 'ascii' 72 # for writing to a file 73 my $block = encodepixels('raw', $maxvalue, \@pixels); 74 75=head1 DESCRIPTION 76 77This is primarily a library for reading and writing portable bitmap (PBM), 78portable graymap (PGM), and portable pixmap (PPM) files. As a 79set they are portable anymap (PNM). There is a separate PAM 80format that is not yet supported. Within each format there are 81two representations on disk, ASCII and RAW. ASCII is suitable 82for raw email transmission, short lines, all 7-bit characters. 83RAW is much more compact and generally preferred. A single RAW 84formatted file can contain multiple concatenated images. 85 86These image formats are only the barest step up from raw raster 87data, and have a very simple format which is the key to be "portable". 88Writing out images in these formats is very easy. Reading only 89slightly more complicated. 90 91=head2 Maxvalue 92 93Version 1.x of this library had serious bugs except for the most 94basic versions of PGM and PPM files, by not properly observing 95the maxvalue. Version 2.x fixes that at a compatiblity cost. Raw 96gray and color channel information is now stored as a floating 97point number from 0.0 as full black to 1.0 as full white, and 98it is scaled to the approprate maxvalue, which is a decimal integer 99from 1 to 65535 inclusive. 100 101=head2 Pixels 102 103When this version of the library returns a pixel it will be: 104"0" or "1" for PBM files; "0.0," to "1.0," for PGM in float 105format, "0:" to "65535:" for PGM in decimal, "0/" to "FFFF/" 106for PGM in hexadecimal; "0.0,0.0,0.0" to "1.0,1.0,1.0" for 107PPM in float, "0:0:0" to "65535:65535:65535" for PPM in decimal, 108and "FFFF/FFFF/FFFF" for PPM in hexadecimal. 109 110That is to say PBM files always return just zeros and ones, 111regardless of float, dec, or hex settings. 112 113PGM files return a floating point number, an unrescaled dec or 114hex value, but always followed by a comma if float, a colon if 115decimal, and a slash if hex. Unrescaled means that if the 116maxvalue is 1000 (decimal integer), then white is "1.0," in 117float, "1000:" in dec, and "3E8/" in hex. 118 119PPM files return a RGB set of floating point numbers, an 120unrescaled set of dec or hex values, which are always separated 121by commas if float, colons if decimal, and slashes if hex. Be sure 122to read what unscaled means in the previous paragraph. 123 124Image::PBMlib likes pixels in a two dimensional array, but can 125use a single dimensional array. 126 127=cut 128 129BEGIN { 130} # end BEGIN 131 132 133# Internal read header function. Does not do argument checks. 134sub int_readpnmheader { 135 my $gr = shift; # input file glob ref 136 my $ir = shift; # image info hash ref 137 my $in = ''; 138 my $pre = ''; 139 my $no_comments; 140 my $rc; 141 142 $rc = read($gr, $in, 3); 143 144 if (!defined($rc) or $rc != 3) { 145 $$ir{error} = 'Read error or EOF on magic number'; 146 $$ir{fullheader} = $in; 147 return; 148 } 149 150 if ($in =~ /\nP[123456]/) { 151 # hmmm. bad concatenated file? 152 my $peek; 153 $rc = read($gr, $peek, 1); 154 if($rc and $peek eq "\n") { 155 $in =~ s/^\n//; 156 $in .= "\n"; 157 } 158 } 159 160 if ($in =~ /^P([123456])\s/) { 161 $$ir{type} = $1; 162 if ($$ir{type} > 3) { 163 $$ir{raw} = 1; 164 $$ir{format} = 'raw'; 165 } else { 166 $$ir{raw} = 0; 167 $$ir{format} = 'ascii'; 168 } 169 170 if ($$ir{type} == 1 or $$ir{type} == 4) { 171 $$ir{max} = 1; 172 $$ir{bgp} = 'b'; 173 } elsif ($$ir{type} == 2 or $$ir{type} == 5) { 174 $$ir{bgp} = 'g'; 175 } else { 176 $$ir{bgp} = 'p'; 177 } 178 179 while(1) { 180 $rc = read($gr, $in, 1, length($in)); 181 if (!defined($rc) or $rc != 1) { 182 $$ir{error} = 'Read error or EOF during header'; 183 $$ir{fullheader} = $in; 184 return; 185 } 186 187 # yes, really reset ir{comments} every time through loop 188 $no_comments = $in; 189 $$ir{comments} = ''; 190 while ($no_comments =~ /#.*\n/) { 191 $no_comments =~ s/#(.*\n)/ /; 192 $$ir{comments} .= $1; 193 } 194 195 if ($$ir{bgp} eq 'b') { 196 if ($no_comments =~ /^P\d\s+(\d+)\s+(\d+)\s/) { 197 $$ir{width} = $1; 198 $$ir{height} = $2; 199 $$ir{pixels} = $1*$2; 200 last; 201 } 202 } else { 203 # graymap and pixmap 204 if ($no_comments =~ /^P\d\s+(\d+)\s+(\d+)\s+(\d+)\s/) { 205 $$ir{width} = $1; 206 $$ir{height} = $2; 207 $$ir{max} = $3; 208 $$ir{pixels} = $1*$2; 209 last; 210 } 211 } 212 } # while reading header 213 214 $$ir{error} = ''; 215 } else { 216 $$ir{error} = 'Wrong magic number'; 217 } 218 219 $$ir{fullheader} = $in; 220 return; 221} # end &int_readpnmheader 222 223# internal single value to float function 224sub int_decvaltofloat { 225 my $v = shift; 226 my $m = shift; 227 my $p; 228 229 # eat our own dog food for indicating a decimal value 230 $v =~ s/:$//; 231 232 if($v >= $m) { 233 $p = '1.0,'; 234 } elsif ($v == 0) { 235 $p = '0.0,'; 236 } else { 237 $p = sprintf('%0.8f,', ($v/$m)); 238 } 239 240 return $p; 241} # end &int_decvaltofloat 242 243# internal RGB to float function 244sub int_dectripletofloat { 245 my $r = shift; 246 my $g = shift; 247 my $b = shift; 248 my $m = shift; 249 my $p; 250 251 # eat our own dog food for indicating a decimal value 252 $r =~ s/:$//; 253 $g =~ s/:$//; 254 $b =~ s/:$//; 255 256 if($r > $m) { $r = $m; } 257 if($g > $m) { $g = $m; } 258 if($b > $m) { $b = $m; } 259 260 $p = sprintf('%0.8f,%0.8f,%0.8f', ($r/$m), ($g/$m), ($b/$m)); 261 262 # paranoia: I don't trust floating point to get 1.0 exactly 263 $p =~ s/1[.]\d+/1.0/g; 264 265 # more compact 266 $p =~ s/0[.]0+\b/0.0/g; 267 268 return $p; 269} # end &int_dectripletofloat 270 271# internal single float to dec function 272sub int_floatvaltodec { 273 my $v = shift; 274 my $m = shift; 275 my $p; 276 277 # eat our own dog food for indicating a float value 278 $v =~ s/,$//; 279 280 # 1/65535 is about .0000152590 281 if($v >= 0.999999) { 282 $p = "$m:"; 283 } elsif ($v <= 0.000001) { 284 $p = '0:'; 285 } else { 286 # counter-intuitive way to round to an interger, but int() is 287 # rather broken. 288 $p = sprintf('%1.0f:', ($v*$m)); 289 } 290 291 return $p; 292} # end &int_floatvaltodec 293 294# internal RGB float to dec function 295sub int_floattripletodec { 296 my $r = shift; 297 my $g = shift; 298 my $b = shift; 299 my $m = shift; 300 my $p; 301 302 $r = int_floatvaltodec($r, $m); 303 $g = int_floatvaltodec($g, $m); 304 $b = int_floatvaltodec($b, $m); 305 306 $p = "$r$g$b"; 307 # remove final (extra) comma 308 $p =~ s/,$//; 309 310 return $p; 311} # end &int_floattripletodec 312 313# internal single float to hex function 314sub int_floatvaltohex { 315 my $v = shift; 316 my $m = shift; 317 my $p; 318 319 # eat our own dog food for indicating a float value 320 $v =~ s/,$//; 321 322 # 1/65535 is about .0000152590 323 if($v >= 0.999999) { 324 $p = sprintf("%X/", $m); 325 } elsif ($v <= 0.000001) { 326 $p = '0/'; 327 } else { 328 # counter-intuitive way to round to an interger, but int() is 329 # rather broken. 330 $p = sprintf("%X/", sprintf('%1.0f', ($v*$m))); 331 } 332 333 return $p; 334} # end &int_floatvaltohex 335 336# internal RGB float to hex function 337sub int_floattripletodhex{ 338 my $r = shift; 339 my $g = shift; 340 my $b = shift; 341 my $m = shift; 342 my $p; 343 344 $r = int_floatvaltohex($r, $m); 345 $g = int_floatvaltohex($g, $m); 346 $b = int_floatvaltohex($b, $m); 347 348 $p = "$r$g$b"; 349 # remove final (extra) slash 350 $p =~ s:/$::; 351 352 return $p; 353} # end &int_floattripletohex 354 355# hands off to correct int_encodepixels_N type 356sub int_encodepixels { 357 my $type = shift; 358 my $p_r = shift; 359 my $deep = shift; 360 my $encode = shift; 361 my $max = shift; 362 363 # most common to least common 364 # type 7 is PAM, not supported here (yet) 365 # types 1 and 4 are PBM and don't need a max 366 367 if($type == 6) { 368 return int_encodepixels_6($p_r, $deep, $encode, $max); 369 } 370 if($type == 5) { 371 return int_encodepixels_5($p_r, $deep, $encode, $max); 372 } 373 if($type == 4) { 374 return int_encodepixels_4($p_r, $deep, $encode ); 375 } 376 if($type == 3) { 377 return int_encodepixels_3($p_r, $deep, $encode, $max); 378 } 379 if($type == 2) { 380 return int_encodepixels_2($p_r, $deep, $encode, $max); 381 } 382 if($type == 1) { 383 return int_encodepixels_1($p_r, $deep, $encode ); 384 } 385 386 # should never reach here 387 return undef; 388 389} # end &int_encodepixels 390 391# Internal read pixels for P1: ascii bitmap. Does not do argument checks. 392sub int_readpixels_1 { 393 my $gr = shift; # input file glob ref 394 my $ir = shift; # image info hash ref 395 my $pr = shift; # pixel array ref 396 my $enc = shift; # target pixel encoding 397 398 my $used = 0; 399 my $read; 400 my $bit; 401 my $w = 0; 402 my $h = 0; 403 404 while(defined($read = <$gr>)) { 405 while($read =~ /\b(\d+)\b/g) { 406 $bit = ($1)? 1 : 0; 407 $$pr[$h][$w] = $bit; 408 $used ++; 409 if($used >= $$ir{pixels}) { last; } 410 $w ++; 411 if($w >= $$ir{width}) { 412 $w = 0; 413 $h ++; 414 } 415 } 416 } # while read from file 417 418 if($used < $$ir{pixels}) { 419 $$ir{error} = 'type 1 read: not enough pixels'; 420 } else { 421 $$ir{error} = ''; 422 } 423} # end &int_readpixels_1 424 425# Internal write pixels for P1: ascii bitmap. Does not do argument checks. 426sub int_encodepixels_1 { 427 my $pr = shift; # pixel array ref 428 my $deep = shift; # how deep is our array 429 my $enc = shift; # source pixel encoding 430 431 my $w = 0; 432 my $h = 0; 433 my $out = ''; 434 my $wide = 0; 435 my $pix; 436 my $cur; 437 438 if($deep eq '1d') { 439 # $#{array} returns counts starting at -1 for empty array 440 $pix = 1+ $#{$pr}; 441 $cur = $$pr[$w]; 442 } else { 443 # deep = 3d only allowed for P3/P6 444 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]}); 445 $cur = $$pr[$h][$w]; 446 } 447 448 while($pix > 0) { 449 $cur =~ s![,:/]$!!; 450 if($enc eq 'float') { 451 if($cur > 0.5) { 452 $out .= '1 '; 453 } else { 454 $out .= '0 '; 455 } 456 } else { 457 # for PBM, we assume $max is 1 458 if($cur) { 459 $out .= '1 '; 460 } else { 461 $out .= '0 '; 462 } 463 } 464 465 $wide += 2; 466 if($wide > 70) { 467 $out .= "\n"; 468 $wide = 0; 469 } 470 471 $pix --; 472 $w ++; 473 if($deep eq '1d') { 474 if(exists($$pr[$w]) and defined($$pr[$w])) { 475 $cur = $$pr[$w]; 476 } else { 477 $cur = 0; 478 } 479 } else { 480 if(!exists($$pr[$h][$w])) { 481 $w = 0; 482 $h ++; 483 } 484 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) { 485 $cur = $$pr[$h][$w]; 486 } else { 487 $cur = 0; 488 } 489 } 490 } # while pix 491 492 if($wide) { 493 $out .= "\n"; 494 } 495 return($out); 496} # end &int_encodepixels_1 497 498# Internal read pixels for P2: ascii graymap. Does not do argument checks. 499sub int_readpixels_2 { 500 my $gr = shift; # input file glob ref 501 my $ir = shift; # image info hash ref 502 my $pr = shift; # pixel array ref 503 my $enc = shift; # target pixel encoding 504 505 my $used = 0; 506 my $read; 507 my $val; 508 my $pix; 509 my $w = 0; 510 my $h = 0; 511 512 while(defined($read = <$gr>)) { 513 while($read =~ /\b(\d+)\b/g) { 514 $val = $1; 515 516 if($enc eq 'dec') { 517 $pix = "$val:"; 518 } elsif ($enc eq 'hex') { 519 $pix = sprintf('%X:', $val); 520 } else { 521 if($val >= $$ir{max}) { 522 $pix = '1.0,'; 523 } elsif ($val == 0) { 524 $pix = '0.0,'; 525 } else { 526 $pix = sprintf('%0.8f,', $val/$$ir{max}); 527 } 528 } 529 530 $$pr[$h][$w] = $pix; 531 $used ++; 532 if($used >= $$ir{pixels}) { last; } 533 $w ++; 534 if($w >= $$ir{width}) { 535 $w = 0; 536 $h ++; 537 } 538 } 539 } # while read from file 540 541 if($used < $$ir{pixels}) { 542 $$ir{error} = 'type 2 read: not enough pixels'; 543 } else { 544 $$ir{error} = ''; 545 } 546} # end &int_readpixels_2 547 548# Internal write pixels for P2: ascii graymap. Does not do argument checks. 549sub int_encodepixels_2 { 550 my $pr = shift; # pixel array ref 551 my $deep = shift; # how deep is our array 552 my $enc = shift; # source pixel encoding 553 my $max = shift; # max value 554 555 my $w = 0; 556 my $h = 0; 557 my $out = ''; 558 my $val; 559 my $wide = 0; 560 my $pix; 561 my $cur; 562 563 if($deep eq '1d') { 564 # $#{array} returns counts starting at -1 for empty array 565 $pix = 1+ $#{$pr}; 566 $cur = $$pr[$w]; 567 } else { 568 # deep = 3d only allowed for P3/P6 569 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]}); 570 $cur = $$pr[$h][$w]; 571 } 572 573 while($pix > 0) { 574 575 if($enc eq 'float') { 576 $val = int_floatvaltodec($cur, $max); 577 chop($val); # eat last ':' 578 } elsif($enc eq 'hex') { 579 $cur =~ s!/$!!; 580 $val = hex($cur); 581 } else { 582 $cur =~ s!:$!!; 583 $val = 0+$cur; # normalize numbers 584 } 585 586 if($val > $max) { 587 $val = $max; 588 } 589 590 if(70 < ($wide + 1 + length($val))) { 591 $wide = 0; 592 $out .= "\n"; 593 } 594 $out .= $val . ' '; 595 $wide += 1 + length($val); 596 597 $pix --; 598 $w ++; 599 if($deep eq '1d') { 600 if(exists($$pr[$w]) and defined($$pr[$w])) { 601 $cur = $$pr[$w]; 602 } else { 603 $cur = 0; 604 } 605 } else { 606 if(!exists($$pr[$h][$w])) { 607 $w = 0; 608 $h ++; 609 } 610 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) { 611 $cur = $$pr[$h][$w]; 612 } else { 613 $cur = 0; 614 } 615 } 616 } # while pix 617 618 if($wide) { 619 $out .= "\n"; 620 } 621 622 return($out); 623} # end &int_encodepixels_2 624 625# Internal read pixels for P3: ascii pixmap. Does not do argument checks. 626sub int_readpixels_3 { 627 my $gr = shift; # input file glob ref 628 my $ir = shift; # image info hash ref 629 my $pr = shift; # pixel array ref 630 my $enc = shift; # target pixel encoding 631 632 my $used = 0; 633 my $read; 634 my $val; 635 my $pix; 636 my $w = 0; 637 my $h = 0; 638 my $r; 639 my $g; 640 my $state = 'r'; 641 642 while(defined($read = <$gr>)) { 643 while($read =~ /\b(\d+)\b/g) { 644 $val = $1; 645 646 if($enc eq 'dec') { 647 $pix = "$val:"; 648 } elsif ($enc eq 'hex') { 649 $pix = sprintf('%X:', $val); 650 } else { 651 if($val >= $$ir{max}) { 652 $pix = '1.0,'; 653 } elsif ($val == 0) { 654 $pix = '0.0,'; 655 } else { 656 $pix = sprintf('%0.8f,', $val/$$ir{max}); 657 } 658 } 659 660 if($state eq 'r') { 661 $r = $pix; 662 $state = 'g'; 663 } elsif($state eq 'g') { 664 $g = $pix; 665 $state = 'b'; 666 } else { 667 668 chop($pix); 669 $$pr[$h][$w] = "$r$g$pix"; 670 $used ++; 671 if($used >= $$ir{pixels}) { last; } 672 $w ++; 673 if($w >= $$ir{width}) { 674 $w = 0; 675 $h ++; 676 } 677 678 $state = 'r'; 679 } 680 } 681 } # while read from file 682 683 if($used < $$ir{pixels}) { 684 $$ir{error} = 'type 3 read: not enough pixels'; 685 } else { 686 $$ir{error} = ''; 687 } 688} # end &int_readpixels_3 689 690# Internal write pixels for P3: ascii pixmap. Does not do argument checks. 691sub int_encodepixels_3 { 692 my $pr = shift; # pixel array ref 693 my $deep = shift; # how deep is our array 694 my $enc = shift; # source pixel encoding 695 my $max = shift; # max value 696 697 my $w = 0; 698 my $h = 0; 699 my $out = ''; 700 my $val; 701 my $wide = 0; 702 my $pix; 703 my @cur; 704 my $rgb; 705 706 if($deep eq '1d') { 707 # $#{array} returns counts starting at -1 for empty array 708 $pix = 1+ $#{$pr}; 709 @cur = explodetriple($$pr[$w]); 710 } else { 711 # explodetriple makes deep = 2d work like deep = 3d 712 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]}); 713 @cur = explodetriple($$pr[$h][$w]); 714 } 715 716 while($pix > 0) { 717 718 for $rgb (0,1,2) { 719 if($enc eq 'float') { 720 $val = int_floatvaltodec($cur[$rgb], $max); 721 chop($val); # eat last ':' 722 } elsif($enc eq 'hex') { 723 $cur[$rgb] =~ s!/$!!; 724 $val = hex($cur[$rgb]); 725 } else { 726 $cur[$rgb] =~ s!:$!!; 727 $val = 0+$cur[$rgb]; # normalize numbers 728 } 729 730 if($val > $max) { 731 $val = $max; 732 } 733 734 if(70 < ($wide + 1 + length($val))) { 735 $wide = 0; 736 $out .= "\n"; 737 } 738 $out .= $val . ' '; 739 $wide += 1 + length($val); 740 } # for rgb 741 742 $pix --; 743 $w ++; 744 if($deep eq '1d') { 745 if(exists($$pr[$w]) and defined($$pr[$w])) { 746 @cur = explodetriple($$pr[$w]); 747 } else { 748 @cur = (0,0,0); 749 } 750 } else { 751 if(!exists($$pr[$h][$w])) { 752 $w = 0; 753 $h ++; 754 } 755 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) { 756 @cur = explodetriple($$pr[$h][$w]); 757 } else { 758 @cur = (0,0,0); 759 } 760 } 761 } # while pix 762 763 if($wide) { 764 $out .= "\n"; 765 } 766 return($out); 767} # end &int_encodepixels_3 768 769# Internal read pixels for P4: raw bitmap. Does not do argument checks. 770sub int_readpixels_4 { 771 my $gr = shift; # input file glob ref 772 my $ir = shift; # image info hash ref 773 my $pr = shift; # pixel array ref 774 my $enc = shift; # target pixel encoding 775 776 my $used = 0; 777 my $read; 778 my $bits; 779 my $bit; 780 my $w = 0; 781 my $h = 0; 782 783 READ: 784 while(read($gr,$read,1)) { 785 # $bits will be '01000001' if $read is 'A' 786 $bits = unpack('B*', $read); 787 788 for $bit ($bits =~ /([01])/g) { 789 $$pr[$h][$w] = $bit; 790 $used ++; 791 if($used >= $$ir{pixels}) { last READ; } 792 $w ++; 793 if($w >= $$ir{width}) { 794 $w = 0; 795 $h ++; 796 # pbm pads each row with unused bits, if (width % 8) != 0 797 next READ; 798 } 799 } 800 } # while read from file 801 802 if($used < $$ir{pixels}) { 803 $$ir{error} = 'type 4 read: not enough pixels'; 804 } else { 805 $$ir{error} = ''; 806 } 807} # end &int_readpixels_4 808 809# Internal write pixels for P4: raw bitmap. Does not do argument checks. 810sub int_encodepixels_4 { 811 my $pr = shift; # pixel array ref 812 my $deep = shift; # how deep is our array 813 my $enc = shift; # source pixel encoding 814 815 my $w = 0; 816 my $h = 0; 817 my $out = ''; 818 my $used = 0; 819 my $pix; 820 my $cur; 821 my $val = ''; 822 823 if($deep eq '1d') { 824 # $#{array} returns counts starting at -1 for empty array 825 $pix = 1+ $#{$pr}; 826 $cur = $$pr[$w]; 827 } else { 828 # deep = 3d only allowed for P3/P6 829 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]}); 830 $cur = $$pr[$h][$w]; 831 } 832 833 while($pix > 0) { 834 $cur =~ s![,:/]$!!; 835 if($enc eq 'float') { 836 if($cur > 0.5) { 837 $val .= '1'; 838 } else { 839 $val .= '0'; 840 } 841 } else { 842 # for PBM, we assume $max is 1 843 if($cur) { 844 $val .= '1'; 845 } else { 846 $val .= '0'; 847 } 848 } 849 850 $used ++; 851 if($used == 8) { 852 $out .= pack("B*", $val); 853 $used = 0; 854 $val = ''; 855 } 856 857 $pix --; 858 $w ++; 859 if($deep eq '1d') { 860 if(exists($$pr[$w]) and defined($$pr[$w])) { 861 $cur = $$pr[$w]; 862 } else { 863 $cur = 0; 864 } 865 } else { 866 if(!exists($$pr[$h][$w])) { 867 $w = 0; 868 $h ++; 869 870 # PBM raw is padded to full byte at end of each row 871 if($used) { 872 $out .= pack("B*", substr($val.'0000000',0,8) ); 873 $used = 0; 874 $val = ''; 875 } 876 } 877 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) { 878 $cur = $$pr[$h][$w]; 879 } else { 880 $cur = 0; 881 } 882 } 883 } # while pix 884 885 if($used) { 886 $out .= pack("B*", substr($val.'0000000',0,8) ); 887 } 888 return($out); 889} # end &int_encodepixels_4 890 891# Internal read pixels for P5: raw graymap. Does not do argument checks. 892sub int_readpixels_5 { 893 my $gr = shift; # input file glob ref 894 my $ir = shift; # image info hash ref 895 my $pr = shift; # pixel array ref 896 my $enc = shift; # target pixel encoding 897 898 my $used = 0; 899 my $read; 900 my $val; 901 my $pix; 902 my $rc; 903 my $w = 0; 904 my $h = 0; 905 my $expect = 1; 906 907 if ($$ir{max} > 255) { 908 $expect = 2; 909 } 910 911 while($rc = read($gr,$read,$expect)) { 912 if($rc == $expect) { 913 if($expect == 1) { 914 # $val will be 65 if $read is 'A' 915 $val = unpack('C', $read); 916 } else { 917 # $val will be 16706 if $read is 'AB' 918 $val = unpack('n', $read); 919 } 920 921 if($enc eq 'dec') { 922 $pix = "$val:"; 923 } elsif ($enc eq 'hex') { 924 $pix = sprintf('%X:', $val); 925 } else { 926 if($val >= $$ir{max}) { 927 $pix = '1.0,'; 928 } elsif ($val == 0) { 929 $pix = '0.0,'; 930 } else { 931 $pix = sprintf('%0.8f,', $val/$$ir{max}); 932 } 933 } 934 935 $$pr[$h][$w] = $pix; 936 $used ++; 937 if($used >= $$ir{pixels}) { last; } 938 $w ++; 939 if($w >= $$ir{width}) { 940 $w = 0; 941 $h ++; 942 } 943 } 944 } # while read from file 945 946 if($used < $$ir{pixels}) { 947 $$ir{error} = 'type 5 read: not enough pixels'; 948 } else { 949 $$ir{error} = ''; 950 } 951} # end &int_readpixels_5 952 953 954# Internal write pixels for P5: raw graymap. Does not do argument checks. 955sub int_encodepixels_5 { 956 my $pr = shift; # pixel array ref 957 my $deep = shift; # how deep is our array 958 my $enc = shift; # source pixel encoding 959 my $max = shift; # max value 960 961 my $w = 0; 962 my $h = 0; 963 my $out = ''; 964 my $val; 965 my $pix; 966 my $cur; 967 my $packer; 968 969 if($max > 255) { 970 $packer = 'n'; 971 } else { 972 $packer = 'C'; 973 } 974 if($deep eq '1d') { 975 # $#{array} returns counts starting at -1 for empty array 976 $pix = 1+ $#{$pr}; 977 $cur = $$pr[$w]; 978 } else { 979 # deep = 3d only allowed for P3/P6 980 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]}); 981 $cur = $$pr[$h][$w]; 982 } 983 984 while($pix > 0) { 985 986 if($enc eq 'float') { 987 $val = int_floatvaltodec($cur, $max); 988 chop($val); # eat last ':' 989 } elsif($enc eq 'hex') { 990 $cur =~ s!/$!!; 991 $val = hex($cur); 992 } else { 993 $cur =~ s!:$!!; 994 $val = 0+$cur; # normalize numbers 995 } 996 997 if($val > $max) { 998 $val = $max; 999 } 1000 1001 $out .= pack($packer, $val); 1002 1003 $pix --; 1004 $w ++; 1005 if($deep eq '1d') { 1006 if(exists($$pr[$w]) and defined($$pr[$w])) { 1007 $cur = $$pr[$w]; 1008 } else { 1009 $cur = 0; 1010 } 1011 } else { 1012 if(!exists($$pr[$h][$w])) { 1013 $w = 0; 1014 $h ++; 1015 } 1016 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) { 1017 $cur = $$pr[$h][$w]; 1018 } else { 1019 $cur = 0; 1020 } 1021 } 1022 } # while pix 1023 1024 return($out); 1025 1026} # end &int_encodepixels_5 1027 1028 1029# Internal read pixels for P6: raw pixmap. Does not do argument checks. 1030sub int_readpixels_6 { 1031 my $gr = shift; # input file glob ref 1032 my $ir = shift; # image info hash ref 1033 my $pr = shift; # pixel array ref 1034 my $enc = shift; # target pixel encoding 1035 1036 my $used = 0; 1037 my $read; 1038 my $val; 1039 my $pix; 1040 my $rc; 1041 my $w = 0; 1042 my $h = 0; 1043 my $r; 1044 my $g; 1045 my $b; 1046 my $expect = 3; 1047 1048 if ($$ir{max} > 255) { 1049 $expect = 6; 1050 } 1051 1052 while($rc = read($gr,$read,$expect)) { 1053 if($rc == $expect) { 1054 if($expect == 3) { 1055 # ($r,$g,$b) will be (65,66,0) if $read is 'AB<nul>' 1056 ($r,$g,$b) = unpack('CCC', $read); 1057 } else { 1058 # ($r,$g,$b) will be (16706,49,12544) if $read is 'AB<nul>11<nul>' 1059 ($r,$g,$b) = unpack('nnn', $read); 1060 } 1061 1062 1063 if($enc eq 'dec') { 1064 $pix = "$r:$g:$b"; 1065 } elsif ($enc eq 'hex') { 1066 $pix = sprintf('%X:%X:%X', $r, $g, $b); 1067 } else { 1068 $pix = int_dectripletofloat($r,$g,$b,$$ir{max}); 1069 } 1070 1071 $$pr[$h][$w] = $pix; 1072 $used ++; 1073 if($used >= $$ir{pixels}) { last; } 1074 $w ++; 1075 if($w >= $$ir{width}) { 1076 $w = 0; 1077 $h ++; 1078 } 1079 1080 } 1081 } # while read from file 1082 1083 if($used < $$ir{pixels}) { 1084 $$ir{error} = 'type 6 read: not enough pixels'; 1085 } else { 1086 $$ir{error} = ''; 1087 } 1088} # end &int_readpixels_6 1089 1090# Internal write pixels for P6: raw pixmap. Does not do argument checks. 1091sub int_encodepixels_6 { 1092 my $pr = shift; # pixel array ref 1093 my $deep = shift; # how deep is our array 1094 my $enc = shift; # source pixel encoding 1095 my $max = shift; # max value 1096 1097 my $w = 0; 1098 my $h = 0; 1099 my $out = ''; 1100 my $val; 1101 my $pix; 1102 my @cur; 1103 my $rgb; 1104 my $packer; 1105 1106 if($max > 255) { 1107 $packer = 'n'; 1108 } else { 1109 $packer = 'C'; 1110 } 1111 1112 if($deep eq '1d') { 1113 # $#{array} returns counts starting at -1 for empty array 1114 $pix = 1+ $#{$pr}; 1115 @cur = explodetriple($$pr[$w]); 1116 } else { 1117 # explodetriple makes deep = 2d work like deep = 3d 1118 $pix = (1+ $#{$pr}) * (1+ $#{$$pr[0]}); 1119 @cur = explodetriple($$pr[$h][$w]); 1120 } 1121 1122 while($pix > 0) { 1123 1124 for $rgb (0,1,2) { 1125 if($enc eq 'float') { 1126 $val = int_floatvaltodec($cur[$rgb], $max); 1127 chop($val); # eat last ':' 1128 } elsif($enc eq 'hex') { 1129 $cur[$rgb] =~ s!/$!!; 1130 $val = hex($cur[$rgb]); 1131 } else { 1132 $cur[$rgb] =~ s!:$!!; 1133 $val = 0+$cur[$rgb]; # normalize numbers 1134 } 1135 1136 if($val > $max) { 1137 $val = $max; 1138 } 1139 1140 $out .= pack($packer, $val); 1141 } # for rgb 1142 1143 $pix --; 1144 $w ++; 1145 if($deep eq '1d') { 1146 if(exists($$pr[$w]) and defined($$pr[$w])) { 1147 @cur = explodetriple($$pr[$w]); 1148 } else { 1149 @cur = (0,0,0); 1150 } 1151 } else { 1152 if(!exists($$pr[$h][$w])) { 1153 $w = 0; 1154 $h ++; 1155 } 1156 if(exists($$pr[$h][$w]) and defined($$pr[$h][$w])) { 1157 @cur = explodetriple($$pr[$h][$w]); 1158 } else { 1159 @cur = (0,0,0); 1160 } 1161 } 1162 } # while pix 1163 1164 return($out); 1165 1166} # end &int_encodepixels_6 1167 1168# Internal read pixels function. Does not do argument checks. 1169sub int_readpixels { 1170 my $gr = shift; # input file glob ref 1171 my $ir = shift; # image info hash ref 1172 my $pr = shift; # pixel array ref 1173 my $enc = shift; # target pixel encoding 1174 1175 # most common to least common 1176 # type 7 is PAM, not supported here (yet) 1177 if($$ir{type} == 6) { return int_readpixels_6($gr, $ir, $pr, $enc); } 1178 if($$ir{type} == 5) { return int_readpixels_5($gr, $ir, $pr, $enc); } 1179 if($$ir{type} == 4) { return int_readpixels_4($gr, $ir, $pr, $enc); } 1180 if($$ir{type} == 3) { return int_readpixels_3($gr, $ir, $pr, $enc); } 1181 if($$ir{type} == 2) { return int_readpixels_2($gr, $ir, $pr, $enc); } 1182 if($$ir{type} == 1) { return int_readpixels_1($gr, $ir, $pr, $enc); } 1183 1184 $$ir{error} = 'image type not recognized'; 1185} # end &int_readpixels 1186 1187# Internal argument check for encodepixels() and inspectpixels() 1188sub int_prelim_inspect { 1189 my $fmt = shift; 1190 my $max = shift; 1191 my $p_r = shift; 1192 my %inspect; 1193 1194 $inspect{error} = ''; 1195 1196 if($fmt =~ /^raw$/i) { 1197 $inspect{type} = 3; # will be modified later 1198 } elsif($fmt =~ /^ascii$/i) { 1199 $inspect{type} = 0; # will be modified later 1200 } else { 1201 $inspect{error} = 'invalid format'; 1202 return \%inspect; 1203 } 1204 1205 if(($max !~ /^\d+$/) or ($max < 1) or ($max > 65535)) { 1206 $inspect{error} = 'invalid max'; 1207 return \%inspect; 1208 } 1209 if($max > 255) { 1210 $inspect{bytes} = 2; 1211 } else { 1212 $inspect{bytes} = 1; 1213 } 1214 1215 if( ref($p_r) ne 'ARRAY') { 1216 $inspect{error} = 'pixels not an array'; 1217 return \%inspect; 1218 } 1219 1220 if( ref($$p_r[0]) eq '') { 1221 $inspect{deep} = '1d'; 1222 $inspect{first} = $$p_r[0]; 1223 $inspect{pixels} = 1+ $#{$p_r}; 1224 1225 } elsif(ref($$p_r[0]) eq 'ARRAY' and ref($$p_r[0][0]) eq '') { 1226 $inspect{deep} = '2d'; 1227 $inspect{first} = $$p_r[0][0]; 1228 $inspect{height} = 1+ $#{$p_r}; 1229 $inspect{width} = 1+ $#{$$p_r[0]}; 1230 $inspect{pixels} = $inspect{width} * $inspect{height}; 1231 1232 } elsif(ref($$p_r[0][0]) eq 'ARRAY' and ref($$p_r[0][0][0]) eq '') { 1233 $inspect{deep} = '3d'; 1234 $inspect{first} = $$p_r[0][0][0]; 1235 $inspect{height} = 1+ $#{$p_r}; 1236 $inspect{width} = 1+ $#{$$p_r[0]}; 1237 $inspect{pixels} = $inspect{width} * $inspect{height}; 1238 1239 } else { 1240 # too many levels? 1241 $inspect{error} = 'pixels not expected structure'; 1242 return \%inspect; 1243 } 1244 1245 if(!defined($inspect{first})) { 1246 $inspect{error} = 'first pixel undef'; 1247 return \%inspect; 1248 } 1249 if($inspect{first} =~ m!^[.0-9]+,!) { 1250 $inspect{encode} = 'float'; 1251 1252 } elsif($inspect{first} =~ m!^[0-9]+:!) { 1253 $inspect{encode} = 'dec'; 1254 1255 } elsif($inspect{first} =~ m!^[0-9a-fA-F]+/!) { 1256 $inspect{encode} = 'hex'; 1257 1258 } elsif($inspect{first} =~ m!^[01]+$!) { 1259 # for PBM 1260 $inspect{encode} = 'dec'; 1261 1262 } else { 1263 $inspect{error} = 'first pixel unrecognized'; 1264 return \%inspect; 1265 } 1266 1267 if($max == 1) { 1268 $inspect{type} += 1; # now either 1 or 4 1269 1270 } elsif($inspect{deep} eq '3d') { 1271 $inspect{type} += 3; # now either 3 or 6 1272 1273 } else { 1274 # still could be 2, 3, 5, 6 1275 if($inspect{first} =~ m!^[.0-9a-fA-F]+[,:/][.0-9a-fA-F]+[,:/][.0-9a-fA-F]+!) { 1276 $inspect{type} += 3; # now either 3 or 6 1277 } else { 1278 $inspect{type} += 2; # now either 2 or 5 1279 } 1280 } 1281 1282 return \%inspect; 1283} # end &int_prelim_inspect 1284 1285 1286=head1 FUNCTIONS 1287 1288=head2 readpnmfile( \*PNM, \%info, \@pixels, $encoding ); 1289 1290Reads from a file handle and sets hash %info with properties, 1291puts pixels into @pixels, formated as "float", "dec", or "hex". 1292The @pixels structure is an array of rows, each row being an 1293array of pixel strings. 1294 1295The %info hash has numerous properties about the source file. 1296The function itself returns 'error' for usage errors, and the 1297empty string normally. 1298 1299This function essentially chains readpnmheader(), 1300checkpnminfo(), and readpnmpixels(). 1301 1302A single file, if in the RAW format, can contain multiple 1303concatenated images. This function will only read one at a 1304time, but can be called multiple times on the same file handle. 1305 1306=over 1307 1308=item * 1309 1310$info{bgp} 1311 1312Will contain one of "b", "g", or "p" for pbm (bitmap), pgm (graymap), 1313or ppm (pixmap). This is an informational value not used by this library. 1314 1315=item * 1316 1317$info{type} 1318 1319Will contain one of "1" for ASCII PBM, "2" for ASCII PGM, "3" for 1320ASCII PPM, "4" for raw PBM, "5" for raw PGM, or "6" for raw PPM. 1321This numerical value is right out of the header of the PBM family 1322of files and is essential to understanding the pixel format. 1323 1324=item * 1325 1326$info{max} 1327 1328Will contain the max value of the image as a decimal integer. This 1329is needed to properly understand what a decimal or hexadecimal 1330pixel value means. It is used to convert raw pixel data into 1331floating point values (and back to integers). 1332 1333=item * 1334 1335$info{format} 1336 1337Will contain 'raw' or 'ascii'. 1338 1339=item * 1340 1341$info{raw} 1342 1343Will contain a true value if the file is raw encoded, and false 1344for ASCII. This is an informational value not used by this library. 1345 1346=item * 1347 1348$info{height} 1349 1350Will contain the height of the image in pixels. 1351 1352=item * 1353 1354$info{width} 1355 1356Will contain the width of the image in pixels. 1357 1358=item * 1359 1360$info{pixels} 1361 1362Will contain the number of pixels (height * width). 1363 1364=item * 1365 1366$info{comments} 1367 1368Will contain any comments found in the header, concatenated. 1369 1370=item * 1371 1372$info{fullheader} 1373 1374Will contain the complete, unparsed, header. 1375 1376=item * 1377 1378$info{error} 1379 1380Will contain an empty string if no errors occured, or an error 1381message, including usage errors. 1382 1383=back 1384 1385=cut 1386 1387# readpnmfile(\*PNM, \%imageinfo, \@pixels, 'float' ); 1388sub readpnmfile { 1389 my $f_r = shift; # file 1390 my $i_r = shift; # image info 1391 my $p_r = shift; # 2d array of pixels 1392 my $enc = shift; # encoding string 1393 1394 if('HASH' ne ref($i_r)) { 1395 # not a hash, can't return errors the normal way 1396 return 'error'; 1397 } 1398 1399 if('GLOB' ne ref($f_r)) { 1400 $$i_r{error} = 'readpnmfile: first arg not a file handle ref'; 1401 return 'error'; 1402 } 1403 1404 if('ARRAY' ne ref($p_r)) { 1405 $$i_r{error} = 'readpnmfile: third arg not an array ref'; 1406 return 'error'; 1407 } 1408 1409 if($enc =~ /^(float|dec|raw)/i) { 1410 $enc = lc($1); 1411 } else { 1412 $$i_r{error} = 'readpnmfile: fourth arg not recognized pixel encoding'; 1413 return 'error'; 1414 } 1415 1416 int_readpnmheader($f_r, $i_r); 1417 1418 if(length($$i_r{error})) { 1419 $$i_r{error} = 'readpnmfile: ' . $$i_r{error}; 1420 return ''; 1421 } 1422 1423 checkpnminfo($i_r); 1424 if(exists($$i_r{error}) and length($$i_r{error})) { 1425 $$i_r{error} = 'readpnmfile: ' . $$i_r{error}; 1426 return 'error'; 1427 } 1428 1429 int_readpixels($f_r, $i_r, $p_r, $enc); 1430 if(length($$i_r{error})) { 1431 $$i_r{error} = 'readpnmfile: ' . $$i_r{error}; 1432 } 1433 1434 return ''; 1435} # end &readpnmfile 1436 1437 1438################################################################## 1439 1440 1441=head2 checkpnminfo( \%info ) 1442 1443Checks the values in the image info hash for completeness. Used 1444internally between reading the header and reading the pixels of 1445an image, but might be useful generally. Expects to find numerical 1446values for type, pixels, max, width, and height. 1447 1448=cut 1449 1450sub checkpnminfo { 1451 my $i_r = shift; # image info 1452 1453 if((!exists($$i_r{type}) or ($$i_r{type} !~ /^\d/)) or 1454 (!exists($$i_r{pixels}) or ($$i_r{pixels} !~ /^\d/)) or 1455 (!exists($$i_r{max}) or ($$i_r{max} !~ /^\d/)) or 1456 (!exists($$i_r{width}) or ($$i_r{width} !~ /^\d/)) or 1457 (!exists($$i_r{height}) or ($$i_r{height} !~ /^\d/)) ) { 1458 $$i_r{error} = 'image info incomplete'; 1459 return 'error'; 1460 } 1461} # end &checkheader 1462 1463 1464 1465################################################################## 1466 1467 1468 1469=head2 readpnminfo( \*PNM, \%info ) 1470 1471Reads just the header of a PBM/PGM/PPM file from the file handle 1472and populates the image info hash. See C<readpnmfile> for a 1473description of the image info hash. Returns the string 'error' 1474if there is an problem, and the empty string otherwise. Sets 1475the $info{error} value with an error string. 1476 1477=cut 1478 1479sub readpnmheader { 1480 my $f_r = shift; # file 1481 my $i_r = shift; # image info 1482 1483 if('HASH' ne ref($i_r)) { 1484 # not a hash, can't return errors the normal way 1485 return 'error'; 1486 } 1487 1488 if('GLOB' ne ref($f_r)) { 1489 $$i_r{error} = 'readpnmfile: first arg not a file handle ref'; 1490 return 'error'; 1491 } 1492 1493 int_readpnmheader($f_r, $i_r); 1494 1495 if(length($$i_r{error})) { 1496 $$i_r{error} = 'readpnmheader: ' . $$i_r{error}; 1497 return ''; 1498 } 1499 1500 checkpnminfo($i_r); 1501 if(exists($$i_r{error}) and length($$i_r{error})) { 1502 $$i_r{error} = 'readpnmheader: ' . $$i_r{error}; 1503 return 'error'; 1504 } 1505 1506 return ''; 1507} # end &readpnmheader 1508 1509 1510 1511################################################################## 1512 1513 1514=head2 readpnmpixels( \*PNM, \%info, \@pixels, $encoding ) 1515 1516Reads just the pixels of a PBM/PGM/PPM file from the file handle 1517and populates the pixels array. See C<readpnmfile> for a 1518description of the image info hash, pixel array output format, 1519and encoding details. Returns 'error' if there is an problem, and 1520the empty string otherwise. Sets the $info{error} value with an 1521error string. 1522 1523=cut 1524 1525sub readpnmpixels { 1526 my $g_r = shift; # input file glob ref 1527 my $i_r = shift; # image info hash ref 1528 my $p_r = shift; # pixel array ref 1529 my $enc = shift; # target pixel encoding 1530 1531 if('HASH' ne ref($i_r)) { 1532 # not a hash, can't return errors the normal way 1533 return 'error'; 1534 } 1535 1536 if('GLOB' ne ref($g_r)) { 1537 $$i_r{error} = 'readpnmpixels: first arg not a file handle ref'; 1538 return 'error'; 1539 } 1540 1541 if('ARRAY' ne ref($p_r)) { 1542 $$i_r{error} = 'readpnmpixels: third arg not an array ref'; 1543 return 'error'; 1544 } 1545 1546 if($enc =~ /^(float|dec|raw)/i) { 1547 $enc = lc($1); 1548 } else { 1549 $$i_r{error} = 'readpnmpixels: fourth arg not recognized pixel encoding'; 1550 return 'error'; 1551 } 1552 1553 checkpnminfo($i_r); 1554 if(exists($$i_r{error}) and length($$i_r{error})) { 1555 $$i_r{error} = 'readpnmpixels: ' . $$i_r{error}; 1556 return 'error'; 1557 } 1558 1559 int_readpixels($g_r,$i_r,$p_r,$enc); 1560 if(exists($$i_r{error}) and length($$i_r{error})) { 1561 $$i_r{error} = 'readpnmpixels: ' . $$i_r{error}; 1562 return 'error'; 1563 } 1564 1565 return ''; 1566} # end &readpnmpixels 1567 1568 1569 1570################################################################## 1571 1572 1573=head2 $float_pixel = hextripletofloat( $hex_pixel, $max ) 1574 1575=head2 $float_pixel = hextripletofloat( \@hex_pixel, $max ) 1576 1577For a pixel string with hex red green and blue values separated by 1578slashes (R/G/B to RRRR/GGGG/BBBB) or an array of hex values, and a 1579of max 1 to 65535, convert to the comma separated floating point 1580pixel format. 1581 1582No error is returned if $max is outside of the allowed range, but 0 1583will kill the program. Any value larger than max is clipped. 1584 1585C<$hex_pixel> can be a scalar or an array ref (eg C<\@triple>) and 1586C<$float_pixel> can be a scalar or an array (eg C<@triple>). 1587 1588Returns undef if $hex_pixel is malformed. 1589 1590=cut 1591 1592sub hextripletofloat { 1593 my $trip = shift; 1594 my $max = shift; 1595 my $rgb = undef; 1596 my @val; 1597 1598 if(wantarray()) { 1599 my @set; 1600 1601 if(ref($trip) eq 'ARRAY') { 1602 @val = ( $$trip[0], $$trip[1], $$trip[2]); 1603 map { s:/$:: } @val; 1604 1605 } elsif($trip =~ m:^([0-9a-fA-F]+)/([0-9a-fA-F]+)/([0-9a-fA-F]+)/?$:) { 1606 @val = ( $1, $2, $3 ); 1607 } 1608 1609 @set = ( int_decvaltofloat(hex($val[0]), $max), 1610 int_decvaltofloat(hex($val[1]), $max), 1611 int_decvaltofloat(hex($val[2]), $max) ); 1612 return @set; 1613 } 1614 1615 if(ref($trip) eq 'ARRAY') { 1616 @val = ( $$trip[0], $$trip[1], $$trip[2]); 1617 map { s:/$:: } @val; 1618 $rgb = int_dectripletofloat(hex($val[0]), 1619 hex($val[1]), 1620 hex($val[2]), $max) 1621 } elsif($trip =~ m:^([0-9a-fA-F]+)/([0-9a-fA-F]+)/([0-9a-fA-F]+)/?$:) { 1622 $rgb = int_dectripletofloat(hex($1), hex($2), hex($3), $max); 1623 } 1624 return $rgb; 1625} # end hextripletofloat 1626 1627 1628 1629################################################################## 1630 1631 1632=head2 $float_pixel = dectripletofloat( $dec_pixel, $max ) 1633 1634=head2 $float_pixel = dectripletofloat( \@dec_pixel, $max ) 1635 1636For a pixel string with decimal red green and blue values separated by 1637colons (eg R:G:B), or an array of decimal values, and a max of 1 to 65535, 1638convert to the comma separated floating point pixel format. 1639 1640No error is returned if $max is outside of the allowed range, but 0 will 1641kill the program. Any value larger than max is clipped. 1642 1643C<$dec_pixel> can be a scalar or an array ref (eg C<\@triple>) and 1644C<$float_pixel> can be a scalar or an array (eg C<@triple>). 1645 1646Returns undef if $dec_pixel is malformed. 1647 1648=cut 1649 1650# R:G:B, max 1 to 65535 1651sub dectripletofloat { 1652 my $trip = shift; 1653 my $max = shift; 1654 my $rgb = undef; 1655 1656 if(wantarray()) { 1657 my @set; 1658 1659 if(ref($trip) eq 'ARRAY') { 1660 @set = ( int_decvaltofloat($$trip[0], $max), 1661 int_decvaltofloat($$trip[1], $max), 1662 int_decvaltofloat($$trip[2], $max) ); 1663 1664 } elsif($trip =~ m/^(\d+):(\d+):(\d+):?$/) { 1665 @set = ( int_decvaltofloat($1, $max), 1666 int_decvaltofloat($2, $max), 1667 int_decvaltofloat($3, $max) ); 1668 } 1669 return @set; 1670 } 1671 1672 if(ref($trip) eq 'ARRAY') { 1673 $rgb = int_dectripletofloat($$trip[0], 1674 $$trip[1], 1675 $$trip[2], $max); 1676 } elsif($trip =~ m/^(\d+):(\d+):(\d+):?$/) { 1677 $rgb = int_dectripletofloat($1, $2, $3, $max); 1678 } 1679 return $rgb; 1680} 1681 1682 1683 1684################################################################## 1685 1686 1687=head2 $float_pixel = hexvaltofloat( $hex_val, $max ) 1688 1689For a pixel value in hexadecimal and a max of 1 to 65535, 1690convert to the comma separated floating point pixel value format. 1691 1692No error is returned if $max is outside of the allowed range, but 0 will 1693kill the program. Any value larger than max is clipped. 1694 1695Returns undef if $hex_pixel is malformed. 1696 1697=cut 1698 1699sub hexvaltofloat { 1700 my $val = shift; 1701 my $max = shift; 1702 my $fl = undef; 1703 1704 # allow trailing slash, since we use them 1705 if($val =~ m:^([a-fA-F0-9]+)/?$:) { 1706 $fl = int_decvaltofloat(hex($1), $max); 1707 } 1708 1709 return $fl; 1710} # end &hexvaltofloat 1711 1712 1713 1714################################################################## 1715 1716 1717=head2 $float_pixel = decvaltofloat( $dec_val, $max ) 1718 1719For a pixel value in decimal and a max of 1 to 65535, 1720convert to the comma separated floating point pixel value format. 1721 1722No error is returned if $max is outside of the allowed range, but 0 will 1723kill the program. Any value larger than max is clipped. 1724 1725Returns undef if $dec_pixel is malformed. 1726 1727=cut 1728 1729sub decvaltofloat { 1730 my $val = shift; 1731 my $max = shift; 1732 my $fl = undef; 1733 1734 # allow trailing colon, since we use them 1735 if($val =~ /^(\d+):?$/) { 1736 $fl = int_decvaltofloat($1, $max); 1737 } 1738 1739 return $fl; 1740} # end &decvaltofloat 1741 1742 1743 1744################################################################## 1745 1746 1747=head2 $dec_pixel = floattripletodec( \@float_pixel, $max ) 1748 1749=head2 $dec_pixel = floattripletodec( $float_pixel, $max ) 1750 1751For a pixel string with floating red green and blue values separated by 1752commas (eg R:G:B), and max 1 to 65535, convert to the colon separated 1753decimal pixel format. No error is returned 1754if $max is outside of the allowed range, but 0 will kill the program. 1755Any value larger than max is clipped. 1756 1757C<$float_pixel> can be a scalar or an array ref (eg C<\@triple>) and 1758C<$dec_pixel> can be a scalar or an array (eg C<@triple>). 1759 1760Returns undef if $float_pixel is malformed. 1761 1762=cut 1763 1764sub floattripletodec { 1765 my $trip = shift; 1766 my $max = shift; 1767 my $rgb = undef; 1768 1769 if(wantarray()) { 1770 my @set; 1771 1772 if(ref($trip) eq 'ARRAY') { 1773 @set = ( int_floatvaltodec($$trip[0], $max), 1774 int_floatvaltodec($$trip[1], $max), 1775 int_floatvaltodec($$trip[2], $max) ); 1776 1777 } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) { 1778 @set = ( int_floatvaltodec($1, $max), 1779 int_floatvaltodec($2, $max), 1780 int_floatvaltodec($3, $max) ); 1781 } 1782 return @set; 1783 } 1784 1785 if(ref($trip) eq 'ARRAY') { 1786 $rgb = int_floattripletodec($$trip[0], 1787 $$trip[1], 1788 $$trip[2], $max); 1789 } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) { 1790 $rgb = int_floattripletodec($1, $2, $3, $max); 1791 } 1792 return $rgb; 1793 1794} # end &floattripletodec 1795 1796 1797 1798################################################################## 1799 1800 1801=head2 $hex_pixel = floattripletohex( \@float_pixel, $max ) 1802 1803=head2 $hex_pixel = floattripletohex( $float_pixel, $max ) 1804 1805For a pixel string with floating red green and blue values separated by 1806commas (eg R:G:B), and max 1 to 65535, convert to the slash separated 1807hex pixel format. No error is returned 1808if $max is outside of the allowed range, but 0 will kill the program. 1809Any value larger than max is clipped. 1810 1811C<$float_pixel> can be a scalar or an array ref (eg C<\@triple>) and 1812C<$hex_pixel> can be a scalar or an array (eg C<@triple>). 1813 1814Returns undef if $float_pixel is malformed. 1815 1816=cut 1817 1818sub floattripletohex { 1819 my $trip = shift; 1820 my $max = shift; 1821 my $rgb = undef; 1822 1823 if(wantarray()) { 1824 my @set; 1825 1826 if(ref($trip) eq 'ARRAY') { 1827 @set = ( int_floatvaltohex($$trip[0], $max), 1828 int_floatvaltohex($$trip[1], $max), 1829 int_floatvaltohex($$trip[2], $max) ); 1830 1831 } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) { 1832 @set = ( int_floatvaltohex($1, $max), 1833 int_floatvaltohex($2, $max), 1834 int_floatvaltohex($3, $max) ); 1835 } 1836 return @set; 1837 } 1838 1839 if(ref($trip) eq 'ARRAY') { 1840 $rgb = int_floattripletohex($$trip[0], 1841 $$trip[1], 1842 $$trip[2], $max); 1843 } elsif($trip =~ m/^([.\d+]),([.\d+]),([.\d+]),?$/) { 1844 $rgb = int_floattripletohex($1, $2, $3, $max); 1845 } 1846 return $rgb; 1847 1848} # end &floattripletodec 1849 1850 1851 1852################################################################## 1853 1854 1855=head2 $dec_pixel = floatvaltodec( $float_pixel, $max ) 1856 1857For a floating point pixel value and max 1 to 65535, convert to the decimal 1858pixel format. No error is returned 1859if $max is outside of the allowed range, but 0 will kill the program. 1860Any value larger than max is clipped. 1861 1862Returns undef if $float_pixel is malformed. 1863 1864=cut 1865 1866sub floatvaltodec { 1867 my $trip = shift; 1868 my $max = shift; 1869 my $p = undef; 1870 1871 $p = int_floatvaltodec($trip, $max); 1872 1873 return $p; 1874 1875} # end &floatvaltodec 1876 1877 1878 1879################################################################## 1880 1881 1882=head2 $hex_pixel = floatvaltohex( $float_pixel, $max ) 1883 1884For a floating point pixel value and max 1 to 65535, convert to the hexadecimal 1885pixel format. No error is returned 1886if $max is outside of the allowed range, but 0 will kill the program. 1887Any value larger than max is clipped. 1888 1889Returns undef if $float_pixel is malformed. 1890 1891=cut 1892 1893sub floatvaltohex { 1894 my $trip = shift; 1895 my $max = shift; 1896 my $p = undef; 1897 1898 $p = int_floatvaltohex($trip, $max); 1899 1900 return $p; 1901 1902} # end &floatvaltohex 1903 1904 1905 1906################################################################## 1907 1908 1909=head2 $status = comparefloattriple(\@a, \@b) 1910 1911=head2 $status = comparefloattriple($a, $b) 1912 1913Returns -1, 0, or 1 much like <=>, but allows a variance of up 1914to half 1/65535. Checks only a single pair at a time (red value 1915of $a to red value of $b, etc) and stops at the first obvious 1916non-equal value. Does not check if any value is outside of 0.0 1917to 1.0. Returns undef if either triple can't be understood. 1918 1919=cut 1920 1921sub comparefloattriple { 1922 my $a = shift; 1923 my $b = shift; 1924 my $v; 1925 1926 my $a_r; my $a_g; my $a_b; 1927 my $b_r; my $b_g; my $b_b; 1928 1929 ($a_r, $a_g, $a_b) = explodetriple($a); 1930 ($b_r, $b_g, $b_b) = explodetriple($b); 1931 1932 if(!defined($a_r) or !defined($b_r)) { return undef; } 1933 1934 $v = comparefloatval($a_r, $b_r); 1935 if($v) { return $v; } 1936 1937 $v = comparefloatval($a_g, $b_g); 1938 if($v) { return $v; } 1939 1940 $v = comparefloatval($a_b, $b_b); 1941 return $v; 1942} # end &comparefloattriple 1943 1944 1945 1946################################################################## 1947 1948 1949=head2 $status = comparefloatval($a, $b) 1950 1951Returns -1, 0, or 1 much like <=>, but allows a variance of up 1952to half 1/65535. Checks only a single pair (not an RGB triple), 1953does not check if either value is outside of 0.0 to 1.0. 1954 1955=cut 1956 1957sub comparefloatval { 1958 my $a = shift; 1959 my $b = shift; 1960 # 1/65535 ~ .0000152590; .0000152590 / 2 = .0000076295 1961 my $alpha = 0.0000076295; 1962 1963 # eat our own dog food for indicating a float value 1964 $a =~ s/,$//; 1965 $b =~ s/,$//; 1966 1967 my $low_a = $a - $alpha; 1968 my $hi_a = $a + $alpha; 1969 1970 if($low_a > $b) { return 1; } 1971 if($hi_a < $b) { return -1; } 1972 1973 return 0; 1974} # end &comparefloatval 1975 1976 1977################################################################## 1978 1979=head2 $status = comparepixelval($a, $max_a, $b, $max_b) 1980 1981Returns -1, 0, or 1 much like <=>, taking into account that 1982each is really a fraction: C<$v / $max_v>. Decimal values should 1983have a colon (eg "123:"), while hex values should have a slash 1984(eg "7B/"). Uses integer comparisions and should not be used with 1985floating point values. Max should always be a regular decimal integer. 1986Checks only a single pair (not an RGB triple), 1987does not enforce checks on the max values. 1988 1989This is a less forgiving comparison than C<comparefloatval()>. 1990 1991=cut 1992 1993sub comparepixelval { 1994 my $a = shift; 1995 my $a_m = shift; 1996 my $b = shift; 1997 my $b_m = shift; 1998 1999 # eat our own dog food for indicating a dec / hex value 2000 if($a =~ s:/$::) { 2001 $a = hex($a); 2002 } else { 2003 $a =~ s/:$//; 2004 } 2005 if($b =~ s:/$::) { 2006 $b = hex($b); 2007 } else { 2008 $b =~ s/:$//; 2009 } 2010 2011 if($a_m == $b_m) { 2012 return ($a <=> $b); 2013 } 2014 2015 # simple way to get to common denominator 2016 $a = $a * $b_m; 2017 $b = $b * $a_m; 2018 2019 return ($a <=> $b); 2020} # end &comparepixelval 2021 2022 2023################################################################## 2024 2025=head2 $status = comparepixeltriple(\@a, $max_a, \@b, $max_b) 2026 2027=head2 $status = comparepixeltriple($a, $max_a, $b, $max_b) 2028 2029Returns -1, 0, or 1 much like <=>, taking into account that 2030RGB each is really a fraction: C<$v / $max_v>. Decimal values should 2031be colon separated (eg "123:1:1024" or terminated ["123:", "1:", "1024:"]), 2032while hex values should have slashes 2033(eg "7B/1/400" or ["7B/", "1/", "400/"]). Uses integer comparisions and 2034should not be used with floating point values. Max should always be a 2035regular decimal integer. Checks only a single pair at a time (red value 2036of $a to red value of $b, etc) and stops at the first obvious 2037non-equal value. Does not enforce checks on the max values. 2038Returns undef if either triple can't be understood. 2039 2040This is a less forgiving comparison than C<comparefloattriple()>. 2041 2042=cut 2043 2044sub comparepixeltriple { 2045 my $a = shift; 2046 my $a_m = shift; 2047 my $b = shift; 2048 my $b_m = shift; 2049 my $v; 2050 2051 my $a_r; my $a_g; my $a_b; 2052 my $b_r; my $b_g; my $b_b; 2053 2054 ($a_r, $a_g, $a_b) = explodetriple($a); 2055 ($b_r, $b_g, $b_b) = explodetriple($b); 2056 2057 if(!defined($a_r) or !defined($b_r)) { return undef; } 2058 2059 # eat our own dog food for indicating a dec / hex value 2060 if($a_r =~ s:/$::) { $a_r = hex($a_r); } else { $a_r =~ s/:$//; } 2061 if($a_g =~ s:/$::) { $a_g = hex($a_g); } else { $a_g =~ s/:$//; } 2062 if($a_b =~ s:/$::) { $a_b = hex($a_b); } else { $a_b =~ s/:$//; } 2063 if($b_r =~ s:/$::) { $b_r = hex($b_r); } else { $b_r =~ s/:$//; } 2064 if($b_g =~ s:/$::) { $b_g = hex($b_g); } else { $b_g =~ s/:$//; } 2065 if($b_b =~ s:/$::) { $b_b = hex($b_b); } else { $b_b =~ s/:$//; } 2066 2067 if($a_m == $b_m) { 2068 return (($a_r <=> $b_r) or ($a_g <=> $b_g) or ($a_b <=> $b_b)); 2069 } 2070 2071 # simple way to get to common denominator 2072 $a_r = $a_r * $b_m; 2073 $b_r = $b_r * $a_m; 2074 2075 $v = ($a_r <=> $b_r); 2076 if($v) { return $v; } 2077 2078 $a_g = $a_g * $b_m; 2079 $b_g = $b_g * $a_m; 2080 2081 $v = ($a_g <=> $b_g); 2082 if($v) { return $v; } 2083 2084 $a_b = $a_b * $b_m; 2085 $b_b = $b_b * $a_m; 2086 2087 return ($a_g <=> $b_g); 2088 2089} # end &comparepixeltriple 2090 2091 2092################################################################## 2093 2094=head2 ($r, $g, $b) = explodetriple( \@pixel ); 2095 2096=head2 ($r, $g, $b) = explodetriple( $pixel ); 2097 2098Helper function to separate the values of an RGB pixel, either in 2099array or string format. Float pixels have comma separated triples, 2100and comma suffixed single values. Decimal pixels use colons, and 2101hex pixels use slashes. Does not enforce values to be within the 2102allowed range. 2103 2104Returns undef if the pixel could not be understood. 2105 2106=cut 2107 2108sub explodetriple { 2109 my $a = shift; 2110 my $a_r; 2111 my $a_g; 2112 my $a_b; 2113 2114 if(ref($a) eq 'ARRAY') { 2115 $a_r = $$a[0]; 2116 $a_g = $$a[1]; 2117 $a_b = $$a[2]; 2118 } else { 2119 if($a =~ m/^(\d+):(\d+):(\d+):?$/) { 2120 $a_r = $1 .':'; 2121 $a_g = $2 .':'; 2122 $a_b = $3 .':'; 2123 } elsif ($a =~ m:^([0-9a-fA-F]+)/([0-9a-fA-F]+)/([0-9a-fA-F]+)/?$:) { 2124 $a_r = $1 .'/'; 2125 $a_g = $2 .'/'; 2126 $a_b = $3 .'/'; 2127 } elsif ($a =~ m/^([.0-9]+),([.0-9]+),([.0-9]+),?$/) { 2128 $a_r = $1 .','; 2129 $a_g = $2 .','; 2130 $a_b = $3 .','; 2131 } else { 2132 return undef; 2133 } 2134 } 2135 2136 return ($a_r, $a_g, $a_b); 2137 2138} # end &explodetriple 2139 2140 2141################################################################## 2142 2143=head2 @pixel = rescaletriple( \@pixel, $old_max, $new_max ); 2144 2145=head2 $pixel = rescaletriple( $pixel, $old_max, $new_max ); 2146 2147Helper function to rescale the values of an RGB pixel to a new max 2148value, either in array or string format. Float pixels do not need 2149rescaling. Decimal pixels use colons as separator / suffix, and 2150hex pixels use slashes. Does not enforce values to be within the 2151allowed range. 2152 2153Returns undef if the pixel could not be understood. 2154 2155=cut 2156 2157sub rescaletriple { 2158 my $p = shift; 2159 my $o_m = shift; 2160 my $n_m = shift; 2161 my $p_r; 2162 my $p_g; 2163 my $p_b; 2164 my $enc; 2165 my $r; 2166 2167 ($p_r, $p_g, $p_b) = explodetriple($p); 2168 2169 if(!defined($p_r)) { return undef; } 2170 2171 if($p_r =~ /:/) { 2172 $enc = 'dec'; 2173 } elsif ($p_r =~ m:/:) { 2174 $enc = 'hex'; 2175 } 2176 2177 # undef if it was a float triple 2178 if(defined($enc)) { 2179 $p_r = rescaleval($p_r, $o_m, $n_m); 2180 $p_g = rescaleval($p_g, $o_m, $n_m); 2181 $p_b = rescaleval($p_b, $o_m, $n_m); 2182 } 2183 2184 if(wantarray()) { 2185 return ($p_r, $p_g, $p_b); 2186 } else { 2187 $r = "$p_r$p_g$p_b"; 2188 chop $r; 2189 return $r; 2190 } 2191 2192} # end &rescaletriple 2193 2194 2195################################################################## 2196 2197 2198=head2 $value = rescaleval( $value, $old_max, $new_max ); 2199 2200Helper function to rescale a single value to a new max 2201value, either in array or string format. Float values do not need 2202rescaling. Decimal values use colons as suffix, and 2203hex values use slashes. Does not enforce values to be within the 2204allowed range. 2205 2206Returns undef if the value could not be understood. 2207 2208=cut 2209 2210sub rescaleval { 2211 my $v = shift; 2212 my $o_m = shift; 2213 my $n_m = shift; 2214 my $r; 2215 2216 if($o_m == $n_m) { 2217 # no change 2218 return $v; 2219 } 2220 2221 if($v =~ /:$/) { 2222 $v =~ s/:$//; 2223 2224 $r = int_floatvaltodec( ($v / $o_m), $n_m); 2225 } elsif ($v =~ m:/$:) { 2226 $v =~ s:/$::; $v = hex($v); 2227 2228 $r = int_floatvaltohex( ($v / $o_m), $n_m); 2229 } elsif ($v =~ m/,$/) { 2230 # no change 2231 return $v; 2232 } else { 2233 return undef; 2234 } 2235 2236 return $r; 2237} # end &rescaleval 2238 2239 2240 2241################################################################## 2242 2243 2244=head2 $header = makepnmheader( \%info ); 2245 2246=head2 $header = makepnmheader($type, $width, $height, $max); 2247 2248Takes a hash reference similar to C<readpnmheader()> or 2249C<readpnmfile> would return and makes a PBM, PGM, or PPM header string 2250from it. C<makeppmheader> first looks for a B<type> in the hash and 2251uses that, otherwise it expects B<bgp> and B<format> to be set in the hash 2252(and it will set B<type> for you then). If there is a non-empty 2253B<comments> in the hash, that will be put in as one or more lines 2254of comments. There must be sizes for B<width> and B<height>, and if 2255the image is not a bitmap, there should be one for B<max>. A missing 2256B<max> will result in C<makeppmheader> guessing 255 and setting 2257B<max> accordingly. 2258 2259The numerical types are 1 for ASCII PBM, 2 for ASCII PGM, 3 for 2260ASCII PPM, 4 for raw PBM, 5 for raw PGM, and 6 for raw PPM. The 2261maxvalue is ignored for PBM files. 2262 2263Returns the header string if successful. 2264Returns undef if there is an error. 2265 2266=cut 2267 2268sub makepnmheader { 2269 my $type; 2270 my $w; 2271 my $h; 2272 my $max; 2273 2274 my $hr = shift; # header hash ref 2275 my $head = ''; 2276 my $com = ''; 2277 my $setmax; 2278 2279 if(ref($hr) ne 'HASH') { 2280 $type = $hr; 2281 $w = shift; 2282 $h = shift; 2283 $max = shift; 2284 2285 if(!defined($type) or !defined($w) or !defined($h)) { 2286 return undef; 2287 } 2288 2289 if($type !~ /^[123456]$/) { 2290 return undef; 2291 } 2292 if($w !~ /^\d+$/) { 2293 return undef; 2294 } 2295 if($h !~ /^\d+$/) { 2296 return undef; 2297 } 2298 2299 } else { 2300 2301 if (defined($$hr{width}) and $$hr{width} =~ /^\d+$/) { 2302 $w = $$hr{width}; 2303 } else { 2304 return undef; 2305 } 2306 2307 if (defined($$hr{height}) and $$hr{height} =~ /^\d+$/) { 2308 $h = $$hr{height}; 2309 } else { 2310 return undef; 2311 } 2312 2313 if (defined($$hr{max}) and $$hr{max} =~ /^\d+$/) { 2314 $max = $$hr{max}; 2315 } else { 2316 $max = 255; 2317 $setmax = 1; 2318 } 2319 2320 if (defined($$hr{type}) and $$hr{type} =~ /^[123456]$/) { 2321 $type = $$hr{type}; 2322 2323 } elsif(defined($$hr{bgp}) and defined($$hr{format}) and 2324 $$hr{bgp} =~ /^([bgp])$/i) { 2325 2326 my $bgp = lc($1); 2327 if ($bgp eq 'b') { 2328 $type = 1; 2329 } elsif ($bgp eq 'g') { 2330 $type = 2; 2331 } else { 2332 $type = 3; 2333 } 2334 2335 if ($$hr{format} =~ /raw/i) { 2336 $type += 3; 2337 } elsif ($$hr{format} !~ /ascii/i) { 2338 return undef; 2339 } 2340 2341 $$hr{type} = $type; 2342 } else { 2343 return undef; 2344 } 2345 2346 if(defined($$hr{comments}) and length($$hr{comments})) { 2347 $com = $$hr{comments}; 2348 $com =~ s/^/#/gm; 2349 if(substr($com, -1, 1) ne "\n") { 2350 $com .= "\n"; 2351 }; 2352 } 2353 2354 } 2355 2356 if($w < 1 or $h < 1) { 2357 return undef; 2358 } 2359 2360 $head = "P$type\n$com"; 2361 $head .= "$w $h\n"; 2362 2363 if($type != 1 and $type != 4) { 2364 if(!defined($max) or $max < 1 or $max > 65535) { 2365 return undef; 2366 } 2367 $head .= "$max\n"; 2368 if($setmax) { 2369 $$hr{max} = $max; 2370 } 2371 } 2372 2373 return $head; 2374} # end &makepnmheader 2375 2376################################################################## 2377 2378 2379=head2 $block = encodepixels($format, $max, \@pixels); 2380 2381Encodes pixels into 'raw' or 'ascii' PBM/PGM/PPM format. The 2382supplied pixels can be decimal, hex, or floating point values. 2383Decimal and hex values greater than $max will be clipped to $max. 2384A $max of 1 will encode a PBM file, otherwise the first pixel 2385will be examined to determine if it is PGM or PPM data. 2386 2387The array of pixels can be one, two, or three dimensional. A 2388two dimensional array is prefered and will be considered to 2389be same format C<readpnmfile()> and C<readpnmpixels()> uses. 2390There, the @pixels structure is an array of rows, each row 2391being an array of pixel strings. This function will expect 2392every row to have the same number of pixels as the first. If 2393subsequent rows have different amounts, the results can be 2394unpredictable. Missing values will be assumed to be 0 if it 2395it tries to read past the end of the array. 2396 2397A three dimensional @pixels structure is considered to be an 2398array of rows, each row being an array of PPM pixel values. 2399 2400A one dimensional @pixels structure is an array of pixel strings 2401with no hint of row and column structure. 2402With a one dimensional array, raw PBM files will be 2403misencoded if number of columns is not a multiple of 8 and the data 2404represents more than one row: each row is supposed to be padded to 2405a multiple of 8 bits. 2406 2407Returns undef if $encoding is not recognized, $max is out of bounds 2408(1 to 65535, inclusive), or @pixels cannot be understood. 2409 2410=cut 2411 2412# $block = encodepixels($encoding, $max, \@pixels); 2413sub encodepixels { 2414 my $fmt = shift; 2415 my $max = shift; 2416 my $p_r = shift; 2417 my $i; 2418 2419 $i = int_prelim_inspect($fmt, $max, $p_r); 2420 2421 if(exists($$i{error}) and length($$i{error})) { 2422 # we don't return a meaningful error 2423 return undef; 2424 } 2425 2426 return int_encodepixels($$i{type}, $p_r, $$i{deep}, $$i{encode}, $max); 2427} # end &encodepixels 2428 2429 2430################################################################## 2431 2432 2433=head2 $return = writepnmfile(\*PNM, \%info, \@pixels); 2434 2435Writes an entire PNM image to a given filehandle. Sometimes more 2436memory efficient than a C<makepnmheader()> C<encodepixels()> pair 2437(by encoding row by row when possible). Does not do an C<inspectpixels()>. 2438 2439Writes are done using C<syswrite()> so see that the documentation for 2440that function for warnings about mixing with other file operations. 2441 2442Returns undef if $encoding is not recognized, $max is out of bounds 2443(1 to 65535, inclusive), or @pixels cannot be understood. Returns 2444number of bytes written with positive values for complete success, 24450 for no bytes successfully written, and -1 * bytes written for 2446a partial success (eg, ran out of disk space). 2447 2448=cut 2449 2450# $return = writepnmfile(\*PNM, \%info, \@pixels); 2451sub writepnmfile { 2452 my $f_r = shift; # file 2453 my $i_r = shift; # image info 2454 my $p_r = shift; # array of pixels 2455 my $header; 2456 my $inspect; 2457 my $fmt; 2458 my $max; 2459 my $encode; 2460 my $deep; 2461 my $type; 2462 my $bytes; 2463 my $rc; 2464 my $row; 2465 my $pixels; 2466 2467 if((ref($f_r) ne 'GLOB') or (ref($i_r) ne 'HASH') or (ref($p_r) ne 'ARRAY')) { 2468 return undef; 2469 } 2470 2471 $header = makepnmheader($i_r); 2472 if(!defined($header)) { 2473 return undef; 2474 } 2475 2476 $fmt = $$i_r{format}; 2477 $max = $$i_r{max}; 2478 2479 if(!defined($fmt)) { 2480 if($$i_r{type} > 3) { 2481 $fmt = 'raw'; 2482 } else { 2483 $fmt = 'ascii'; 2484 } 2485 } 2486 $inspect = int_prelim_inspect($fmt, $max, $p_r); 2487 2488 if(exists($$inspect{error}) and length($$inspect{error})) { 2489 # last undef case 2490 return undef; 2491 } 2492 2493 $encode = $$inspect{encode}; 2494 $deep = $$inspect{deep}; 2495 $type = $$inspect{type}; 2496 2497 $rc = syswrite($f_r, $header); 2498 if($rc != length($header)) { 2499 return ($rc * -1); 2500 } 2501 $bytes = $rc; 2502 2503 if($deep eq '1d') { 2504 # oh well, have to encode it all 2505 $pixels = int_encodepixels($type, $p_r, $deep, $encode, $max); 2506 $rc = syswrite($f_r, $pixels); 2507 $bytes += $rc; 2508 if($rc != length($pixels)) { 2509 return ($bytes * -1); 2510 } 2511 return $bytes; 2512 } 2513 2514 for $row (@$p_r) { 2515 $pixels = int_encodepixels($type, [ $row ], $deep, $encode, $max); 2516 $rc = syswrite($f_r, $pixels); 2517 $bytes += $rc; 2518 if($rc != length($pixels)) { 2519 return ($bytes * -1); 2520 } 2521 } 2522 2523 return $bytes; 2524} # end &writepnmfile 2525 2526################################################################## 2527 2528 2529=head2 inspectpixels($format, $max, \@pixels, \%report ); 2530 2531Performs all of the argument checks of C<encodepixels()>, and 2532if no errors are found it does a thorough inspection all pixels 2533looking for inconsitencies. 2534 2535Returns undef if there was an error, and the number of pixels 2536if it succeeded. (An image with no pixels is considered an error.) 2537The report hash will contain information gleaned from the inspection. 2538 2539=over 2540 2541=item * 2542 2543$report{error} 2544 2545Set if there is an error with a description of the problem. 2546 2547=item * 2548 2549$report{where} 2550 2551Set if there is an error with the array coordinates of the problem. 2552 2553=item * 2554 2555$report{deep} 2556 2557Set to '1d', '2d', or '3d' to describe the pixel array. 2558 2559=item * 2560 2561$report{width} 2562 2563Width of the pixel array (if not '1d' deep). 2564 2565=item * 2566 2567$report{height} 2568 2569Height of the pixel array (if not '1d' deep). 2570 2571=item * 2572 2573$report{pixels} 2574 2575Expected number pixels. 2576 2577=item * 2578 2579$report{bytes} 2580 2581Number of bytes needed to encode each pixel, if in raw. Will be 1 2582for PBM files. 2583 2584=item * 2585 2586$report{encode} 2587 2588The 'float', 'dec', or 'hex' encoding of the first pixel. All others 2589are expected to match this. 2590 2591=item * 2592 2593$report{first} 2594 2595First pixel found. 2596 2597=item * 2598 2599$report{type} 2600 2601The numerical type of the format. Might be wrong if B<$report{first}> 2602is unset. Will contain one of "1" for ASCII PBM, "2" for ASCII PGM, "3" for 2603ASCII PPM, "4" for raw PBM, "5" for raw PGM, or "6" for raw PPM. 2604 2605=item * 2606 2607$report{checked} 2608 2609Number of pixels checked. 2610 2611=back 2612 2613=cut 2614 2615sub inspectpixels { 2616 my $fmt = shift; 2617 my $max = shift; 2618 my $p_r = shift; 2619 my $i_r = shift; 2620 2621 # int_prelim_inspect returns a hash ref 2622 %$i_r = %{int_prelim_inspect($fmt, $max, $p_r)}; 2623 2624 if(exists($$i_r{error}) and length($$i_r{error})) { 2625 # the inspection report error explains the problem 2626 return undef; 2627 } 2628 2629 my $w = 0; 2630 my $h = 0; 2631 my $checked = 0; 2632 my $cur; 2633 my @rgb; 2634 2635 if($$i_r{deep} eq '1d') { $cur = $$p_r[$w]; } 2636 else { $cur = $$p_r[$h][$w]; } 2637 2638 CHECK_ALL: 2639 while(defined($cur)) { 2640 2641 if($$i_r{deep} eq '3d') { 2642 if(ref($cur) ne 'ARRAY') { 2643 $$i_r{error} = 'rgb pixel not array'; 2644 2645 } elsif ($#{$cur} != 2) { 2646 $$i_r{error} = 'rgb pixel array wrong size'; 2647 2648 } elsif (!checkval($$cur[0], $$i_r{encode}) or 2649 !checkval($$cur[1], $$i_r{encode}) or 2650 !checkval($$cur[2], $$i_r{encode})) { 2651 $$i_r{error} = 'rgb pixel array encoded wrong'; 2652 2653 } 2654 } # 3d 2655 2656 elsif(ref($cur) ne '') { 2657 $$i_r{error} = 'pixel not scalar'; 2658 } 2659 2660 elsif(($$i_r{type} == 6) or ($$i_r{type} == 3)) { # pixmap 2661 @rgb = explodetriple($cur); 2662 2663 if ($#rgb != 2) { 2664 $$i_r{error} = 'rgb pixel not a triple'; 2665 2666 } elsif (!checkval($rgb[0], $$i_r{encode}) or 2667 !checkval($rgb[1], $$i_r{encode}) or 2668 !checkval($rgb[2], $$i_r{encode})) { 2669 $$i_r{error} = 'rgb pixel encoded wrong'; 2670 } 2671 } # pixmap 2672 2673 elsif(($$i_r{type} == 5) or ($$i_r{type} == 2)) { # graymap 2674 if (!checkval($cur, $$i_r{encode})) { 2675 $$i_r{error} = 'gray pixel encoded wrong'; 2676 } 2677 } # graymap 2678 2679 if(length($$i_r{error})) { 2680 $$i_r{checked} = $checked; 2681 $$i_r{where} = "$h,$w"; 2682 return undef; 2683 } 2684 2685 # that pixel works out okay 2686 $checked ++; 2687 2688 if($checked == $$i_r{pixels}) { 2689 last CHECK_ALL; 2690 } 2691 2692 if($$i_r{deep} eq '1d') { 2693 $w ++; 2694 $cur = $$p_r[$w]; 2695 } else { 2696 $w ++; 2697 if($w > ($$i_r{width} - 1)) { 2698 if(exists($$p_r[$h][$w])) { 2699 $$i_r{error} = 'row too wide'; 2700 last CHECK_ALL; 2701 } else { 2702 $w = 0; 2703 $h ++; 2704 } 2705 } 2706 if (!exists($$p_r[$h][$w])) { 2707 $$i_r{error} = 'row not wide enough'; 2708 last CHECK_ALL; 2709 } 2710 $cur = $$p_r[$h][$w]; 2711 } 2712 } # while CHECK_ALL 2713 2714 $$i_r{checked} = $checked; 2715 2716 if($checked != $$i_r{pixels}) { 2717 $$i_r{error} = 'pixel undef'; 2718 $$i_r{where} = "$h,$w"; 2719 return undef; 2720 } 2721 2722 return $$i_r{pixels}; 2723} # end &inspectpixels 2724 2725 2726################################################################## 2727 2728 2729=head2 checkval($value, $encode); 2730 2731Checks that a value (not an RGB triple) conforms to an encoding of 2732'float', 'dec', or 'hex'. Returns undef if there was an error, and a 2733positive value otherwise. 2734 2735=cut 2736 2737sub checkval { 2738 my $v = shift; 2739 my $enc = shift; 2740 2741 if(!defined($v) or !defined($enc)) { 2742 return undef; 2743 } 2744 2745 if($enc eq 'float') { 2746 if($v =~ /^[.\d]+,$/) { 2747 return 1; 2748 } 2749 } elsif($enc eq 'dec') { 2750 if($v =~ /^[\d]+:$/) { 2751 return 1; 2752 } 2753 } elsif($enc eq 'hex') { 2754 if($v =~ m:^[\da-fA-F]+/$:) { 2755 return 1; 2756 } 2757 } 2758 2759 return undef; 2760} # sub &checkval 2761 2762################################################################## 2763 2764 2765 2766 2767=head1 PORTABILITY 2768 2769This code is pure perl for maximum portability, as befitting the 2770PBM/PGM/PPM philosophy. 2771 2772=head1 CHANGES 2773 27742.0 is a nearly complete rewrite fixing the bugs that arose from 2775not taking the max value into account. Only the code to read an 2776image header is taken from 1.x. None of the function names are the 2777same and most of the interface has changed. 2778 27791.05 fixes two comment related bugs (thanks Ladislav Sladecek!) and 2780some error reporting bugs with bad filehandles. 2781 2782=head1 BUGS 2783 2784No attempt is made to deal with comments after the header in ASCII 2785formatted files. 2786 2787No attempt is made to handle the PAM format. 2788 2789Pure perl code makes this slower than it could be. 2790 2791Not all PBM/PGM/PPM tools are safe for images from untrusted sources 2792but this one should be. Be careful what you use this with. This 2793software can create raw files with multibyte (max over 255) values, but 2794some older PBM/PGM/PPM tools can only handle ASCII files for large 2795max values (or cannot handle it at all). 2796 2797=head1 SEE ALSO 2798 2799The manual pages for B<pbm>(5), B<pgm>(5), and B<ppm>(5) define the 2800various file formats. The netpbm and pbmplus packages include a host 2801of interesting PNM tools. 2802 2803=head1 COPYRIGHT 2804 2805Copyright 2012, 2003 Benjamin Elijah Griffin / Eli the Bearded 2806E<lt>elijah@cpan.orgE<gt> 2807 2808This library is free software; you can redistribute it and/or modify it 2809under the same terms as Perl itself. 2810 2811=cut 2812 28131; 2814 2815__END__ 2816