perldoc -m Cava::Pack
######################################################################
+#######
## Name:        Cava::Pack.pm
## Author:      Mark Dootson
## Created:     01/02/2007
## Copyright:   (c) 2007 Mark Dootson
## Licence:     This program is free software; you can redistribute it
+ and/or
##              modify it under the same terms as Perl itself
######################################################################
+#######

package Cava::Pack;
require DynaLoader;
use vars qw(@ISA $VERSION $RESPATH $BINPATH $TMPPATH $__cvpk_info);
@ISA = qw(DynaLoader);
$VERSION = '1.1.0.8';
bootstrap Cava::Pack $VERSION;
use strict;

$BINPATH = GetFullPathName($0);
$BINPATH = CodePath($BINPATH);

{
    my @parts = split(/[\/\\]/, $BINPATH);
    pop(@parts);
    $BINPATH = join('/', @parts);
}

$RESPATH = $BINPATH;
{
    my @parts = split(/[\/\\]/, $RESPATH);
    pop(@parts);
    $RESPATH = join('/', @parts) . '/res';
}

$TMPPATH = '';

#---------------------------------------------------------
# set default product Info
#---------------------------------------------------------
#  Note - defaults when packaged are set via Cava Packager

{
    $__cvpk_info = { ProductName => 'Product Name',
                     ProductVersion => '0.0.0.0',
                     Vendor => 'Vendor Name',
                     Copyright => 'Copyright Notice',
                     Trademarks => 'Trademarks',
                     Comments => 'Comments',
                     FileDescription => 'Perl Script',
                     FileInternalName => 'default.pl',
                     FileVersion => '0.0.0.0',
                     FileOriginalName => 'default.exe',
                   };

}

#---------------------------------------------------------

sub __cvpk_purge_dir { 
    my $dirpath = shift;
    my $rm = shift || 0;
    $dirpath = CodePath($dirpath);
    return 0 if(! $dirpath);
    my @tempfiles = ();
    eval {
        opendir(DIR, $dirpath) or return 0;
        @tempfiles = readdir(DIR);
        closedir DIR;
    };
    foreach my $tmp (@tempfiles) {
        next if(($tmp eq '.') || ($tmp eq '..'));
        my $newtmp = qq($dirpath/$tmp);
        if(-l $newtmp) {
            eval {
                unlink CodePath($newtmp);
            };
        } elsif(-d $newtmp) {
            __cvpk_purge_dir($newtmp, 1);
        } elsif(-f $newtmp) {
            eval {
                unlink CodePath($newtmp);
            };
        }
    }
    eval {
        if($rm) { rmdir $dirpath; }
    };
}

sub CAVA_FOLDER_PERSONAL       ()       { 0x0005 }    
sub CAVA_FOLDER_LOCAL_APPDATA  ()       { 0x001C }    
sub CAVA_FOLDER_APPDATA        ()       { 0x001A }     
sub CAVA_FOLDER_COMMON_APPDATA ()       { 0x0023 }    

sub Packaged () { 0 }

sub Resource {
    my $filename = shift;
    return qq($RESPATH/$filename);
}

