Win32::GUI::BitmapInline - Inline bitmap support for Win32::GUI

    perl -MWin32::GUI::BitmapInline -e "inline('image.bmp')" >>script.pl

    use Win32::GUI();
    use Win32::GUI::BitmapInline ();

    $Bitmap1 = Win32::GUI::BitmapInline->new( q(
    Qk32AAAAAAAAAHYAAAAoAAAAEAAAABAAAAABAAQAAAAAAIAAAAAAAAAAAAAAABAAAAAQAAAAAAAA
    AACcnABjzs4A9/f3AJzO/wCc//8Azv//AP///wD///8A////AP///wD///8A////AP///wD///8A
    ////AHd3d3d3d3d3d3d3d3d3d3dwAAAAAAAABxIiIiIiIiIHFkVFRUVEQgcWVVRUVFRCBxZVVVVF
    RUIHFlVVVFRUUgcWVVVVVUVCBxZVVVVUVFIHFlVVVVVVQgcWZmZmZmZSBxIiIiIRERF3cTZlUQd3
    d3d3EREQd3d3d3d3d3d3d3d3
    ) );

    perl -MWin32::GUI::BitmapInline -e "inline('image.bmp','IMAGE')"

    $IMAGE = new Win32::GUI::BitmapInline( q( ...

    perl -MWin32::GUI::BitmapInline -e "inline('harrow.cur')"  >>script.pl
    perl -MWin32::GUI::BitmapInline -e "inline('guiperl.ico')" >>script.pl

    $Cursor1 = Win32::GUI::BitmapInline->newCursor( q( ...
    $Icon2 = Win32::GUI::BitmapInline->newIcon( q( ...

  my $bitmap = Win32::GUI::BitmapInline->new($data);

package Win32::GUI::BitmapInline;
use strict;
use warnings;

use Win32::GUI();
use MIME::Base64(); # Core since ???
use File::Spec();   # Core since ???

# Make Win32::GUI::BitmapInline thread-safe for ithreads.
# Stolen from Test::More
BEGIN {
    use Config;
    # Load threads::shared when threads are turned on.
    # 5.8.0's threads are so busted we no longer support them.
    if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'}) {
        require threads::shared;

        # Hack around YET ANOTHER threads::shared bug.  It would 
        # occassionally forget the contents of the variable when sharing it.
        # So we first copy the data, then share, then put our copy back.
        *share = sub (\[$@%]) {
            my $type = ref $_[0];
            my $data;

            if( $type eq 'HASH' ) {
                %$data = %{$_[0]};
            }
            elsif( $type eq 'ARRAY' ) {
                @$data = @{$_[0]};
            }
            elsif( $type eq 'SCALAR' ) {
                $$data = ${$_[0]};
            }
            else {
                die("Unknown type: ".$type);
            }

            $_[0] = &threads::shared::share($_[0]);

            if( $type eq 'HASH' ) {
                %{$_[0]} = %$data;
            }
            elsif( $type eq 'ARRAY' ) {
                @{$_[0]} = @$data;
            }
            elsif( $type eq 'SCALAR' ) {
                ${$_[0]} = $$data;
            }
            else {
                die("Unknown type: ".$type);
            }

            return $_[0];
        };
    }
    # 5.8.0's threads::shared is busted when threads are off
    # and earlier Perls just don't have that module at all.
    else {
        *share = sub { return $_[0] };
        *lock  = sub { 0 };
    }
}

use Exporter();
our @ISA = qw(Exporter);
our @EXPORT = qw(inline);

our $VERSION = "0.03";
$VERSION = eval $VERSION;

# Thread-safe, temporary filename generator
# We'd like to use File::Temp, but it's not in core.  This
# is probably good enough
{
    my $file_count = 0;
    share($file_count);
    sub _tmp_filename {
        my $count;
        { lock($file_count); $count = ++$file_count; }

        return "~Win32GUIBitmapInLine.$$.$count.tmp";
    }
}

# new(), defaulting to $type = "Win32::GUI::Bitmap" exists as a public api
# for backwards compatibility
sub new {
    my($class, $data, $type) = @_;
    $type = 'Win32::GUI::Bitmap' unless $type;

    # Find a suitable temp directory.  File::Spec->tmpdir givs us
    # a writable tmp dir from a list, or the current directory (whether or not
    # writable) if it can't find a writable directory in any of the usual
    # places. It'd be nice to use IO::File->new_tmpfile(), but we need the
    # name of the file to pass to Win32::GUI::Bitmap->new().
    my $tmpfile = File::Spec->catfile(File::Spec->tmpdir(), _tmp_filename());

    # On perl 5.6 we have problems with tainted data in open().
    # so (naughtily) untaint our TMP file name.  In later versions
    # of File::Spec tmpdir() won't give us a tained answer.
    if($[ < 5.008000) {
        $tmpfile =~ /^(.*)$/;
        $tmpfile = $1;
    }

    open(my $tmpfh, '>', $tmpfile);
    if(!$tmpfh) {
        warn(qq(Failed to open tmp file '$tmpfile' for writing));
        return undef;
    }

    binmode($tmpfh);
    print $tmpfh MIME::Base64::decode($data);
    close($tmpfh) or warn(qq(Failed to close tmp file '$tmpfile')); 

    my $obj = $type->new($tmpfile);

    unlink($tmpfile) or warn(qq(Failed to remove tmp file '$tmpfile'));

    return $obj;  
}

sub newCursor {
    my($class, $data) = @_;

    return $class->new($data, 'Win32::GUI::Cursor');
}

sub newIcon {
    my($class, $data) = @_;

    return $class->new($data, 'Win32::GUI::Icon');
}

# Thread-safe counter
{
    my $object_count = 0;
    share($object_count);
    sub _new_count {
        my $count;
        {lock($object_count); $count = ++$object_count; }
        return $count;
    }
}

sub inline {
    my ($filename, $name) = @_;

    my $type = 'Bitmap';
    $type = 'Icon'   if $filename =~ /\.ico$/i;
    $type = 'Cursor' if $filename =~ /\.cur$/i;

    $name = $type . _new_count() unless $name;

    my $bmpfh;
    if(!open($bmpfh, '<', $filename)) {
        warn (qq(Can't open file '$filename' for reading));
        return undef;
    }
    binmode($bmpfh);

    # use new() (not newBitmap()) for backwards compatability
    $type = q() if $type eq 'Bitmap';
    my $ret = "\$$name = Win32::GUI::BitmapInline->new$type( q(\n";
    {
        local $/ = undef; # Slurp
        $ret .= MIME::Base64::encode( <$bmpfh> );
    }
    $ret .= ") );\n";

    close($bmpfh) or warn(qq(Failed to close '$filename')); 

    # print to currrently selected output filehandle
    print $ret;

    return length($ret);
}

1; # End of BitmapInline.pm

__END__