#!/usr/bin/perl ##################################################################### # # BMPINFO v1.0 Last Update: 2022.10.16 # # This Perl script reads one or more BMP files and decodes all the # header values and prints them to stdout. BMP files come in many # flavors, and this program handles them all. This script does not # use any modules or external libraries. It's written in pure Perl. # # Usage: perl bmpinfo.pl [/S] [/P] [/V] filename # # The file name may contain a '?' or '*' character. # Use either '/' or '-' as a prefix for switches. # # /S = Scan sub-directories as well. # /P = Pause. Wait for [Enter] after each BMP file. # /V = Verbose. Print a lot more information. # # Example: perl bmpinfo.pl -sv *.bmp > list.txt # # The above example will gather all the information about all BMP # files in the current directory and all sub-directories and will # print the result to a file called list.txt. # # Written by Zsolt N Perry (also known as Zsolt Nagy Perge). # For questions, comments, feature requests, or bug reports, # write to zsnp@juno.com. # This Perl script was tested with TinyPerl 5.8 under Windows XP. # This file was downloaded from http://www.wzsn.net/perl # # THIS ENTIRE SOURCE CODE IS FREEWARE. # If you want to incorporate it or parts of it into your program, # just copy and paste whatever you need! There is no need to ask # for permission. This software is distributed "AS IS." There is # no warranty of any kind. The author will not be held liable for # any loss resulting from the use or misuse of this software. # ##################################################################### use 5.004; use strict; use warnings; $| = 1; my $HELP = 0; my $PAUSE = 0; my $VERBOSE = 0; my $RECURSIVE = 0; my $FILENAME = ''; foreach (@ARGV) # Get all parameters { if ($_ =~ m/^[\/-]{1,2}[SPV]{1,3}$/i) { # Match something that starts with / or - and is followed by some of these letters: S P V if ($_ =~ m/P/i) { $PAUSE = 1; } # Match: P p if ($_ =~ m/V/i) { $VERBOSE = 1; } # Match: V v if ($_ =~ m/S/i) { $RECURSIVE = 1; } } # Match: S s elsif ($_ =~ m/^(\/RECURSIVE|-RECURSIVE)$/i) { $RECURSIVE = 1; } # Find: /RECURSIVE -RECURSIVE elsif ($_ =~ m/^(\/VERBOSE|-VERBOSE)$/i) { $VERBOSE = 1; } # Find: /VERBOSE -VERBOSE elsif ($_ =~ m/^(\/PAUSE|-PAUSE)$/i) { $PAUSE = 1; } # Find: /PAUSE -PAUSE # Find: /HELP /help -HELP -help /? -? /H /h -H -h --HELP --help ? HELP etc... elsif ($_ =~ m/^(\/HELP|\-HELP|\-\-HELP|-\?|\/\?|\?|\/H|-H|--H|HELP)$/i) { $HELP = 1; } elsif (length($FILENAME) == 0) { $FILENAME = $_; } else { $HELP = 1; } } if ($HELP || length($FILENAME) == 0) { PrintHelp(); exit; } my $CURDIR = GetCurrentDirectory(); if ($VERBOSE) { print "\n PROGRAM NAME .... BMPINFO v1.0\n PERL ............ $^X\n VERSION ......... ", PerlVersion(), "\n ARGUMENTS ....... $0 ", join(' ', @ARGV), "\n TIME ............ ", TimeStamp(), "\n CURDIR .......... $CURDIR", "\n FILENAME ........ $FILENAME\n /VERBOSE ........ $VERBOSE\n /PAUSE .......... $PAUSE\n /RECURSIVE ...... $RECURSIVE\n"; OptionalPause(); } my $SEARCH = $RECURSIVE || ($FILENAME =~ m/[*?]+/) ? 1 : 0; # Match the * or ? characters in the file name if ($SEARCH) # If the filename contains * or ?, then we start reading the entire directory { # (and maybe sub-directories also) and look for files that match the search pattern. SplitPathName($FILENAME); # Splits the filename into two parts: Path->$a FileName->$b my $PATHONLY = (length($a)) ? $a : $CURDIR; $FILENAME = length($b) ? $b : '*.bmp'; $VERBOSE && print "\n Searching in .... $PATHONLY ", ($RECURSIVE ? '(and all sub-directories)' : ''), "\n Looking for ..... $FILENAME\n"; SearchDIR($PATHONLY, $FILENAME); print "\n"; exit; } $VERBOSE && print "\n Processing one file only.\n"; # Just read one file: print BMPInfo($FILENAME); OptionalPause(); exit; ################################################## # v2022.9.9 # This function creates a formatted plain text chart # that includes all the information from a BMP # file's header. # # Usage: STRING = BMPInfo(BMPFILE) # sub BMPInfo { my $BMPFILE = FilterFileName($_[0]); (-e $BMPFILE && -f $BMPFILE) or return "\n File not found: $BMPFILE\n"; (-s $BMPFILE > 3) or return "\n File is too small: $BMPFILE\n"; ReadFile(my $HEADER, $BMPFILE, 0, 1200); # Read the first 1200 bytes. vec($HEADER, 1200, 8) = 0; # Fill in missing space with zero bytes. my $RealSize = -s $BMPFILE; # The first 18 bytes are standard in all BMP headers, but in order to interpret the rest of the file, # we must first get the BMPVersion value. The BMP Version Number is also called "Sub-header Length." my ($Signature, $FileSize, $Reserved, $DataPtr, $BMPVersion) = unpack('vVVVV', substr($HEADER, 0, 18)); # Error checking... my $ERR = ''; # Error messages my $ISBMP = ($Signature == 0x4D42) ? 1 : 0; if (!$ISBMP) { $ERR .= "\nError: Not a BMP file. File Signature doesn't match."; } if ($FileSize != $RealSize) { $ERR .= "\nWarning: Reported file size in BMP header doesn't match actual file size."; } if ($Reserved != 0) { $ERR .= "\nWarning: Reserved value should be 0 instead of $Reserved."; } if ($DataPtr >= 5000000) { $ERR .= "\nError: The header size should not be more than 1162 bytes,\n and this BMP file reports its header size is $DataPtr bytes."; } elsif ($DataPtr > 1162) { $ERR .= "\nWarning: It's very usual to have a header size that is more than 1162 bytes,\n and this BMP file reports its header size is $DataPtr bytes."; } if ($RealSize < $DataPtr) { $ERR .= "\nError: The BMP file header cannot be longer than the file itself!"; } if ($RealSize < $BMPVersion) { $ERR .= "\nError: Sub-header cannot be larger than the file itself!"; } if ($RealSize < 26) { $ERR .= "\nError: The smallest BMP file cannot be smaller than 26 bytes."; } my $VALIDVER = ' 12 16 40 52 54 56 58 64 108 124 '; if (index($VALIDVER, " $BMPVersion ") < 0) { $ERR .= "\nError: BMP Version number is unknown.\n It can only be one of these:$VALIDVER"; } my ($W, $H, $PalWidth, $Padding, $Planes, $BPP, $Compression, $DataSize, $XRes, $YRes, $MaxColors, $Colors, $ImportantColors, $RMask, $GMask, $BMask, $AMask) = (0) x 18; my $PalPtr = $BMPVersion + 14; if ($BMPVersion < 16) { $PalWidth = 3; ($W, $H, $Planes, $BPP) = unpack('vvvv', substr($HEADER, 18, 8)); } else # BMP VERSIONS 16, 40, 52, 54, 56, 58, 64, 108 and 124: { $PalWidth = 4; ($W, $H, $Planes, $BPP) = unpack('VVvv', substr($HEADER, 18, 12)); if ($BMPVersion > 16) { ($Compression, $DataSize, $XRes, $YRes, $Colors, $ImportantColors) = unpack('VVVVVV', substr($HEADER, 30, 24)); } } my $VFlip = 1; # By default, BMP files store the pixel data upside down, if ($H & 0x80000000) # but if the Image Height is negative, then it means { # that the image is stored right side up. $H = NEG32($H); $VFlip = 0; } # More error checking... my $VALIDBPP = ' 1 4 8 16 24 32 '; if (index($VALIDBPP, " $BPP ") < 0) { $ERR .= "\nError: The bits per pixel value is invalid.\n It can only be one of these:$VALIDBPP"; } $Planes == 1 or $ERR .= "\nWarning: Number of Planes is always 1, but in this image it is $Planes."; ($W) or $ERR .= "\nError: Image width cannot be zero!!!"; ($H) or $ERR .= "\nError: Image height cannot be zero!!!"; ($W != 1) or $ERR .= "\nWarning: Unusual image size: only 1 pixel wide."; ($H != 1) or $ERR .= "\nWarning: Unusual image size: only 1 pixel tall."; ($W <= 8192 && $H <= 16384) or $ERR .= "\nWarning: Unusual image size: Larger than 8192 x 16384 pixels."; if ($RealSize < 26 + int($W * $H * $BPP / 8)) { $ERR .= "\nWarning: The file is too small. Part of the image may be missing."; } if ($Compression == 0) {} # OK (Zero is always an acceptable value. It means that standard encoding is used with no compression.) elsif ($Compression == 1) { if ($BPP == 8) {} # OK (RLE8 compression) else { $ERR .= "\nWarning: RLE8 compression can only be used in 8-bit images."; } } elsif ($Compression == 2) { if ($BPP == 4) {} # OK (RLE4 compression) else { $ERR .= "\nWarning: RLE4 compression can only be used in 4-bit images."; } } elsif ($Compression == 3) { if ($BPP == 16 || $BPP == 24 || $BPP == 32) {} # OK (BITFIELDS encoding) else { $ERR .= "\nError: BITFIELDS encoding can only be used in 16-bit, 24-bit or 32-bit images!!!"; } } else { $ERR .= "\nError: Unknown compression or encoding used - $Compression.\n Valid vales are: 0 1 2 3"} my $PalSize = 0; # PalSize refers to the number of colors in the palette my $BytesPerPixel = 0; $MaxColors = FixMaxColor(int(($RealSize - 40) / ($W * $H + 1))); if ($BPP == 1) { $MaxColors = $PalSize = 2; $BytesPerPixel = 1; } elsif ($BPP == 4) { $MaxColors = $PalSize = 16; $BytesPerPixel = 1; } elsif ($BPP == 8) { $MaxColors = $PalSize = 256; $BytesPerPixel = 1; } elsif ($BPP == 16) { $MaxColors = 65536; $BytesPerPixel = 2; } elsif ($BPP == 24) { $MaxColors = 16777216; $BytesPerPixel = 3; } elsif ($BPP == 32) { $MaxColors = 16777216; $BytesPerPixel = 4; } # Calculate row length including padding. my $BitsPerRow = $W * $BPP; my $BytesPerRow = ($BitsPerRow + 7) >> 3; # Calculate bytes per row $Padding = $BytesPerRow & 3; # Calculate padding if ($Padding) { $Padding = 4 - $Padding; } # When padding is used, it adds a few zero bytes at the end of every row. if (($Compression == 1 && $BPP == 8) || ($Compression == 2 && $BPP == 4)) { $Padding = 0; } # No significant padding is used in RLE compressed bitmaps! elsif ($Padding * $H > 10000) { $ERR .= "\nWarning: Over 10,000 bytes are wasted in this image because of padding.\n You may fix this by changing the image width."; } ($Colors <= $MaxColors) or $ERR .= "\nWarning: Number of \"Colors\" ($Colors) cannot exceed total colors ($MaxColors)."; ($ImportantColors <= $MaxColors) or $ERR .= "\nWarning: Number of \"Important Colors\" cannot exceed total colors."; my $EstDataSize = $BytesPerRow * $H + 10; my $DataWaste = $RealSize - $EstDataSize + 4; my $ENDONWORD = ($BPP == 8 && ($Compression == 1 || $DataSize)) ? 1 : 0; # Some newer BMP files also include an RGBA mask, which is used to # decode the pixel data. So, we read these bit masks here: if ($Compression == 3 && $BMPVersion >= 56 && $DataPtr >= 70) { ($RMask, $GMask, $BMask, $AMask) = unpack('VVVV', substr($HEADER, 54, 16)); $MaxColors = POWER(2, CountBits($RMask | $GMask | $BMask)); } else # Use default values for 24-bit RGB images: { $RMask = 0x00000000; $GMask = 0x00000000; $BMask = 0x00000000; $AMask = 0x00000000; } # # WHAT ARE BIT MASKS? # # Most 24-bit BMP files store pixels in B8-G8-R8 format, which means 8 bits of blue value, # followed by 8 bits of green value, followed by 8 bits of red value. However, some newer BMP files # may also store pixels in a condensed format such as R5-G6-B5, X1-R5-G5-B5, A1-R5-G5-B5, X4-R4-G4-B4, # A4-R4-G4-B4, X8-R8-G8-B8 or A8-R8-G8-B8. How to interpret these codes? Well, for instance, # A4-R4-G4-B4 means that 4 bits of alpha value, 4 bits of red, 4 bits of green, and 4 bits of blue. # That comes out to 16 bits altogether. So, one pixel is stored in 2 bytes. If you look closely, the # numbers in each group adds up to 16, 24 or 32, which indicates how many bits are used to store one pixel. # # The bit masks are used to extract the R G B values. For example, if the red mask is 0xFF000000 then # that means you read a 32-bit value and the red value is stored in the highest 8 bits. If the red mask # happens to be 0x0000F000 then that means wherever that 'F' is that's where the red value is stored # within a 4-byte or 2-byte chunk of data. A pixel can be stored in either 2 bytes, 3 bytes or 4 bytes. # When we're looking at red mask 0x0000F000, it looks like the pixel is stored in 2 bytes and the red value # is stored in the highest 4-bit nibble of that 2-bytes. It also tells us that the range of the red values # is 0 to 15. So, only 16 different shades of red are used in this picture, which of course, means that # there is probably a loss of quality. And in these situations, the Compression value is set to '3' to # indicate that bit fields are used. (Compression values 1 and 2 indicate RLE compression which is ONLY # used for 16-color and 256-color BMP images. And Compression value 0 indicates that no compression is used # which is what most BMP pictures are like.) # # BMP image viewers and editors cannot work with 64-bit BMP images, although technically it would be possible # to create such things. The human eye can only distinguish 50,000 colors or so, and a 24-bit image can have # 16 million colors. A 64-bit image can have 280 trillion colors, which is just overkill. No practical use. # # WHAT IS ALPHA? # # The "Alpha" value in images refers to transparency. A 4-bit alpha value can store 16 values # 0-15 where 0 means not transparent and 15 means 100% transparent. So, whatever the pixel color, # if the transparency is set to 100%, then you will only see the background or whatever is behind # that pixel when the BMP image is displayed correctly. A value 8 represents 50% transparency, # and a value 5 represents 31.25% transparency when 4 bits are used to store transparency. # Transparency is often used in icons or filter images. In photos, it has no real use # and is very rare to encounter. # # USING PALETTE COLORS # # All BMP images with BPP 1, 4 or 8 contain a color palette. (BPP=Bits Per Pixel) # The color palette is located inside the header, right before the pixel data begins. # Each color can take up 3 bytes or 4 bytes depending on which BMP version is used. # Earlier versions used 3 bytes (RR GG BB). Newer versions use (AA RR GG BB). # These values are stored in little-endian order in the file, so when reading the palette, # you start reading the blue value first, then green, then red and finally alpha # (if the palette is 4 bytes per color). The first color entry in the palette is the # zero color. The second color is 1 and so on... A 2-color BMP picture might not be # black and white but white and black or red and green or any two colors. You have to # look up the colors in the palette to find the right color of a pixel. So, it's important # to read the palette first before decoding a 2-color or 16-color picture and not just # assume that 0 is black, 1 is blue, 2 is green and so forth. The palette might contain # completely different colors! # # Not all 256-color images have 256 colors defined in the palette! Some images can have # FEWER colors. And it's also possible to have MORE colors, although that # has no practical use. # -Zsolt # my $BGRS = (substr($HEADER, 54, 4) eq 'BGRs') ? 1 : 0; if ($Colors && $PalSize > $Colors) { $PalSize = $Colors; } if ($PalPtr <= 10 || $Compression == 3 || $PalPtr >= $DataPtr) { $PalSize = $PalWidth = $PalPtr = 0; } # Calculate print size. my $XDPI = int($XRes / 3.935); my $YDPI = int($YRes / 3.935); my $DefaultDPI = 720; if ($XDPI <= 0) { $XDPI = $DefaultDPI; } if ($YDPI <= 0) { $YDPI = $DefaultDPI; } my $XIN = int($W / $XDPI * 1000 + 1) / 100; # Calculate print size width in inches my $YIN = int($H / $YDPI * 1000 + 1) / 100; # Calculate print size height in inches my $XCM = int($W / $XDPI * 2540 + 1) / 100; # Calculate print size width in cm my $YCM = int($H / $YDPI * 2540 + 1) / 100; # Calculate print size height in cm my $PrintSize = "$XIN x $YIN\" ($XCM x ${YCM}cm)"; my $DPI = ($XDPI == $YDPI ? "$XDPI DPI" : "$XDPI x $YDPI DPI"); my $TAB = "\n "; my $REPORT = "$TAB+=====================================================================SIG==+" . "$TAB| File: ff |" . "$TAB|------------------------------------IX--------------------------------FX--|" . "$TAB| Bits Per Pixel ....... Z P1 |" . "$TAB| Total Pixels ......... RR |" . "$TAB| Important Colors ..... IC Header Size .................HX bytes |" . "$TAB| Palette Colors ....... Q Real File Size .................F2 bytes |" . "$TAB| Palette Width ........ J Reported File Size .................F1 bytes |" . "$TAB| BMP Version .......... BV Pixel Data Size .................DZ bytes |" . "$TAB| Reserved Value ....... ~ Padding Per Row ..................* bytes |" . "$TAB| Number of Planes ..... ` Row Length .................._ bytes |" . "$TAB| Encoding ............. & |" . "$TAB| Print Size ........... PS |" . "$TAB| Print Resolution ..... DD AM00......... Alpha Mask |" . "$TAB| Pixel Data Ptr ....... DX RM00......... Red Mask |" . "$TAB| Palette Ptr .......... PX GM00......... Green Mask |" . "$TAB| BMP Health ........... HLT BM00......... Blue Mask |" . "$TAB| ^ FLG |" . "$TAB+---------------------------------------------------------------------ERR--+\n"; my $Flags = ' '; if ($ENDONWORD || $BGRS) { $Flags = "Flags:[ " .($ENDONWORD ? 'ENDONWORD ' : '') . ($BGRS ? 'BGRS ' : '') . '] '; } my $ABitCount = CountBits($AMask); if ($ABitCount > 8) { $ERR .= "\nWarning: Can't use more than 8 bits per channel! ALPHA channel is using $ABitCount bits."; } my $RBitCount = CountBits($RMask); if ($RBitCount > 8) { $ERR .= "\nWarning: Can't use more than 8 bits per channel! RED channel is using $RBitCount bits."; } my $GBitCount = CountBits($GMask); if ($GBitCount > 8) { $ERR .= "\nWarning: Can't use more than 8 bits per channel! GREEN channel is using $GBitCount bits."; } my $BBitCount = CountBits($BMask); if ($BBitCount > 8) { $ERR .= "\nWarning: Can't use more than 8 bits per channel! BLUE channel is using $BBitCount bits."; } if ($RBitCount || $GBitCount || $BBitCount) { # If one of the R G B bit masks is used, then ALL must be used! # The ALPHA channel is always optional, so we don't issue an error if it's missing. if ($RBitCount == 0) { $ERR .= "\nWarning: If one of the R G B bit masks is used, then ALL must be used! The RED channel is not used."; } if ($GBitCount == 0) { $ERR .= "\nWarning: If one of the R G B bit masks is used, then ALL must be used! The GREEN channel is not used."; } if ($BBitCount == 0) { $ERR .= "\nWarning: If one of the R G B bit masks is used, then ALL must be used! The BLUE channel is not used."; } } if ($Compression == 3 && $BPP >= 16) { if ($RBitCount == 0) { $ERR .= "\nError: RED channel mask is missing!"; } if ($GBitCount == 0) { $ERR .= "\nError: GREEN channel mask is missing!"; } if ($BBitCount == 0) { $ERR .= "\nError: BLUE channel mask is missing!"; } } if ($Compression == 0 && ($RBitCount == 0 && $GBitCount == 0 && $BBitCount == 0)) { if ($BPP > 8) { if ($BPP == 32) { $ABitCount = 8; } $RBitCount = $GBitCount = $BBitCount = 8; $PalPtr = 0; $PalWidth = 0; } } my $Format = '--'; if ($BPP >= 16) { my $A = ''; # Number of bits used for the alpha channel my $X = ''; # Number of unused bits per pixel if ($Compression == 0) { if ($BPP == 32) { $A = 'A8-'; }} elsif ($Compression == 3) { if ($ABitCount) { $A = "A$ABitCount-"; } $X = $BPP - $ABitCount - $RBitCount - $GBitCount - $BBitCount; $X = ($X) ? "X$X-" : ''; } $Format = '[ ' . $A . $X . "R$RBitCount-G$GBitCount-B$BBitCount ]"; # Number of bits used for red, green and blue } my $Errors = CountStr($ERR, "\nError: "); my $Warnings = CountStr($ERR, "\nWarning: "); my $HEALTH = 100 - $Errors * 20; $HEALTH > 0 or $HEALTH = 0; my $ErrorSummary = ($Errors ? " ERRORS=$Errors " : '---') . ($Warnings ? "--- WARNINGS=$Warnings " : '---'); my $ImageSize = '[ ' . Commify($W) . ' x ' . Commify($H) . ' ]'; OverwriteFromRight($REPORT, 'SIG', sprintf('[ %0.04X ]', $Signature)); OverwriteFromRight($REPORT, 'ERR', $ErrorSummary); OverwriteFromLeft($REPORT, 'FLG', $Flags); OverwriteFromLeft($REPORT, 'HLT', "$HEALTH % " . (!$ISBMP ? '(Not a BMP file)' : '')); OverwriteFromRight($REPORT, 'FX', $Format); OverwriteFromCenter($REPORT, 'IX', $ImageSize); OverwriteFromLeft($REPORT, 'IC', $ImportantColors . ' '); OverwriteFromRight($REPORT, '*', ' ' . $Padding); OverwriteFromRight($REPORT, '_', ' ' . Commify($BytesPerRow)); OverwriteFromRight($REPORT, 'P1', ' (' . Commify($MaxColors) . ' colors)'); OverwriteFromLeft($REPORT, 'RR', Commify($W * $H)); OverwriteFromLeft($REPORT, '~', $Reserved); OverwriteFromLeft($REPORT, '`', $Planes); if ($Compression == 0) { $Compression .= '=RAW'; } elsif ($Compression == 1) { $Compression .= '=RLE8 Compressed'; } elsif ($Compression == 2) { $Compression .= '=RLE4 Compressed'; } elsif ($Compression == 3) { $Compression .= '=BITFIELDS (using RGBA masks)'; } else { $Compression .= ' ???'; } OverwriteFromLeft($REPORT, '&', $Compression); OverwriteFromLeft($REPORT, '^', $VFlip ? 'The image is stored UPSIDE DOWN. (default)' : 'The image is stored RIGHT SIDE UP.'); OverwriteFromRight($REPORT, 'DZ', ' ' . Commify($DataSize)); OverwriteFromLeft($REPORT, 'Z', $BPP); OverwriteFromLeft($REPORT, 'Q', $PalSize); OverwriteFromLeft($REPORT, 'J', $PalWidth); OverwriteFromLeft($REPORT, 'PX', sprintf('0x%0.08x', $PalPtr)); OverwriteFromLeft($REPORT, 'DX', sprintf('0x%0.08x', $DataPtr)); OverwriteFromLeft($REPORT, 'PS', $PrintSize); OverwriteFromLeft($REPORT, 'DD', $DPI); OverwriteFromLeft($REPORT, 'BV', $BMPVersion); OverwriteFromLeft($REPORT, 'CC', $BPP); OverwriteFromLeft($REPORT, 'AM00', sprintf('%0.08x ', $AMask)); OverwriteFromLeft($REPORT, 'RM00', sprintf('%0.08x ', $RMask)); OverwriteFromLeft($REPORT, 'GM00', sprintf('%0.08x ', $GMask)); OverwriteFromLeft($REPORT, 'BM00', sprintf('%0.08x ', $BMask)); OverwriteFromRight($REPORT, 'F1', ' ' . Commify($FileSize)); OverwriteFromRight($REPORT, 'F2', ' ' . Commify($RealSize)); OverwriteFromRight($REPORT, 'HX', ' ' . $DataPtr); OverwriteFromLeft($REPORT, 'ff', TruncateStr($BMPFILE, 66)); # Load BMP color palette. my $Palette = ''; if ($BPP <= 8 && $PalSize) { my $PTR = $PalPtr; for (my $i = 0; $i < $PalSize; $i++) { $Palette .= "\0" . reverse(substr($HEADER, $PTR, 3)); # RGB values are stored backwards. Of course. $PTR += $PalWidth; } } if ($BPP <= 8 && $PalSize) { $REPORT .= "$TAB This image includes a color palette with $PalSize colors:\n"; my $PTR = $PalPtr; for (my $i = 0; $i < $PalSize; $i++, $PTR += $PalWidth) { $REPORT .= (($i & 7) == 0 ? $TAB : ' ') . unpack('H*', substr($HEADER, $PTR, $PalWidth)); } $REPORT .= "\n$TAB" . ('-' x 75) . "\n"; } # Add error report. if (($Errors || $Warnings) && ($VERBOSE || $Errors < 5)) { $ERR =~ s/\n/\n /g; $REPORT .= $ERR . "\n\n"; } return $REPORT; } ################################################################# # Corrects invalid MaxColor values. Provide any number, and this # function will return one of these integers: 2, 16, 256, # 65536 or 16777216. # # Usage: INTEGER = FixMaxColor(MAXCOLOR) # sub FixMaxColor { my $MaxColors = defined $_[0] ? $_[0] : 2; $MaxColors < 16777216 or return 16777216; foreach (2, 16, 256, 65536, 16777216) { if ($MaxColors <= $_) { $MaxColors = $_; last; } } return $MaxColors; } ################################################################# # # This function reads the contents of a folder and calls # BMPInfo() for each matching file that was found. # # Usage: SearchDIR(PATH, FILENAME_PATTERN) # sub SearchDIR { @_ == 2 or return 0; defined $_[0] && defined $_[1] or return 0; my ($PATH, $PATTERN) = @_; length($PATH) && length($PATTERN) or return 0; $PATH .= '\\'; $PATH =~ tr|\/|\\|; $PATH =~ tr|\\||s; $VERBOSE && print "\nReading directory: $PATH\n"; my $FULLNAME; my @SUBDIRLIST; my $BMPFILECOUNT = 0; opendir(my $DIR, $PATH) or return; while (my $NAME = readdir $DIR) { $FULLNAME = "$PATH$NAME"; if (-d $FULLNAME) # Save list of sub-directories if RECURSIVE == 1 { # Save directory name unless it starts with '.' if ($RECURSIVE && (vec($NAME, 0, 8) != 46)) { push (@SUBDIRLIST, $FULLNAME); } } elsif (-f $FULLNAME) { if ($NAME =~ m/.BMP$/i) { $BMPFILECOUNT++; } if (isMatch(uc($NAME), uc($PATTERN))) { print BMPInfo($FULLNAME); OptionalPause(); } } } closedir $DIR; $BMPFILECOUNT && $VERBOSE && print "\n\n! $BMPFILECOUNT BMP file(s) were found in $PATH\n\n\n"; # Check sub-directories... if ($VERBOSE == 0 && @SUBDIRLIST) { print '.'; } foreach (@SUBDIRLIST) { SearchDIR($_, $PATTERN); } return 0; } ################################################## # Will pause the program if the /PAUSE switch was used # or if an argument is used. # Usage: OptionalPause( [PAUSE_ANYWAY] ) # sub OptionalPause { if ($PAUSE || @_) { print "\t\t\t< < PRESS [ENTER] TO CONTINUE > >\n"; $a = ; $a = 0; } return 0; } ################################################## # v2022.9.10 # Splits a full file name and stores the path # portion of the file name without the trailing # slash or backslash in $a and the file name in $b. # # Usage: SplitPathName(FULLNAME) # sub SplitPathName { my $PATH = defined $_[0] ? $_[0] : ''; $PATH =~ tr|\\|/|; my $P = rindex($PATH, '/'); if ($P >= 0) { $a = substr($PATH, 0, $P + 1); $b = substr($PATH, $P + 1); } else { if ($PATH =~ m/^[a-zA-Z]{1}:$|^[.]*/ && !($PATH =~ m/[*?.]+/)) { $a = $PATH; $b = ''; } else { $a = ''; $b = $PATH; } } $a = FixPath($a); return 0; } ################################################## # Formats the time like this: Sat Sep 10 2022 6:13p # Usage: STRING = TimeStamp([TIME]) # sub TimeStamp { my @D = localtime(defined $_[0] ? $_[0] : time); my $M = substr('JanFebMarAprMayJunJulAugSepOctNovDec', $D[4] * 3, 3); my $W = substr('SunMonTueWedThuFriSat', $D[6] * 3, 3); my $A = $D[2] > 11 ? 'p' : 'a'; $D[2] or $D[2] = 12; $D[2] < 13 or $D[2] -= 12; return "$W $M " . sprintf('%d %.04d %d:%.02d', $D[3], (1900+$D[5]), $D[2], $D[1]) . $A; } ################################################## # Returns the Perl version and CPU architecture. # sub PerlVersion { return "Perl $] " . (length(pack('P', 0)) << 3) . '-bit'; } ################################################## # Prints the description of this program. # sub PrintHelp { print PerlVersion(), " $^O, ", TimeStamp(), "\n\n $0\n\n"; ReadFile(my $S, $0, 0, 0x800); my $P = 1 + index($S, '# '); my $E = 1 + index($S, '###', $P); $E && $P or die " Failed to print script description.\n"; $S = substr($S, $P, $E - $P); $S =~ tr/#//d; print $S; OptionalPause(); } ################################################## # # This function searches STRING to see if any of its # characters match any of the characters of SUBSTR. # Returns 1 if a match was found; returns 0 otherwise. # Usage: INTEGER = FindChar(STRING, SUBSTR) # sub FindChar { defined $_[0] && defined $_[1] or return 0; length($_[0]) or return 0; my $i = length($_[1]); while ($i--) { index($_[0], substr($_[1], $i, 1)) < 0 or return 1; } return 0; } ################################################## # # This function returns true if a filename matches # a certain wildcard pattern. There may be several # question marks in the search pattern, but only one # asterisk is allowed! The matching is NOT case sensitive! # Usage: INTEGER = isMatch(FILENAME, WILDCARD) # Example: isMatch("New_Document.txt", "n*.txt") ---> 1 # sub isMatch { my $F = defined $_[0] ? uc($_[0]) : ''; my $W = defined $_[1] ? uc($_[1]) : ''; length($F) && length($W) or return 0; # If there are invalid characters... if (FindChar($W.$F, '<|>')) { return 0; } # If there aren't any wildcards at all... if (FindChar($W, '*?') == 0) { return ($F eq $W) ? 1 : 0; } # Match what's before the asterisk... return 0 unless (_isMatch($F, $W, 1)); # Match what comes after the asterisk... return _isMatch($F, $W, -1); } ################################################## # # This function is called by isMatch() to compare # two strings until the first asterisk. Returns 1 # if both strings match until the first asterisk. # This function can start comparing strings starting # from the beginning or starting from the end! # DIRECTION must be either 1 or -1. # Usage: INTEGER = _isMatch(FILENAME, WILDCARD, DIRECTION) # sub _isMatch { my $F = shift; my $f; my $LF = length($F)-1; my $W = shift; my $w; my $LW = length($W)-1; my $DIR = shift; my $STOP = $LW; my $START = 0; my $FSTART = 0; if ($DIR < 0) { $STOP = 0; $START = $LW; $FSTART = $LF; } while ($START != $STOP) { $w = vec($W, $START, 8); # Grab byte from wildcard pattern $f = vec($F, $FSTART, 8); # Grab byte from filename $START += $DIR; $FSTART += $DIR; if ($w == 42) # ASTERISK? { return 1; } else { # If the character is "?" then skip, but if # it's not "?", then the characters must match. if ($w != 63) { ($f == $w) or return 0; } } } return 1; } ################################################## # v2021.3.3 # This function cuts a text to a certain length # and adds '...' at the beginning if it was too long. # Usage: STRING = TruncateStr(STRING, MAXLEN) # sub TruncateStr { @_ == 2 or return ''; my $S = defined $_[0] ? Trim($_[0]) : ''; my $MAXLEN = defined $_[1] ? $_[1] : 20; my $PREFIX = '...'; $MAXLEN > 3 or return $PREFIX; return ($MAXLEN > length($S)) ? $S : $PREFIX . substr($S, 0, $MAXLEN - 3); } ################################################## # v2022.9.5 # This function removes illegal characters from # a file name such as: $ % ? * < > | " \t \r \n \0 # and any character whose ASCII value is 0-31. # # Usage: FILENAME = FilterFileName(FILENAME) # sub FilterFileName { my $F = defined $_[0] ? $_[0] : ''; $F =~ tr`<>*%$?\x00-\x1F\"\|``d; return $F; } ################################################## # v2022.9.5 # This function reads a binary file into memory and # returns 1 on success or zero if something went wrong. # # An optional 3rd argument will move the file pointer # before reading. And an optional 4th argument can # limit the number of bytes to read. # # The buffer will be overwritten with the file's # contents. If an error occurs, then the buffer will # be empty and the return value will be zero. # # Usage: STATUS = ReadFile(FILENAME, BUFFER, [START, [LENGTH]]) # sub ReadFile { my $FILE = defined $_[1] ? $_[1] : ''; # File name my $PTR = defined $_[2] ? $_[2] : 0; # File pointer my $N = defined $_[3] ? $_[3] : 0; # Bytes to read # First we find out if the buffer is a scalar or a scalar reference. # Perl creates a double copy of the read buffer unless we use a reference. my $REF = length(ref($_[0])); if ($REF == 0) { $REF = \$_[0]; } # Let's create a reference. elsif ($REF == 6) { $REF = $_[0]; } # It's already a reference. else { return 0; } # It's not a scalar and not a reference. # Initialize our read buffer. $$REF = ''; -e $FILE || return 0; # Let's check if the file exists. -f $FILE || return 0; # Check if it's a plain file. my $SIZE = -s $FILE; # Get file size. $SIZE || return 0; # File size is zero? # Make sure all parameters are valid. if ($N < 0 || $PTR < 0 || $PTR >= $SIZE) { return 0; } # The sysread() function will reserve exactly $N bytes of memory # as specified in its third argument even if the file is smaller. # So, it is a good idea to check and make sure # that $N does not exceed the file's length. $SIZE -= $PTR; # Calculate the maximum value for $N. if ($N == 0 || $N > $SIZE) { $N = $SIZE; } local *H; sysopen(H, $FILE, 0) || return 0; # Try to open file for read only. $PTR && sysseek(H, $PTR, 0); # Move the file pointer if necessary. sysread(H, $$REF, $N); # Read $N number of bytes from file into close H; # our read buffer which is referenced by $REF. return 1; } ################################################## # v2022.7.11 # Returns the current directory. (If a drive letter # is provided in the first argument, then it returns # the current directory for that drive. This only # applies to DOS and Windows where each drive letter # can have its own current directory. If no drive # letter is provided, then it returns the current # directory of the current drive under DOS and Windows.) # # Usage: STRING = GetCurrentDirectory([DRIVE]) # sub GetCurrentDirectory { if ($^O =~ /DOS|MSWIN/i) { my $DRV = defined $_[0] ? substr(Trim($_[0]), 0, 2) : ''; return Trim(`CD $DRV`); } return Trim(`pwd`); } ################################################## # v2022.8.27 # Changes the file name separator to forward slash # or backslash depending on the current OS. # Resolves . and .. in path strings. # Eliminates duplicate slashes. # # Examples: # ../.. => ../.. # a/b/././../../.. => .. # /a/b/c/./../x.txt => /a/b/x.txt # a/../../../x.txt => ../../x.txt # /a/b/../../../x.txt => /x.txt # # Paths can contain too many .. which point to nowhere. # In that, case the function ignores the error and # tries to resolve it as much as possible: # # /../ => / # /../../a/b/c => /a/b/c # # Usage: STRING = FixPath(PATH) # sub FixPath { my $P = defined $_[0] ? $_[0] : ''; $P =~ tr`\x00-\x1F\"\|<>``d; # Remove illegal characters: < > | " \t \r \n \0 $P =~ tr`\\`/`; # Change all backslash to forward slash. $P =~ tr|\/||s; # Remove duplicate slashes. my $DRV = ''; if (vec($P, 1, 8) == 58) { $DRV = substr($P, 0, 2); $P = substr($P, 2); } my $ABS = ''; if (vec($P, 0, 8) == 47) { $ABS = 1; $P = substr($P, 1); } # Split the path string along '/' characters my @D = split(/\//, $P); my $i = @D; # First, let's eliminate '.' from the path string. while ($i--) { $D[$i] = Trim($D[$i]); if (length($D[$i]) == 0 || $D[$i] eq '.') { splice(@D, $i, 1); } } # Next, we resolve '..' in the path string. for ($i = 0; $i < @D; $i++) { if ($D[$i] eq '..') { if ($i == 0) { # If the path string begins with .. # then we can do one of two things: either eliminate # it or leave it. We eliminate it if the path is an absolute path, # because you can't go one level higher than / # If the path looks like ../a.txt then it's a relative path, # and we have to leave it like it is. But if it looks like # /../a.txt then we eliminate those, because /../a.txt # makes no sense. This is an invalid path. if ($ABS) { splice(@D, $i--, 1); } next; } # If we encounter a '..' but the previous string was also '..' # then we can't resolve it. Two '..' separated by '/' don't # cancel each other out. We skip this and move on... if ($D[$i - 1] eq '..') { next; } # Okay, if we can cancel out the previous string, then we use # the splice() function to erase the current '..' and the string before it. splice(@D, $i - 1, 2); $i -= 2; } } # Here we rebuild the original path string. $P = $DRV . ($ABS ? '/' : '') . join('/', @D); $P =~ tr`/``s; # Remove duplicate slashes just in case. -- THIS LINE MAY BE UNNECESSARY. WILL HAVE TO REVIEW... # Change all forward slashes to backslash on DOS/Windows. if ($^O =~ m/DOS|MSWIN/i) { $P =~ tr`/`\\`; } # And we're done! return $P; } ################################################## # v2022.2.11 # This function removes whitespace from before and # after STRING. Whitespace is here defined as any # character whose ASCII value is less than 33. # This includes spaces, tabs, esc, null, vertical tab, # new lines, etc. # Usage: STRING = Trim(STRING) # sub Trim { my $P = 0; defined $_[0] or return ''; (my $L = length($_[0])) or return ''; # In an earlier version, I used vec() to get characters, # but I was told that it will throw an error when working on # Unicode characters. So, I replaced it with ord(substr()). while ($P <= $L && ord(substr($_[0], $P++, 1)) < 33) {} $P--; while ($P <= $L && ord(substr($_[0], $L--, 1)) < 33) {} return substr($_[0], $P, $L - $P + 2); } ################################################## # v2019.11.23 # Counts how many times SUBSTR occurs in STRING and # returns the number. The search is case sensitive. # Usage: INTEGER = CountStr(STRING, SUBSTR) # sub CountStr { defined $_[0] or return 0; defined $_[1] or return 0; (my $LA = length($_[0])) or return 0; (my $LB = length($_[1])) or return 0; $LA >= $LB or return 0; my $COUNT = 0; for (my $i = 0; $i < $LA; $i += $LB) { $i = index($_[0], $_[1], $i); $i >= 0 or last; $COUNT++; } return $COUNT; } ################################################## # v2022.8.10 # This function allows you to create nice reports # in memory where the numbers must be aligned to # the right. # # See Also: OverwriteFromLeft() and OverwriteFromCenter() # # This function looks for the first occurrence of string B # which we call a "MARKER" within string A which is the # report input string. If the marker is found, it will # be overwritten with string C starting from the right, # so the output will look like the value is aligned right. # # Here is an example: # String A = '...........X lbs. ' <= original string # String B = 'X' <= marker # String C = '3,587.42' <= paste # Output = '....3,587.42 lbs. ' <= result # # As you can see, the number was placed # where the X was using right alignment. # # NOTE: This function modifies the contents of the first argument!! # # Usage: OverwriteFromRight(STRING_A, STRING_B, STRING_C) # sub OverwriteFromRight { my $A = defined $_[0] ? $_[0] : ''; my $B = defined $_[1] ? $_[1] : ''; my $C = defined $_[2] ? $_[2] : ''; my $FOUND = index($A, $B); $FOUND >= 0 or return 0; my $POS = $FOUND + length($B) - length($C); if ($POS < 0) { if (abs($POS) < length($C)) { $C = substr($C, length($C) + $POS) } else { return 0; } } substr($_[0], $POS, length($C)) = $C; return 1; } # # # # # # # # # # # # # # # # # # # # # # # # # sub OverwriteFromLeft { my $A = defined $_[0] ? $_[0] : ''; my $B = defined $_[1] ? $_[1] : ''; my $C = defined $_[2] ? $_[2] : ''; my $P = index($A, $B); $P >= 0 or return 0; substr($_[0], $P, length($C)) = $C; return 1; } # # # # # # # # # # # # # # # # # # # # # # # # # sub OverwriteFromCenter { my $A = defined $_[0] ? $_[0] : ''; my $B = defined $_[1] ? $_[1] : ''; my $C = defined $_[2] ? $_[2] : ''; my $P = index($A, $B); $P >= 0 or return 0; $P = $P - int((length($C) / 2) + 0.5); if ($P < 0) { $P = 0; } substr($_[0], $P, length($C)) = $C; return 1; } ################################################## # This function inserts commas into a number at # every 3 digits and returns a string. # Usage: STRING = Commify(INTEGER) # Copied from www.PerlMonks.org/?node_id=157725 # sub Commify { my $N = reverse $_[0]; $N =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g; return scalar reverse $N; } ################################################## # v2022.8.28 # This function counts how many 1s occur in a # 32-bit integer when converted to binary format. # # Usage: INTEGER = CountBits(INTEGER) # sub CountBits { my $N = defined $_[0] ? $_[0] : 0; my $MASK = 1; my $COUNT = 0; for (;;) { if ($N & $MASK) { $COUNT++; } if ($MASK == 0x80000000) { last; } $MASK <<= 1; } return $COUNT; } ################################################## # v2022.8.28 # This function raises X to the Nth power. # # Usage: INTEGER = POWER(X, N) # sub POWER { my $X = defined $_[0] ? $_[0] : 0; my $N = defined $_[1] ? $_[1] : 0; $N > 0 or return 1; my $PWR = 1; while ($N--) { $PWR *= $X; } return $PWR; } ################################################## sub CEIL { int($_[0]) + ($_[0] - int($_[0]) > 0) } sub FLOOR { my $i = int($_[0]); $i < 0 ? ($_[0] - $i ? $i - 1 : $i) : $i; } sub ROUND { int(($_[0] < 0) ? ($_[0] - 0.5) : ($_[0] + 0.5)); } sub NEG32 { defined $_[0] && $_[0] ? ~$_[0] + 1 & 0xffffffff : 0; } ##################################################