sub CodePath {
    my $path = shift;
    # return a perl happy path.
    # forward slash delimiters
    # individual directory/ file names converted 
    # to short form if they contain spaces
    
    # NOTE - path must exist;
    
    my $shortpathstr = GetShortPathName($path);
    my $longpathstr = GetLongPathName($path);
    
    $shortpathstr =~ s/\\/\//g;
    $longpathstr =~ s/\\/\//g;
    
    my @shortnames = split(/\//, $shortpathstr);
    my @longnames = split(/\//, $longpathstr);
    
    my $limit = (scalar @shortnames);
    my $index = 0;
    my @outpath = ();
    
    while($index < $limit) {
        if($longnames[$index] =~ /\s/) {
            push(@outpath, $shortnames[$index]);
        } else {
            push(@outpath, $longnames[$index]);
        }
        $index ++;
    }
    my $newpath = join('/', @outpath);
    if($newpath =~ /\w/) {
        return $newpath;
    } else {
        return undef;
    }  
}

sub ShortPath {
    my $path = shift;
    $path = GetShortPathName($path);
    $path =~ s/\\/\//g;
    return $path;
}

sub DisplayPath {
    my $path = shift;
    $path =~ s/\//\\/g;
    $path = GetLongPathName($path);
    return $path;
}

sub GetUserAppDataDir {
    __cvpk_get_shell_folder( CAVA_FOLDER_LOCAL_APPDATA() );      
}

sub GetUserDocumentDir {
    __cvpk_get_shell_folder( CAVA_FOLDER_PERSONAL() );    
}

sub GetCommonAppDataDir {
    __cvpk_get_shell_folder( CAVA_FOLDER_COMMON_APPDATA() );      
}

sub GetTempDir {
    if(!$TMPPATH){
        # create temp path
        my $temproot = CodePath($ENV{TMP});
        if(!-w $temproot) { $temproot = CodePath($ENV{TEMP}); }
        if(!-w $temproot) { $temproot = CodePath($ENV{USERPROFILE}); }
+    
        my $chars = __cvpk_gen_randomchars(11);
        my $tmpstr = 'cvpk-' . $chars;
        my $temppath = qq($temproot/$tmpstr);
        mkdir($temppath, 0777);
        $TMPPATH = $temppath;
    }
    return $TMPPATH;
}

sub GetTempFile {
    my $tempfile = '';
    while($tempfile eq '') {
        my $tmp = GetTempDir() . '/' . __cvpk_gen_randomchars(12) . '.
+tmp';
        if(!-e $tmp) {
            open my $tfh, ">", $tmp;
            close($tfh);
            $tempfile = $tmp;
        }
    }
    return $tempfile;
}

sub __cvpk_get_shell_folder {
    my $type = shift;
    my $path = GetFolderPath($type,1);
    CodePath($path);
}

# all 'Set' subs are noops when packaged with Cava Packager

sub SetResourcePath {
    my $path = shift;
    $path = GetFullPathName($path);
    $RESPATH = CodePath($path);
}

sub SetInfoProductName {
    $__cvpk_info->{ProductName} = shift;
}

sub SetInfoProductVersion {
    $__cvpk_info->{ProductVersion} = shift;
}

sub SetInfoVendor {
    $__cvpk_info->{Vendor} = shift;
}

sub SetInfoCopyright {
    $__cvpk_info->{Copyright} = shift;
}

sub SetInfoTrademarks {
    $__cvpk_info->{Trademarks} = shift;
}

sub SetInfoComments {
    $__cvpk_info->{Comments} = shift;
}

sub SetInfoFileDescription {
    $__cvpk_info->{FileDescription} = shift;
}

sub SetInfoFileInternalName {
    $__cvpk_info->{FileInternalName} = shift;
}

sub SetInfoFileVersion {
    $__cvpk_info->{FileVersion} = shift;
}

sub SetInfoFileOriginalName {
    $__cvpk_info->{FileOriginalName} = shift;
}

sub GetInfoProductName {
    return $__cvpk_info->{ProductName};
}

sub GetInfoProductVersion {
    return $__cvpk_info->{ProductVersion};
}

sub GetInfoVendor {
    return $__cvpk_info->{Vendor};
}

sub GetInfoCopyright {
    return $__cvpk_info->{Copyright};
}

sub GetInfoTrademarks {
    return $__cvpk_info->{Trademarks};
}

sub GetInfoComments {
    return $__cvpk_info->{Comments};
}

sub GetInfoFileDescription {
    return $__cvpk_info->{FileDescription};
}

sub GetInfoFileInternalName {
    return $__cvpk_info->{FileInternalName};
}

sub GetInfoFileVersion {
    return $__cvpk_info->{FileVersion};
}

sub GetInfoFileOriginalName {
    return $__cvpk_info->{FileOriginalName};
}

sub __cvpk_gen_randomchars {
    my $numchars = shift;
    my @vals = qw(A B C D E F G H I J K L M N O P Q R S T U V W X Y Z 
+a b c d e f g h i j k l m n o p q r s t u v w x y z 0 1 2 3 4 5 6 7 8
+ 9);
    my $buffer = '';
    for (my $i = 1; $i <= $numchars; $i++) {
        my $index = int(rand(scalar @vals));
        $buffer .= $vals[$index];
    }
    return $buffer;
}


END {
    # do cleanup if we didn't clean up;
    eval {
        if($TMPPATH) { __cvpk_purge_dir($TMPPATH,1); }
    };
}


1;
__END__
[download]