1############################################################################### 2# Captcha.pm # 3# $Date: 12.02.14 $ # 4############################################################################### 5# YaBB: Yet another Bulletin Board # 6# Open-Source Community Software for Webmasters # 7# Version: YaBB 2.6.11 # 8# Packaged: December 2, 2014 # 9# Distributed by: http://www.yabbforum.com # 10# =========================================================================== # 11# Copyright (c) 2000-2014 YaBB (www.yabbforum.com) - All Rights Reserved. # 12# Software by: The YaBB Development Team # 13# with assistance from the YaBB community. # 14############################################################################### 15# Generate GIF image of a message 16# Version 1.5 17# by Andrew Gregory 18# 17 February 2007 19# 20# http://www.scss.com.au/family/andrew/webdesign/msgimg/ 21# 22# This work is licensed under the Creative Commons 23# Attribution-NonCommercial-ShareAlike License. To view a copy of this license, 24# visit http://creativecommons.org/licenses/by-nc-sa/1.0/ or send a letter to 25# Creative Commons, 559 Nathan Abbott Way, Stanford, California 94305, USA. 26 27# use strict; 28# use warnings; 29no warnings qw(uninitialized once redefine); 30use CGI::Carp qw(fatalsToBrowser); 31use English '-no_match_vars'; 32our $VERSION = '2.6.11'; 33 34$captchapmver = 'YaBB 2.6.11 $Revision: 1611 $'; 35if ( $action eq 'detailedversion' ) { return 1; } 36 37$OUTPUT_AUTOFLUSH = 1; 38 39if ( !$rgb_foreground ) { 40 $rgb_foreground = '0000EE'; 41} 42 43if ( !$rgb_shade ) { 44 $rgb_shade = '999999'; 45} 46 47if ( !$rgb_background ) { 48 $rgb_background = 'FFFFFF'; 49} 50 51sub captcha { 52 my ($msg) = @_; 53 ## make colors for validation image into hex again ## 54 $rgb_foreground =~ s/\#//gxsm; 55 $rgb_shade =~ s/\#//gxsm; 56 $rgb_background =~ s/\#//gxsm; 57 $r_f = substr $rgb_foreground, 0, 2; 58 $g_f = substr $rgb_foreground, 2, 2; 59 $b_f = substr $rgb_foreground, 4, 2; 60 $r_s = substr $rgb_shade, 0, 2; 61 $g_s = substr $rgb_shade, 2, 2; 62 $b_s = substr $rgb_shade, 4, 2; 63 $r_b = substr $rgb_background, 0, 2; 64 $g_b = substr $rgb_background, 2, 2; 65 $b_b = substr $rgb_background, 4, 2; 66 67 # color for center cross of the dots (RGB) 68 $highcolor = pack 'H2', $r_f; 69 $highcolor .= pack 'H2', $g_f; 70 $highcolor .= pack 'H2', $b_f; 71 72 # color for shade in the dots (RGB) 73 $shadecolor = pack 'H2', $r_s; 74 $shadecolor .= pack 'H2', $g_s; 75 $shadecolor .= pack 'H2', $b_s; 76 77 # color for background of the dots (RGB) 78 $backcolor = pack 'H2', $r_b; 79 $backcolor .= pack 'H2', $g_b; 80 $backcolor .= pack 'H2', $b_b; 81 82 if ( !$translayer || $translayer eq '0' ) { $TRANSPARENT_INDEX = "\3"; } 83 else { $TRANSPARENT_INDEX = "\0"; } 84 85 # Palette 86 87 $BITS_PER_PIXEL = 7; # DON'T CHANGE THIS!!! 88 89 # A note about BITS_PER_PIXEL: GIF data is bit packed. For example, if the code 90 # size is 6 bits, then 4 codes can be packed into 3 bytes. This script does not 91 # implement bit packing. 7 bits per pixel translates into 8 bits per code which 92 # exactly matches a byte and therefore bit packing is not needed. 93 94 $palette .= "$backcolor"; # 0 = white 95 $palette .= "$shadecolor"; # 1 = grey 96 $palette .= "$highcolor"; # 2 = almost black 97 98 # Dot definition 99 # Defines a dot in terms of palette colours. 100 101 $DOT_WIDTH = 3; 102 $DOT_HEIGHT = 3; 103 104 $dot = qq~ 105\1\2\1 106\2\2\2 107\1\2\1 108~; 109 $nodot = qq~ 110\0\0\0 111\0\0\0 112\0\0\0 113~; 114 115 $invdot = qq~ 116\1\0\1 117\0\0\0 118\1\0\1 119~; 120 $invnodot = qq~ 121\1\1\1 122\1\1\1 123\1\1\1 124~; 125 126 ############################################### 127 ############################################### 128 129 # Character definitions 130 my ( $CHAR_WIDTH, $CHAR_HEIGHT, %ci ); 131 132 $CHAR_WIDTH = 7; 133 $CHAR_HEIGHT = 10; 134 135 $ci{' '} = qq~ 136....... 137....... 138....... 139....... 140....... 141....... 142....... 143....... 144....... 145....... 146~; 147 $ci{'!'} = qq~ 148....... 149...X... 150...X... 151...X... 152...X... 153...X... 154....... 155...X... 156....... 157....... 158~; 159 $ci{'"'} = qq~ 160....... 161..X.X.. 162..X.X.. 163..X.X.. 164....... 165....... 166....... 167....... 168....... 169....... 170~; 171 $ci{'#'} = qq~ 172....... 173..X.X.. 174..X.X.. 175.XXXXX. 176..X.X.. 177.XXXXX. 178..X.X.. 179..X.X.. 180....... 181....... 182~; 183 $ci{'$'} = qq~ 184....... 185...X... 186..XXXX. 187.X.X... 188..XXX.. 189...X.X. 190.XXXX.. 191...X... 192....... 193....... 194~; 195 $ci{'%'} = qq~ 196....... 197.XX.... 198.XX..X. 199....X.. 200...X... 201..X.... 202.X..XX. 203....XX. 204....... 205....... 206~; 207 $ci{'&'} = qq~ 208....... 209..X.... 210.X.X... 211.X.X... 212..X.... 213.X.X.X. 214.X..X.. 215..XX.X. 216....... 217....... 218~; 219 $ci{'\''} = qq~ #'make my syntax check happy; 220....... 221...X... 222...X... 223...X... 224....... 225....... 226....... 227....... 228....... 229....... 230~; 231 $ci{'('} = qq~ 232....... 233....X.. 234...X... 235..X.... 236..X.... 237..X.... 238...X... 239....X.. 240....... 241....... 242~; 243 $ci{')'} = qq~ 244....... 245..X.... 246...X... 247....X.. 248....X.. 249....X.. 250...X... 251..X.... 252....... 253....... 254~; 255 $ci{'*'} = qq~ 256....... 257...X... 258.X.X.X. 259..XXX.. 260...X... 261..XXX.. 262.X.X.X. 263...X... 264....... 265....... 266~; 267 $ci{'+'} = qq~ 268....... 269....... 270...X... 271...X... 272.XXXXX. 273...X... 274...X... 275....... 276....... 277....... 278~; 279 $ci{','} = qq~ 280....... 281....... 282....... 283....... 284....... 285....... 286...X... 287...X... 288..X.... 289....... 290~; 291 $ci{'-'} = qq~ 292....... 293....... 294....... 295....... 296.XXXXX. 297....... 298....... 299....... 300....... 301....... 302~; 303 $ci{'.'} = qq~ 304....... 305....... 306....... 307....... 308....... 309....... 310....... 311...X... 312....... 313....... 314~; 315 $ci{'/'} = qq~ 316....... 317....... 318.....X. 319....X.. 320...X... 321..X.... 322.X..... 323....... 324....... 325....... 326~; 327 $ci{':'} = qq~ 328....... 329....... 330....... 331....... 332...X... 333....... 334...X... 335....... 336....... 337....... 338~; 339 $ci{';'} = qq~ 340....... 341....... 342....... 343....... 344...X... 345....... 346...X... 347...X... 348..X.... 349....... 350~; 351 $ci{'<'} = qq~ 352....... 353....X.. 354...X... 355..X.... 356.X..... 357..X.... 358...X... 359....X.. 360....... 361....... 362~; 363 $ci{'='} = qq~ 364....... 365....... 366....... 367.XXXXX. 368....... 369.XXXXX. 370....... 371....... 372....... 373....... 374~; 375 $ci{'>'} = qq~ 376....... 377..X.... 378...X... 379....X.. 380.....X. 381....X.. 382...X... 383..X.... 384....... 385....... 386~; 387 $ci{'?'} = qq~ 388....... 389..XXX.. 390.X...X. 391....X.. 392...X... 393...X... 394....... 395...X... 396....... 397....... 398~; 399 $ci{'@'} = qq~ 400....... 401..XXX.. 402.X...X. 403.X.X.X. 404.X.XXX. 405.X.XX.. 406.X..... 407..XXXX. 408....... 409....... 410~; 411 $ci{'['} = qq~ 412....... 413.XXXXX. 414.XX.... 415.XX.... 416.XX.... 417.XX.... 418.XX.... 419.XXXXX. 420....... 421....... 422~; 423 $ci{'\\'} = qq~ 424....... 425....... 426.X..... 427..X.... 428...X... 429....X.. 430.....X. 431....... 432....... 433....... 434~; 435 $ci{']'} = qq~ 436....... 437.XXXXX. 438....XX. 439....XX. 440....XX. 441....XX. 442....XX. 443.XXXXX. 444....... 445....... 446~; 447 $ci{'^'} = qq~ 448....... 449....... 450....... 451...X... 452..X.X.. 453.X...X. 454....... 455....... 456....... 457....... 458~; 459 $ci{'_'} = qq~ 460....... 461....... 462....... 463....... 464....... 465....... 466....... 467.XXXXX. 468....... 469....... 470~; 471 $ci{'`'} = qq~ 472....... 473...X... 474...X... 475....X.. 476....... 477....... 478....... 479....... 480....... 481....... 482~; 483 $ci{'{'} = qq~ 484....... 485....XX. 486...X... 487...X... 488..X.... 489...X... 490...X... 491....XX. 492....... 493....... 494~; 495 $ci{'|'} = qq~ 496....... 497...X... 498...X... 499...X... 500....... 501...X... 502...X... 503...X... 504....... 505....... 506~; 507 $ci{'}'} = qq~ 508....... 509..XX... 510....X.. 511....X.. 512.....X. 513....X.. 514....X.. 515..XX... 516....... 517....... 518~; 519 $ci{'~'} = qq~ 520....... 521..X.... 522.X.X.X. 523....X.. 524....... 525....... 526....... 527....... 528....... 529....... 530~; 531 $ci{'0'} = qq~ 532....... 533..XXX.. 534.X...X. 535.X..XX. 536.X.X.X. 537.XX..X. 538.X...X. 539..XXX.. 540....... 541....... 542~; 543 $ci{'1'} = qq~ 544....... 545...X... 546..XX... 547...X... 548...X... 549...X... 550...X... 551..XXX.. 552....... 553....... 554~; 555 $ci{'2'} = qq~ 556....... 557..XXX.. 558.X...X. 559.....X. 560...XX.. 561..X.... 562.X..... 563.XXXXX. 564....... 565....... 566~; 567 $ci{'3'} = qq~ 568....... 569.XXXXX. 570.....X. 571....X.. 572...XX.. 573.....X. 574.X...X. 575..XXX.. 576....... 577....... 578~; 579 $ci{'4'} = qq~ 580....... 581....X.. 582...XX.. 583..X.X.. 584.X..X.. 585.XXXXX. 586....X.. 587....X.. 588....... 589....... 590~; 591 $ci{'5'} = qq~ 592....... 593.XXXXX. 594.X..... 595.XXXX.. 596.....X. 597.....X. 598.X...X. 599..XXX.. 600....... 601....... 602~; 603 $ci{'6'} = qq~ 604....... 605...XXX. 606..X.... 607.X..... 608.XXXX.. 609.X...X. 610.X...X. 611..XXX.. 612....... 613....... 614~; 615 $ci{'7'} = qq~ 616....... 617.XXXXX. 618.....X. 619....X.. 620...X... 621..X.... 622..X.... 623..X.... 624....... 625....... 626~; 627 $ci{'8'} = qq~ 628....... 629..XXX.. 630.X...X. 631.X...X. 632..XXX.. 633.X...X. 634.X...X. 635..XXX.. 636....... 637....... 638~; 639 $ci{'9'} = qq~ 640....... 641..XXX.. 642.X...X. 643.X...X. 644..XXXX. 645.....X. 646....X.. 647.XXX... 648....... 649....... 650~; 651 $ci{'A'} = qq~ 652....... 653...X... 654..X.X.. 655.X...X. 656.X...X. 657.XXXXX. 658.X...X. 659.X...X. 660....... 661....... 662~; 663 $ci{'a'} = qq~ 664....... 665....... 666....... 667..XXX.. 668.....X. 669..XXXX. 670.X...X. 671..XXXX. 672....... 673....... 674~; 675 $ci{'B'} = qq~ 676....... 677.XXXX.. 678.X...X. 679.X...X. 680.XXXX.. 681.X...X. 682.X...X. 683.XXXX.. 684....... 685....... 686~; 687 $ci{'b'} = qq~ 688....... 689.X..... 690.X..... 691.XXXX.. 692.X...X. 693.X...X. 694.X...X. 695.XXXX.. 696....... 697....... 698~; 699 $ci{'C'} = qq~ 700....... 701..XXX.. 702.X...X. 703.X..... 704.X..... 705.X..... 706.X...X. 707..XXX.. 708....... 709....... 710~; 711 $ci{'c'} = qq~ 712....... 713....... 714....... 715..XXXX. 716.X..... 717.X..... 718.X..... 719..XXXX. 720....... 721....... 722~; 723 $ci{'D'} = qq~ 724....... 725.XXXX.. 726.X...X. 727.X...X. 728.X...X. 729.X...X. 730.X...X. 731.XXXX.. 732....... 733....... 734~; 735 $ci{'d'} = qq~ 736....... 737.....X. 738.....X. 739..XXXX. 740.X...X. 741.X...X. 742.X...X. 743..XXXX. 744....... 745....... 746~; 747 $ci{'E'} = qq~ 748....... 749.XXXXX. 750.X..... 751.X..... 752.XXXX.. 753.X..... 754.X..... 755.XXXXX. 756....... 757....... 758~; 759 $ci{'e'} = qq~ 760....... 761....... 762....... 763..XXX.. 764.X...X. 765.XXXXX. 766.X..... 767..XXXX. 768....... 769....... 770~; 771 $ci{'F'} = qq~ 772....... 773.XXXXX. 774.X..... 775.X..... 776.XXXX.. 777.X..... 778.X..... 779.X..... 780....... 781....... 782~; 783 $ci{'f'} = qq~ 784....... 785...XX.. 786..X..X. 787..X.... 788.XXXX.. 789..X.... 790..X.... 791..X.... 792....... 793....... 794~; 795 $ci{'G'} = qq~ 796....... 797..XXXX. 798.X..... 799.X..... 800.X..... 801.X..XX. 802.X...X. 803..XXXX. 804....... 805....... 806~; 807 $ci{'g'} = qq~ 808....... 809....... 810....... 811..XXX.. 812.X...X. 813.X...X. 814..XXXX. 815.....X. 816..XXX.. 817....... 818~; 819 $ci{'H'} = qq~ 820....... 821.X...X. 822.X...X. 823.X...X. 824.XXXXX. 825.X...X. 826.X...X. 827.X...X. 828....... 829....... 830~; 831 $ci{'h'} = qq~ 832....... 833.X..... 834.X..... 835.XXXX.. 836.X...X. 837.X...X. 838.X...X. 839.X...X. 840....... 841....... 842~; 843 $ci{'I'} = qq~ 844....... 845..XXX.. 846...X... 847...X... 848...X... 849...X... 850...X... 851..XXX.. 852....... 853....... 854~; 855 $ci{'i'} = qq~ 856....... 857...X... 858....... 859..XX... 860...X... 861...X... 862...X... 863..XXX.. 864....... 865....... 866~; 867 $ci{'J'} = qq~ 868....... 869.....X. 870.....X. 871.....X. 872.....X. 873.....X. 874.X...X. 875..XXX.. 876....... 877....... 878~; 879 $ci{'j'} = qq~ 880....... 881....X.. 882....... 883...XX.. 884....X.. 885....X.. 886....X.. 887.X..X.. 888..XX... 889....... 890~; 891 $ci{'K'} = qq~ 892....... 893.X...X. 894.X..X.. 895.X.X... 896.XX.... 897.X.X... 898.X..X.. 899.X...X. 900....... 901....... 902~; 903 $ci{'k'} = qq~ 904....... 905.X..... 906.X..... 907.X...X. 908.X..X.. 909.XXX... 910.X..X.. 911.X...X. 912....... 913....... 914~; 915 $ci{'L'} = qq~ 916....... 917.X..... 918.X..... 919.X..... 920.X..... 921.X..... 922.X..... 923.XXXXX. 924....... 925....... 926~; 927 $ci{'l'} = qq~ 928....... 929..XX... 930...X... 931...X... 932...X... 933...X... 934...X... 935..XXX.. 936....... 937....... 938~; 939 $ci{'M'} = qq~ 940....... 941.X...X. 942.XX.XX. 943.X.X.X. 944.X.X.X. 945.X...X. 946.X...X. 947.X...X. 948....... 949....... 950~; 951 $ci{'m'} = qq~ 952....... 953....... 954....... 955.XX.XX. 956.X.X.X. 957.X.X.X. 958.X.X.X. 959.X...X. 960....... 961....... 962~; 963 $ci{'N'} = qq~ 964....... 965.X...X. 966.X...X. 967.XX..X. 968.X.X.X. 969.X..XX. 970.X...X. 971.X...X. 972....... 973....... 974~; 975 $ci{'n'} = qq~ 976....... 977....... 978....... 979.XXXX.. 980.X...X. 981.X...X. 982.X...X. 983.X...X. 984....... 985....... 986~; 987 $ci{'O'} = qq~ 988....... 989..XXX.. 990.X...X. 991.X...X. 992.X...X. 993.X...X. 994.X...X. 995..XXX.. 996....... 997....... 998~; 999 $ci{'o'} = qq~ 1000....... 1001....... 1002....... 1003..XXX.. 1004.X...X. 1005.X...X. 1006.X...X. 1007..XXX.. 1008....... 1009....... 1010~; 1011 $ci{'P'} = qq~ 1012....... 1013.XXXX.. 1014.X...X. 1015.X...X. 1016.XXXX.. 1017.X..... 1018.X..... 1019.X..... 1020....... 1021....... 1022~; 1023 $ci{'p'} = qq~ 1024....... 1025....... 1026....... 1027.XXXX.. 1028.X...X. 1029.X...X. 1030.XXXX.. 1031.X..... 1032.X..... 1033....... 1034~; 1035 $ci{'Q'} = qq~ 1036....... 1037..XXX.. 1038.X...X. 1039.X...X. 1040.X...X. 1041.X.X.X. 1042.X..X.. 1043..XX.X. 1044....... 1045....... 1046~; 1047 $ci{'q'} = qq~ 1048....... 1049....... 1050....... 1051..XXXX. 1052.X...X. 1053.X...X. 1054..XXXX. 1055.....X. 1056.....X. 1057....... 1058~; 1059 $ci{'R'} = qq~ 1060....... 1061.XXXX.. 1062.X...X. 1063.X...X. 1064.XXXX.. 1065.X.X... 1066.X..X.. 1067.X...X. 1068....... 1069....... 1070~; 1071 $ci{'r'} = qq~ 1072....... 1073....... 1074....... 1075.X.XXX. 1076.XX.... 1077.X..... 1078.X..... 1079.X..... 1080....... 1081....... 1082~; 1083 $ci{'S'} = qq~ 1084....... 1085..XXX.. 1086.X...X. 1087.X..... 1088..XXX.. 1089.....X. 1090.X...X. 1091..XXX.. 1092....... 1093....... 1094~; 1095 $ci{'s'} = qq~ 1096....... 1097....... 1098....... 1099..XXXX. 1100.X..... 1101..XXX.. 1102.....X. 1103.XXXX.. 1104....... 1105....... 1106~; 1107 $ci{'T'} = qq~ 1108....... 1109.XXXXX. 1110...X... 1111...X... 1112...X... 1113...X... 1114...X... 1115...X... 1116....... 1117....... 1118~; 1119 $ci{'t'} = qq~ 1120....... 1121..X.... 1122.XXXX.. 1123..X.... 1124..X.... 1125..X.... 1126..X..X. 1127...XX.. 1128....... 1129....... 1130~; 1131 $ci{'U'} = qq~ 1132....... 1133.X...X. 1134.X...X. 1135.X...X. 1136.X...X. 1137.X...X. 1138.X...X. 1139..XXX.. 1140....... 1141....... 1142~; 1143 $ci{'u'} = qq~ 1144....... 1145....... 1146....... 1147.X...X. 1148.X...X. 1149.X...X. 1150.X..XX. 1151..XX.X. 1152....... 1153....... 1154~; 1155 $ci{'V'} = qq~ 1156....... 1157.X...X. 1158.X...X. 1159.X...X. 1160.X...X. 1161.X...X. 1162..X.X.. 1163...X... 1164....... 1165....... 1166~; 1167 $ci{'v'} = qq~ 1168....... 1169....... 1170....... 1171.X...X. 1172.X...X. 1173.X...X. 1174..X.X.. 1175...X... 1176....... 1177....... 1178~; 1179 $ci{'W'} = qq~ 1180....... 1181.X...X. 1182.X...X. 1183.X...X. 1184.X.X.X. 1185.X.X.X. 1186.XX.XX. 1187..X.X.. 1188....... 1189....... 1190~; 1191 $ci{'w'} = qq~ 1192....... 1193....... 1194....... 1195.X...X. 1196.X...X. 1197.X.X.X. 1198.X.X.X. 1199..X.X.. 1200....... 1201....... 1202~; 1203 $ci{'X'} = qq~ 1204....... 1205.X...X. 1206.X...X. 1207..X.X.. 1208...X... 1209..X.X.. 1210.X...X. 1211.X...X. 1212....... 1213....... 1214~; 1215 $ci{'x'} = qq~ 1216....... 1217....... 1218....... 1219.X...X. 1220..X.X.. 1221...X... 1222..X.X.. 1223.X...X. 1224....... 1225....... 1226~; 1227 $ci{'Y'} = qq~ 1228....... 1229.X...X. 1230.X...X. 1231..X.X.. 1232...X... 1233...X... 1234...X... 1235...X... 1236....... 1237....... 1238~; 1239 $ci{'y'} = qq~ 1240....... 1241....... 1242....... 1243.X...X. 1244.X...X. 1245.X...X. 1246..XXXX. 1247.....X. 1248..XXX.. 1249....... 1250~; 1251 $ci{'Z'} = qq~ 1252....... 1253.XXXXX. 1254.....X. 1255....X.. 1256...X... 1257..X.... 1258.X..... 1259.XXXXX. 1260....... 1261....... 1262~; 1263 $ci{'z'} = qq~ 1264....... 1265....... 1266....... 1267.XXXXX. 1268....X.. 1269...X... 1270..X.... 1271.XXXXX. 1272....... 1273....... 1274~; 1275 1276 ############################################### 1277 1278 my ( $nl, @lines, $len, $w, $h, $LINE_HEIGHT, $BLOCK_LIMIT ); 1279 1280 # to measure length of the 'newline' character (cross platform LF vs CR+LF ???) 1281 $nl = length qq~ 1282~; 1283 1284 $LINE_HEIGHT = $CHAR_HEIGHT * $DOT_HEIGHT; 1285 @lines = split /\n/xsm, $msg; 1286 $len = 0; 1287 foreach (@lines) { 1288 if ( length $_ > $len ) { $len = length $_; } 1289 } 1290 $w = $len * $CHAR_WIDTH * $DOT_WIDTH; 1291 $h = @lines * $LINE_HEIGHT; 1292 1293 # LZW block limit - cannot allow the LZW code size to change from the initial 1294 # code size (we can't know when the code size will change because we aren't 1295 # implementing compression). The 3 is a fudge factor. 1296 $BLOCK_LIMIT = 2**$BITS_PER_PIXEL - 3; 1297 1298# Implementation notes: 1299# * Image is NOT compressed! - Does not use LZW compression! 1300# * For ease of output things are arranged so that the expected LZW code size is 1301# always 8 bits. The initial LZW code size is determined by the number of bits 1302# required to represent all possible colour indices, plus two additional codes 1303# used to (1) reset the LZW decode table and (2) mark the end of LZW data. By 1304# selecting a 128 entry colour table, the total of 130 initial LZW codes 1305# require 8 bits. During output, the decoding table is reset at regular 1306# intervals to prevent it from adding so many entries that the decoder would 1307# increase the expected code size to 9 bits. 1308 1309 # GIF Signature 1310 print 'Content-type: image/gif', "\n\n" or croak "$croak{'print'}"; 1311 1312 # Screen Descriptor 1313 print $TRANSPARENT_INDEX ? 'GIF89a' : 'GIF87a' or croak "$croak{'print'}"; 1314 1315 # width, height 1316 print pack 'v2', $w, $h or croak "$croak{'print'}"; 1317 1318 # global colour map, 8 bits colour resolution, 7 bits per pixel 1319 print pack 'C1', 0xF0 + $BITS_PER_PIXEL - 1 or croak "$croak{'print'}"; 1320 1321 # background colour = 0 1322 print "\0" or croak "$croak{'print'}"; 1323 1324 # reserved 1325 print "\0" or croak "$croak{'print'}"; 1326 1327 # Global Colour Map 1328 print $palette or croak "$croak{'print'}"; 1329 print "\0" x ( ( 2**$BITS_PER_PIXEL * 3 ) - length $palette ) or croak "$croak{'print'}"; 1330 1331 if ($TRANSPARENT_INDEX) { 1332 1333 # Graphic Control Extension 1334 # extension introducer 1335 print "\x21" or croak "$croak{'print'}"; 1336 1337 # graphic control label 1338 print "\xF9" or croak "$croak{'print'}"; 1339 1340 # block size 1341 print "\x04" or croak "$croak{'print'}"; 1342 1343 # no disposal method, no user input, transparent colour present 1344 print "\x01" or croak "$croak{'print'}"; 1345 1346 # delay time 1347 print "\0\0" or croak "$croak{'print'}"; 1348 1349 # transparent colour index 1350 print $TRANSPARENT_INDEX or croak "$croak{'print'}"; 1351 1352 # block terminator 1353 print "\0" or croak "$croak{'print'}"; 1354 } 1355 1356 # Image Descriptor 1357 1358 # image separator 1359 print q{,} or croak "$croak{'print'}"; 1360 1361 # left, top 1362 print "\0\0\0\0" or croak "$croak{'print'}"; 1363 1364 # width, height 1365 print pack 'v2', $w, $h or croak "$croak{'print'}"; 1366 1367 # use global colour map (not local), sequential (not interlaced) 1368 print "\0" or croak "$croak{'print'}"; 1369 1370 # Raster Data 1371 1372 # code size 1373 print pack 'C', $BITS_PER_PIXEL or croak "$croak{'print'}"; 1374 1375 # the data is output in blocks with a leading byte count 1376 my ( $img, $line, $random_number ); 1377 my ( $y, $cy, $dy ); 1378 my ( $x, $cx, $i, $c, $d, $di, $r ); 1379 $range = 10; 1380 for my $y ( 0 .. ( $h - 1 ) ) { 1381 $cy = 1382 int( $y / $DOT_HEIGHT ) % $CHAR_HEIGHT; # y coord in character dots 1383 $dy = $y % $DOT_HEIGHT; 1384 for ( $x = 0 ; $x < $w ; $x += $DOT_WIDTH ) { 1385 $random_number = int rand $range; 1386 $cx = 1387 int( $x / $DOT_WIDTH ) % $CHAR_WIDTH; # x coord in character dots 1388 $i = 1389 int( $x / $DOT_WIDTH / $CHAR_WIDTH ); # index into message string 1390 $line = $lines[ $y / $LINE_HEIGHT ]; 1391 $c = ( $i < length $line ) ? substr $line, $i, 1 : q{ }; 1392 $d = substr $ci{$c}, $cy * ( $CHAR_WIDTH + $nl ) + $cx + $nl, 1; 1393 # dot in character definition 1394 if ( $distortion > 0 ) { 1395 $dis_level = 9 - $distortion; 1396 if ( $random_number <= $dis_level ) { 1397 $di = ( $d eq 'X' ) ? $dot : $nodot; 1398 } 1399 elsif ( $random_number > $dis_level ) { 1400 $di = ( $d eq 'X' ) ? $dot : $invnodot; 1401 } 1402 } 1403 else { 1404 $di = ( $d eq 'X' ) ? $dot : $nodot; 1405 } 1406 $di = substr $di, $dy * ( $DOT_WIDTH + $nl ) + $nl, $DOT_WIDTH; 1407 for my $i ( 0 .. ( length $di - 1 ) ) { 1408 $c = ord substr $di, $i, 1; 1409 if ( $randomizer > 0 ) { 1410 1411 # Start of randomizer - comment this block out if you don't like it! 1412 if ( $randomizer == 1 ) { $rc1 = 1; $rc2 = 1; } 1413 if ( $randomizer == 2 ) { $rc1 = 2; $rc2 = 2; } 1414 if ( $randomizer == 3 ) { $rc1 = 1; $rc2 = 2; } 1415 $r = rand; 1416 if ( $r < .1 ) { 1417 $c += $rc1; 1418 } 1419 elsif ( $r > .9 ) { 1420 $c += $rc2; 1421 } 1422 1423 # End of randomizer 1424 } 1425 $c = chr $c; 1426 $img .= $c; 1427 } 1428 } 1429 } 1430 1431 # Re-arrange the image data so it's bit-packed 1432 my ( $cnt, $pkdimg, $buf, $bufbits ); 1433 $i = 0; 1434 $buf = 0; 1435 $bufbits = 0; 1436 while ( $i <= length $img ) { 1437 if ( $i < length $img ) { 1438 1439 # Output each pixel 1440 $c = ord substr $img, $i, 1; 1441 $c &= 2**$BITS_PER_PIXEL - 1; 1442 $buf |= $c << $bufbits; 1443 $bufbits += $BITS_PER_PIXEL + 1; 1444 $i++; 1445 1446 # Insert LZW table clear code before the decoder will grow the bit size 1447 # The minus 2 is a fudge factor 1448 if ( $i % ( 2**$BITS_PER_PIXEL - 2 ) == 0 ) { 1449 $c = 2**$BITS_PER_PIXEL; 1450 $buf |= $c << $bufbits; 1451 $bufbits += $BITS_PER_PIXEL + 1; 1452 } 1453 } 1454 else { 1455 1456 #Output LZW end code 1457 $c = 2**$BITS_PER_PIXEL + 1; 1458 $buf |= $c << $bufbits; 1459 $bufbits += $BITS_PER_PIXEL + 1; 1460 $i++; 1461 } 1462 while ( $bufbits >= 8 ) { 1463 $c = chr( $buf & 255 ); 1464 $pkdimg .= $c; 1465 $buf >>= 8; 1466 $bufbits -= 8; 1467 } 1468 } 1469 $pkdimg .= chr $buf; 1470 1471 # Output image data 1472 $i = 0; 1473 while ( $i < length $pkdimg ) { 1474 $cnt = ( length $pkdimg ) - $i; 1475 if ( $cnt > 255 ) { $cnt = 255; } 1476 print pack 'C', $cnt or croak "$croak{'print'}"; 1477 print substr $pkdimg, $i, $cnt or croak "$croak{'print'}"; 1478 $i += $cnt; 1479 } 1480 1481 # Finish up 1482 print "\0" or croak "$croak{'print'}"; # zero byte count (end of raster data) 1483 1484 # GIF Terminator 1485 print ';' or croak "$croak{'print'}"; 1486 1487 exit; 1488} 1489 14901; 1491