#!/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 = <STDIN>;
    $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; }
##################################################