############################################################################### # Captcha.pm # # $Date: 09.01.14 $ # ############################################################################### # YaBB: Yet another Bulletin Board # # Open-Source Community Software for Webmasters # # Version: YaBB 2.6.1 # # Packaged: September 1, 2014 # # Distributed by: http://www.yabbforum.com # # =========================================================================== # # Copyright (c) 2000-2014 YaBB (www.yabbforum.com) - All Rights Reserved. # # Software by: The YaBB Development Team # # with assistance from the YaBB community. # ############################################################################### # Generate GIF image of a message # Version 1.5 # by Andrew Gregory # 17 February 2007 # # http://www.scss.com.au/family/andrew/webdesign/msgimg/ # # This work is licensed under the Creative Commons # Attribution-NonCommercial-ShareAlike License. To view a copy of this license, # visit http://creativecommons.org/licenses/by-nc-sa/1.0/ or send a letter to # Creative Commons, 559 Nathan Abbott Way, Stanford, California 94305, USA. # use strict; # use warnings; no warnings qw(uninitialized once redefine); use CGI::Carp qw(fatalsToBrowser); use English '-no_match_vars'; our $VERSION = '2.6.1'; $captchapmver = 'YaBB 2.6.1 $Revision$'; if ( $action eq 'detailedversion' ) { return 1; } $OUTPUT_AUTOFLUSH = 1; if ( !$rgb_foreground ) { $rgb_foreground = '0000EE'; } if ( !$rgb_shade ) { $rgb_shade = '999999'; } if ( !$rgb_background ) { $rgb_background = 'FFFFFF'; } sub captcha { my ($msg) = @_; ## make colors for validation image into hex again ## $rgb_foreground =~ s/\#//gxsm; $rgb_shade =~ s/\#//gxsm; $rgb_background =~ s/\#//gxsm; $r_f = substr $rgb_foreground, 0, 2; $g_f = substr $rgb_foreground, 2, 2; $b_f = substr $rgb_foreground, 4, 2; $r_s = substr $rgb_shade, 0, 2; $g_s = substr $rgb_shade, 2, 2; $b_s = substr $rgb_shade, 4, 2; $r_b = substr $rgb_background, 0, 2; $g_b = substr $rgb_background, 2, 2; $b_b = substr $rgb_background, 4, 2; # color for center cross of the dots (RGB) $highcolor = pack 'H2', $r_f; $highcolor .= pack 'H2', $g_f; $highcolor .= pack 'H2', $b_f; # color for shade in the dots (RGB) $shadecolor = pack 'H2', $r_s; $shadecolor .= pack 'H2', $g_s; $shadecolor .= pack 'H2', $b_s; # color for background of the dots (RGB) $backcolor = pack 'H2', $r_b; $backcolor .= pack 'H2', $g_b; $backcolor .= pack 'H2', $b_b; if ( !$translayer || $translayer eq '0' ) { $TRANSPARENT_INDEX = "\3"; } else { $TRANSPARENT_INDEX = "\0"; } # Palette $BITS_PER_PIXEL = 7; # DON'T CHANGE THIS!!! # A note about BITS_PER_PIXEL: GIF data is bit packed. For example, if the code # size is 6 bits, then 4 codes can be packed into 3 bytes. This script does not # implement bit packing. 7 bits per pixel translates into 8 bits per code which # exactly matches a byte and therefore bit packing is not needed. $palette .= "$backcolor"; # 0 = white $palette .= "$shadecolor"; # 1 = grey $palette .= "$highcolor"; # 2 = almost black # Dot definition # Defines a dot in terms of palette colours. $DOT_WIDTH = 3; $DOT_HEIGHT = 3; $dot = qq~ \1\2\1 \2\2\2 \1\2\1 ~; $nodot = qq~ \0\0\0 \0\0\0 \0\0\0 ~; $invdot = qq~ \1\0\1 \0\0\0 \1\0\1 ~; $invnodot = qq~ \1\1\1 \1\1\1 \1\1\1 ~; ############################################### ############################################### # Character definitions my ( $CHAR_WIDTH, $CHAR_HEIGHT, %ci ); $CHAR_WIDTH = 7; $CHAR_HEIGHT = 10; $ci{' '} = qq~ ....... ....... ....... ....... ....... ....... ....... ....... ....... ....... ~; $ci{'!'} = qq~ ....... ...X... ...X... ...X... ...X... ...X... ....... ...X... ....... ....... ~; $ci{'"'} = qq~ ....... ..X.X.. ..X.X.. ..X.X.. ....... ....... ....... ....... ....... ....... ~; $ci{'#'} = qq~ ....... ..X.X.. ..X.X.. .XXXXX. ..X.X.. .XXXXX. ..X.X.. ..X.X.. ....... ....... ~; $ci{'$'} = qq~ ....... ...X... ..XXXX. .X.X... ..XXX.. ...X.X. .XXXX.. ...X... ....... ....... ~; $ci{'%'} = qq~ ....... .XX.... .XX..X. ....X.. ...X... ..X.... .X..XX. ....XX. ....... ....... ~; $ci{'&'} = qq~ ....... ..X.... .X.X... .X.X... ..X.... .X.X.X. .X..X.. ..XX.X. ....... ....... ~; $ci{'\''} = qq~ #'make my syntax check happy; ....... ...X... ...X... ...X... ....... ....... ....... ....... ....... ....... ~; $ci{'('} = qq~ ....... ....X.. ...X... ..X.... ..X.... ..X.... ...X... ....X.. ....... ....... ~; $ci{')'} = qq~ ....... ..X.... ...X... ....X.. ....X.. ....X.. ...X... ..X.... ....... ....... ~; $ci{'*'} = qq~ ....... ...X... .X.X.X. ..XXX.. ...X... ..XXX.. .X.X.X. ...X... ....... ....... ~; $ci{'+'} = qq~ ....... ....... ...X... ...X... .XXXXX. ...X... ...X... ....... ....... ....... ~; $ci{','} = qq~ ....... ....... ....... ....... ....... ....... ...X... ...X... ..X.... ....... ~; $ci{'-'} = qq~ ....... ....... ....... ....... .XXXXX. ....... ....... ....... ....... ....... ~; $ci{'.'} = qq~ ....... ....... ....... ....... ....... ....... ....... ...X... ....... ....... ~; $ci{'/'} = qq~ ....... ....... .....X. ....X.. ...X... ..X.... .X..... ....... ....... ....... ~; $ci{':'} = qq~ ....... ....... ....... ....... ...X... ....... ...X... ....... ....... ....... ~; $ci{';'} = qq~ ....... ....... ....... ....... ...X... ....... ...X... ...X... ..X.... ....... ~; $ci{'<'} = qq~ ....... ....X.. ...X... ..X.... .X..... ..X.... ...X... ....X.. ....... ....... ~; $ci{'='} = qq~ ....... ....... ....... .XXXXX. ....... .XXXXX. ....... ....... ....... ....... ~; $ci{'>'} = qq~ ....... ..X.... ...X... ....X.. .....X. ....X.. ...X... ..X.... ....... ....... ~; $ci{'?'} = qq~ ....... ..XXX.. .X...X. ....X.. ...X... ...X... ....... ...X... ....... ....... ~; $ci{'@'} = qq~ ....... ..XXX.. .X...X. .X.X.X. .X.XXX. .X.XX.. .X..... ..XXXX. ....... ....... ~; $ci{'['} = qq~ ....... .XXXXX. .XX.... .XX.... .XX.... .XX.... .XX.... .XXXXX. ....... ....... ~; $ci{'\\'} = qq~ ....... ....... .X..... ..X.... ...X... ....X.. .....X. ....... ....... ....... ~; $ci{']'} = qq~ ....... .XXXXX. ....XX. ....XX. ....XX. ....XX. ....XX. .XXXXX. ....... ....... ~; $ci{'^'} = qq~ ....... ....... ....... ...X... ..X.X.. .X...X. ....... ....... ....... ....... ~; $ci{'_'} = qq~ ....... ....... ....... ....... ....... ....... ....... .XXXXX. ....... ....... ~; $ci{'`'} = qq~ ....... ...X... ...X... ....X.. ....... ....... ....... ....... ....... ....... ~; $ci{'{'} = qq~ ....... ....XX. ...X... ...X... ..X.... ...X... ...X... ....XX. ....... ....... ~; $ci{'|'} = qq~ ....... ...X... ...X... ...X... ....... ...X... ...X... ...X... ....... ....... ~; $ci{'}'} = qq~ ....... ..XX... ....X.. ....X.. .....X. ....X.. ....X.. ..XX... ....... ....... ~; $ci{'~'} = qq~ ....... ..X.... .X.X.X. ....X.. ....... ....... ....... ....... ....... ....... ~; $ci{'0'} = qq~ ....... ..XXX.. .X...X. .X..XX. .X.X.X. .XX..X. .X...X. ..XXX.. ....... ....... ~; $ci{'1'} = qq~ ....... ...X... ..XX... ...X... ...X... ...X... ...X... ..XXX.. ....... ....... ~; $ci{'2'} = qq~ ....... ..XXX.. .X...X. .....X. ...XX.. ..X.... .X..... .XXXXX. ....... ....... ~; $ci{'3'} = qq~ ....... .XXXXX. .....X. ....X.. ...XX.. .....X. .X...X. ..XXX.. ....... ....... ~; $ci{'4'} = qq~ ....... ....X.. ...XX.. ..X.X.. .X..X.. .XXXXX. ....X.. ....X.. ....... ....... ~; $ci{'5'} = qq~ ....... .XXXXX. .X..... .XXXX.. .....X. .....X. .X...X. ..XXX.. ....... ....... ~; $ci{'6'} = qq~ ....... ...XXX. ..X.... .X..... .XXXX.. .X...X. .X...X. ..XXX.. ....... ....... ~; $ci{'7'} = qq~ ....... .XXXXX. .....X. ....X.. ...X... ..X.... ..X.... ..X.... ....... ....... ~; $ci{'8'} = qq~ ....... ..XXX.. .X...X. .X...X. ..XXX.. .X...X. .X...X. ..XXX.. ....... ....... ~; $ci{'9'} = qq~ ....... ..XXX.. .X...X. .X...X. ..XXXX. .....X. ....X.. .XXX... ....... ....... ~; $ci{'A'} = qq~ ....... ...X... ..X.X.. .X...X. .X...X. .XXXXX. .X...X. .X...X. ....... ....... ~; $ci{'a'} = qq~ ....... ....... ....... ..XXX.. .....X. ..XXXX. .X...X. ..XXXX. ....... ....... ~; $ci{'B'} = qq~ ....... .XXXX.. .X...X. .X...X. .XXXX.. .X...X. .X...X. .XXXX.. ....... ....... ~; $ci{'b'} = qq~ ....... .X..... .X..... .XXXX.. .X...X. .X...X. .X...X. .XXXX.. ....... ....... ~; $ci{'C'} = qq~ ....... ..XXX.. .X...X. .X..... .X..... .X..... .X...X. ..XXX.. ....... ....... ~; $ci{'c'} = qq~ ....... ....... ....... ..XXXX. .X..... .X..... .X..... ..XXXX. ....... ....... ~; $ci{'D'} = qq~ ....... .XXXX.. .X...X. .X...X. .X...X. .X...X. .X...X. .XXXX.. ....... ....... ~; $ci{'d'} = qq~ ....... .....X. .....X. ..XXXX. .X...X. .X...X. .X...X. ..XXXX. ....... ....... ~; $ci{'E'} = qq~ ....... .XXXXX. .X..... .X..... .XXXX.. .X..... .X..... .XXXXX. ....... ....... ~; $ci{'e'} = qq~ ....... ....... ....... ..XXX.. .X...X. .XXXXX. .X..... ..XXXX. ....... ....... ~; $ci{'F'} = qq~ ....... .XXXXX. .X..... .X..... .XXXX.. .X..... .X..... .X..... ....... ....... ~; $ci{'f'} = qq~ ....... ...XX.. ..X..X. ..X.... .XXXX.. ..X.... ..X.... ..X.... ....... ....... ~; $ci{'G'} = qq~ ....... ..XXXX. .X..... .X..... .X..... .X..XX. .X...X. ..XXXX. ....... ....... ~; $ci{'g'} = qq~ ....... ....... ....... ..XXX.. .X...X. .X...X. ..XXXX. .....X. ..XXX.. ....... ~; $ci{'H'} = qq~ ....... .X...X. .X...X. .X...X. .XXXXX. .X...X. .X...X. .X...X. ....... ....... ~; $ci{'h'} = qq~ ....... .X..... .X..... .XXXX.. .X...X. .X...X. .X...X. .X...X. ....... ....... ~; $ci{'I'} = qq~ ....... ..XXX.. ...X... ...X... ...X... ...X... ...X... ..XXX.. ....... ....... ~; $ci{'i'} = qq~ ....... ...X... ....... ..XX... ...X... ...X... ...X... ..XXX.. ....... ....... ~; $ci{'J'} = qq~ ....... .....X. .....X. .....X. .....X. .....X. .X...X. ..XXX.. ....... ....... ~; $ci{'j'} = qq~ ....... ....X.. ....... ...XX.. ....X.. ....X.. ....X.. .X..X.. ..XX... ....... ~; $ci{'K'} = qq~ ....... .X...X. .X..X.. .X.X... .XX.... .X.X... .X..X.. .X...X. ....... ....... ~; $ci{'k'} = qq~ ....... .X..... .X..... .X...X. .X..X.. .XXX... .X..X.. .X...X. ....... ....... ~; $ci{'L'} = qq~ ....... .X..... .X..... .X..... .X..... .X..... .X..... .XXXXX. ....... ....... ~; $ci{'l'} = qq~ ....... ..XX... ...X... ...X... ...X... ...X... ...X... ..XXX.. ....... ....... ~; $ci{'M'} = qq~ ....... .X...X. .XX.XX. .X.X.X. .X.X.X. .X...X. .X...X. .X...X. ....... ....... ~; $ci{'m'} = qq~ ....... ....... ....... .XX.XX. .X.X.X. .X.X.X. .X.X.X. .X...X. ....... ....... ~; $ci{'N'} = qq~ ....... .X...X. .X...X. .XX..X. .X.X.X. .X..XX. .X...X. .X...X. ....... ....... ~; $ci{'n'} = qq~ ....... ....... ....... .XXXX.. .X...X. .X...X. .X...X. .X...X. ....... ....... ~; $ci{'O'} = qq~ ....... ..XXX.. .X...X. .X...X. .X...X. .X...X. .X...X. ..XXX.. ....... ....... ~; $ci{'o'} = qq~ ....... ....... ....... ..XXX.. .X...X. .X...X. .X...X. ..XXX.. ....... ....... ~; $ci{'P'} = qq~ ....... .XXXX.. .X...X. .X...X. .XXXX.. .X..... .X..... .X..... ....... ....... ~; $ci{'p'} = qq~ ....... ....... ....... .XXXX.. .X...X. .X...X. .XXXX.. .X..... .X..... ....... ~; $ci{'Q'} = qq~ ....... ..XXX.. .X...X. .X...X. .X...X. .X.X.X. .X..X.. ..XX.X. ....... ....... ~; $ci{'q'} = qq~ ....... ....... ....... ..XXXX. .X...X. .X...X. ..XXXX. .....X. .....X. ....... ~; $ci{'R'} = qq~ ....... .XXXX.. .X...X. .X...X. .XXXX.. .X.X... .X..X.. .X...X. ....... ....... ~; $ci{'r'} = qq~ ....... ....... ....... .X.XXX. .XX.... .X..... .X..... .X..... ....... ....... ~; $ci{'S'} = qq~ ....... ..XXX.. .X...X. .X..... ..XXX.. .....X. .X...X. ..XXX.. ....... ....... ~; $ci{'s'} = qq~ ....... ....... ....... ..XXXX. .X..... ..XXX.. .....X. .XXXX.. ....... ....... ~; $ci{'T'} = qq~ ....... .XXXXX. ...X... ...X... ...X... ...X... ...X... ...X... ....... ....... ~; $ci{'t'} = qq~ ....... ..X.... .XXXX.. ..X.... ..X.... ..X.... ..X..X. ...XX.. ....... ....... ~; $ci{'U'} = qq~ ....... .X...X. .X...X. .X...X. .X...X. .X...X. .X...X. ..XXX.. ....... ....... ~; $ci{'u'} = qq~ ....... ....... ....... .X...X. .X...X. .X...X. .X..XX. ..XX.X. ....... ....... ~; $ci{'V'} = qq~ ....... .X...X. .X...X. .X...X. .X...X. .X...X. ..X.X.. ...X... ....... ....... ~; $ci{'v'} = qq~ ....... ....... ....... .X...X. .X...X. .X...X. ..X.X.. ...X... ....... ....... ~; $ci{'W'} = qq~ ....... .X...X. .X...X. .X...X. .X.X.X. .X.X.X. .XX.XX. ..X.X.. ....... ....... ~; $ci{'w'} = qq~ ....... ....... ....... .X...X. .X...X. .X.X.X. .X.X.X. ..X.X.. ....... ....... ~; $ci{'X'} = qq~ ....... .X...X. .X...X. ..X.X.. ...X... ..X.X.. .X...X. .X...X. ....... ....... ~; $ci{'x'} = qq~ ....... ....... ....... .X...X. ..X.X.. ...X... ..X.X.. .X...X. ....... ....... ~; $ci{'Y'} = qq~ ....... .X...X. .X...X. ..X.X.. ...X... ...X... ...X... ...X... ....... ....... ~; $ci{'y'} = qq~ ....... ....... ....... .X...X. .X...X. .X...X. ..XXXX. .....X. ..XXX.. ....... ~; $ci{'Z'} = qq~ ....... .XXXXX. .....X. ....X.. ...X... ..X.... .X..... .XXXXX. ....... ....... ~; $ci{'z'} = qq~ ....... ....... ....... .XXXXX. ....X.. ...X... ..X.... .XXXXX. ....... ....... ~; ############################################### my ( $nl, @lines, $len, $w, $h, $LINE_HEIGHT, $BLOCK_LIMIT ); # to measure length of the 'newline' character (cross platform LF vs CR+LF ???) $nl = length qq~ ~; $LINE_HEIGHT = $CHAR_HEIGHT * $DOT_HEIGHT; @lines = split /\n/xsm, $msg; $len = 0; foreach (@lines) { if ( length $_ > $len ) { $len = length $_; } } $w = $len * $CHAR_WIDTH * $DOT_WIDTH; $h = @lines * $LINE_HEIGHT; # LZW block limit - cannot allow the LZW code size to change from the initial # code size (we can't know when the code size will change because we aren't # implementing compression). The 3 is a fudge factor. $BLOCK_LIMIT = 2**$BITS_PER_PIXEL - 3; # Implementation notes: # * Image is NOT compressed! - Does not use LZW compression! # * For ease of output things are arranged so that the expected LZW code size is # always 8 bits. The initial LZW code size is determined by the number of bits # required to represent all possible colour indices, plus two additional codes # used to (1) reset the LZW decode table and (2) mark the end of LZW data. By # selecting a 128 entry colour table, the total of 130 initial LZW codes # require 8 bits. During output, the decoding table is reset at regular # intervals to prevent it from adding so many entries that the decoder would # increase the expected code size to 9 bits. # GIF Signature print 'Content-type: image/gif', "\n\n" or croak "$croak{'print'}"; # Screen Descriptor print $TRANSPARENT_INDEX ? 'GIF89a' : 'GIF87a' or croak "$croak{'print'}"; # width, height print pack 'v2', $w, $h or croak "$croak{'print'}"; # global colour map, 8 bits colour resolution, 7 bits per pixel print pack 'C1', 0xF0 + $BITS_PER_PIXEL - 1 or croak "$croak{'print'}"; # background colour = 0 print "\0" or croak "$croak{'print'}"; # reserved print "\0" or croak "$croak{'print'}"; # Global Colour Map print $palette or croak "$croak{'print'}"; print "\0" x ( ( 2**$BITS_PER_PIXEL * 3 ) - length $palette ) or croak "$croak{'print'}"; if ($TRANSPARENT_INDEX) { # Graphic Control Extension # extension introducer print "\x21" or croak "$croak{'print'}"; # graphic control label print "\xF9" or croak "$croak{'print'}"; # block size print "\x04" or croak "$croak{'print'}"; # no disposal method, no user input, transparent colour present print "\x01" or croak "$croak{'print'}"; # delay time print "\0\0" or croak "$croak{'print'}"; # transparent colour index print $TRANSPARENT_INDEX or croak "$croak{'print'}"; # block terminator print "\0" or croak "$croak{'print'}"; } # Image Descriptor # image separator print q{,} or croak "$croak{'print'}"; # left, top print "\0\0\0\0" or croak "$croak{'print'}"; # width, height print pack 'v2', $w, $h or croak "$croak{'print'}"; # use global colour map (not local), sequential (not interlaced) print "\0" or croak "$croak{'print'}"; # Raster Data # code size print pack 'C', $BITS_PER_PIXEL or croak "$croak{'print'}"; # the data is output in blocks with a leading byte count my ( $img, $line, $random_number ); my ( $y, $cy, $dy ); my ( $x, $cx, $i, $c, $d, $di, $r ); $range = 10; for my $y ( 0 .. ( $h - 1 ) ) { $cy = int( $y / $DOT_HEIGHT ) % $CHAR_HEIGHT; # y coord in character dots $dy = $y % $DOT_HEIGHT; for ( $x = 0 ; $x < $w ; $x += $DOT_WIDTH ) { $random_number = int rand $range; $cx = int( $x / $DOT_WIDTH ) % $CHAR_WIDTH; # x coord in character dots $i = int( $x / $DOT_WIDTH / $CHAR_WIDTH ); # index into message string $line = $lines[ $y / $LINE_HEIGHT ]; $c = ( $i < length $line ) ? substr $line, $i, 1 : q{ }; $d = substr $ci{$c}, $cy * ( $CHAR_WIDTH + $nl ) + $cx + $nl, 1; # dot in character definition if ( $distortion > 0 ) { $dis_level = 9 - $distortion; if ( $random_number <= $dis_level ) { $di = ( $d eq 'X' ) ? $dot : $nodot; } elsif ( $random_number > $dis_level ) { $di = ( $d eq 'X' ) ? $dot : $invnodot; } } else { $di = ( $d eq 'X' ) ? $dot : $nodot; } $di = substr $di, $dy * ( $DOT_WIDTH + $nl ) + $nl, $DOT_WIDTH; for my $i ( 0 .. ( length $di - 1 ) ) { $c = ord substr $di, $i, 1; if ( $randomizer > 0 ) { # Start of randomizer - comment this block out if you don't like it! if ( $randomizer == 1 ) { $rc1 = 1; $rc2 = 1; } if ( $randomizer == 2 ) { $rc1 = 2; $rc2 = 2; } if ( $randomizer == 3 ) { $rc1 = 1; $rc2 = 2; } $r = rand; if ( $r < .1 ) { $c += $rc1; } elsif ( $r > .9 ) { $c += $rc2; } # End of randomizer } $c = chr $c; $img .= $c; } } } # Re-arrange the image data so it's bit-packed my ( $cnt, $pkdimg, $buf, $bufbits ); $i = 0; $buf = 0; $bufbits = 0; while ( $i <= length $img ) { if ( $i < length $img ) { # Output each pixel $c = ord substr $img, $i, 1; $c &= 2**$BITS_PER_PIXEL - 1; $buf |= $c << $bufbits; $bufbits += $BITS_PER_PIXEL + 1; $i++; # Insert LZW table clear code before the decoder will grow the bit size # The minus 2 is a fudge factor if ( $i % ( 2**$BITS_PER_PIXEL - 2 ) == 0 ) { $c = 2**$BITS_PER_PIXEL; $buf |= $c << $bufbits; $bufbits += $BITS_PER_PIXEL + 1; } } else { #Output LZW end code $c = 2**$BITS_PER_PIXEL + 1; $buf |= $c << $bufbits; $bufbits += $BITS_PER_PIXEL + 1; $i++; } while ( $bufbits >= 8 ) { $c = chr( $buf & 255 ); $pkdimg .= $c; $buf >>= 8; $bufbits -= 8; } } $pkdimg .= chr $buf; # Output image data $i = 0; while ( $i < length $pkdimg ) { $cnt = ( length $pkdimg ) - $i; if ( $cnt > 255 ) { $cnt = 255; } print pack 'C', $cnt or croak "$croak{'print'}"; print substr $pkdimg, $i, $cnt or croak "$croak{'print'}"; $i += $cnt; } # Finish up print "\0" or croak "$croak{'print'}"; # zero byte count (end of raster data) # GIF Terminator print ';' or croak "$croak{'print'}"; exit; } 1;