kernel32.pm

WIN32::API for perl dev 5

package Win32::kernel32;
use Win32::API;

$VERSION = "0.20";

%APIs = (
    Beep                      => [[N, N], N],
    CopyFile                  => [[P, P, N], N],
    GetBinaryType             => [[P, P], N],
    GetCommandLine            => [[], P],
    GetCompressedFileSize     => [[P, P], N],
    GetCurrencyFormat         => [[N, N, P, P, P, N], N],
    GetDiskFreeSpace          => [[P, P, P, P, P], N],
    GetDriveType              => [[P], N],
    GetSystemTime             => [[P], V],
    GetTempPath               => [[N, P], N],
    GetVolumeInformation      => [[P, P, N, P, P, P, P, N], N],
    MultiByteToWideChar       => [[N, N, P, N, P, N], N],
    QueryDosDevice            => [[P, P, N], N],
    QueryPerformanceCounter   => [[P], N],
    QueryPerformanceFrequency => [[P], N],
    SearchPath                => [[P, P, P, N, P, P], N],
    SetLastError              => [[N], V],
    Sleep                     => [[N], V],
    VerLanguageName           => [[N, P, N], N],
    WideCharToMultiByte       => [[N, N, P, N, P, N, P, P], N],
);

%SUBs = (
    Beep => sub {
        my($freq, $duration) = @_;
        return $Win32::kernel32::Beep->Call($freq, $duration);
    },
    CopyFile => sub {
        my($old, $new, $flag) = @_;
        $flag = 1 unless defined($flag);
        return $Win32::kernel32::CopyFile->Call($old, $new, $flag);
    },
    GetBinaryType => sub {
        warn "The Win32::GetBinaryType API works only on Windows NT" unless Win32::IsWinNT();
        my($appname) = @_;
        my $type = pack("L", 0);
        my $result = $Win32::kernel32::GetBinaryType->Call($appname, $type);
        return ($result) ? unpack("L", $type) : undef;
    },
    GetCompressedFileSize => sub {
        warn "The Win32::GetCompressedFileSize API works only on Windows NT" unless Win32::IsWinNT();
        my($filename) = @_;
        my $hiword = pack("L", 0);
        my $loword = $Win32::kernel32::GetCompressedFileSize->Call($filename, $hiword);
        return $loword + $hiword * 4*1024**3;
    },
    GetCommandLine => sub {
        my $cmdline = $Win32::kernel32::GetCommandLine->Call();
        my $string = pack("a1024", $cmdline);
        $string =~ s/\0*$//;
        return $string;
    },
    GetCurrencyFormat => sub {
        my($number, $locale) = @_;
        $locale = 2048 unless defined($locale);
        my $output = "\0" x 1024;
        my $result = $Win32::kernel32::GetCurrencyFormat->Call(
            $locale,
            0,
            $number,
            0,
            $output,
            1024,
        );
        if($result) {
            return substr($output, 0, $result-1);
        } else {
            return undef;
        }
    },
    GetDiskFreeSpace => sub {
        my($root) = @_;
        $root = 0 unless defined($root);
        my $SectorsPerCluster = pack("L", 0);
        my $BytesPerSector = pack("L", 0);
        my $FreeClusters = pack("L", 0);
        my $TotalClusters = pack("L", 0);
        my $result = $Win32::kernel32::GetDiskFreeSpace->Call(
            $root,
            $SectorsPerCluster,
            $BytesPerSector,
            $FreeClusters,
            $TotalClusters,
        );
        if($result) {
            $SectorsPerCluster = unpack("L", $SectorsPerCluster);
            $BytesPerSector = unpack("L", $BytesPerSector);
            $FreeClusters = unpack("L", $FreeClusters);
            $TotalClusters = unpack("L", $TotalClusters);
            return wantarray ? (
                $BytesPerSector*$SectorsPerCluster*$FreeClusters,
                $BytesPerSector*$SectorsPerCluster*$TotalClusters,
            ) : $BytesPerSector*$SectorsPerCluster*$FreeClusters;
        } else {
            return undef;
        }
    },
    GetDriveType => sub {
        my($root) = @_;
        $root = 0 unless defined($root);
        return $Win32::kernel32::GetDriveType->Call($root);
    },
    GetSystemTime => sub {
        my $SYSTEMTIME = pack("SSSSSSSS", 0, 0, 0, 0, 0, 0, 0, 0);
        $Win32::kernel32::GetSystemTime->Call($SYSTEMTIME);
        return wantarray ? unpack("SSSSSSSS", $SYSTEMTIME) : $SYSTEMTIME;
    },
    GetTempPath => sub {
        my $string = " " x 256;
        my $result = $Win32::kernel32::GetTempPath->Call(256, $string);
        return substr($string, 0, $result) if $result;
        return undef;
    },
    GetVolumeInformation => sub {
        my($root) = @_;
        $root = 0 unless defined($root);
        my $name = "\0" x 256;
        my $serial = pack("L", 0);
        my $maxlen = pack("L", 0);
        my $flags = pack("L", 0);
        my $fstype = "\0" x 256;
        my $result = $Win32::kernel32::GetVolumeInformation->Call(
            $root, 
            $name,
            256,
            $serial,
            $maxlen,
            $flags,
            $fstype,
            256,
        );
        if($result) {
            $name =~ s/\0*$//;
            $fstype =~ s/\0*$//;
            return wantarray ? (
                $name,
                unpack("L", $serial), 
                unpack("L", $maxlen), 
                unpack("L", $flags), 
                $fstype,
            ) : $name;
        } else {
            return undef;
        }
    },
    MultiByteToWideChar => sub {
        my($string, $codepage) = @_;
        $codepage = 0 unless defined($codepage);
        my $result = $Win32::kernel32::MultiByteToWideChar->Call(
            $codepage, 
            0, 
            $string, length($string), 
            0, 0,
        );
        return undef unless $result;
        my $ustring = " " x ($result*2);
        $result = $Win32::kernel32::MultiByteToWideChar->Call(
            $codepage, 
            0, 
            $string, length($string), 
            $ustring, $result,
        );
        return undef unless $result;
        return $ustring;
    },
    QueryDosDevice => sub {
        warn "The Win32::QueryDosDevice API works only on Windows NT" unless Win32::IsWinNT();
        my($name) = @_;
        $name = 0 unless defined($name);
        my $path = "\0" x 1024;
        my $result = $Win32::kernel32::QueryDosDevice->Call($name, $path, 1024);
        if($result) {
            return wantarray ?
                split(/\0/, $path)
            :   join(";", split(/\0/, $path));
        } else {
            return undef;
        }
    },
    QueryPerformanceCounter => sub {
        my $count = pack("b64", 0);
        if($Win32::kernel32::QueryPerformanceCounter->Call($count)) {
            my($clo, $chi) = unpack("ll", $count);
            return $clo+$chi*4*1024**3;
        } else {
            return undef;
        }
    },
    QueryPerformanceFrequency => sub {
        my $freq = pack("b64", 0);
        if($Win32::kernel32::QueryPerformanceFrequency->Call($freq)) {
            my($flo, $fhi) = unpack("ll", $freq);
            return $flo+$fhi*4*1024**3;
        } else {
            return undef;
        }
    },
    SearchPath => sub {
        my($name, $ext) = @_;
        $ext = 0 unless defined($ext);
        my $path = "\0" x 1024;
        my $pext = pack("L", 0);
        my $result = $Win32::kernel32::SearchPath->Call(
            0,
            $name, 
            $extension, 
            1024,
            $path,
            $pext,
        );
        if($result) {
            $path =~ s/\0*$//;
            return $path;
        } else {
            return undef;
        }
    },
    SetLastError => sub {
        $Win32::kernel32::SetLastError->Call($_[0]) if $_[0];
    },
    Sleep => sub {
        $Win32::kernel32::Sleep->Call($_[0]) if $_[0];
    },
    VerLanguageName => sub {
        my($lang) = @_;
        if($lang) {
            my $langdesc = "\0" x 256;
            my $result = $Win32::kernel32::VerLanguageName->Call($lang, $langdesc, 256);
            if($result > 0 and $result < 256) {
                return substr($langdesc, 0, $result);
            } else {
                return 0;
            }
        }
    },
    WideCharToMultiByte => sub {
        my($ustring, $codepage) = @_;
        $codepage = 0 unless defined($codepage);
        my $result = $Win32::kernel32::WideCharToMultiByte->Call(
            $codepage, 
            0, 
            $ustring, -1,
            0, 0,
            0, 0,
        );
        return undef unless $result;
        my $string = " " x $result;
        $result = $Win32::kernel32::WideCharToMultiByte->Call(
            $codepage, 
            0, 
            $ustring, -1,
            $string, $result,
            0, 0,
        );
        # $string =~ s/\0.*$//;
        return undef unless $result;
        return $string;
    },
);

sub import {
    my $self = shift;
    @apis = @_;
    @apis = keys %APIs unless @apis;
    foreach $api (@apis) {
        import_API($api);
    }
}

sub import_API {
    my ($function) = @_;
    my $params;
    if(exists($APIs{$function})) {
        $params = $APIs{$function};
    } else {
        $params = [[], V];
        warn "Unknown API: $function";
    }
    $$function = new Win32::API("kernel32", $function, @$params);
    warn "Win32::kernel32 failed to import API $function from KERNEL32.DLL" unless $$function;
    *{'Win32::'.$function} = $SUBs{$function};
}

1;
__END__

=head1 NAME

Win32::kernel32 - Experimental interface to some of the KERNEL32.DLL functions

=head1 SYNOPSIS

  use Win32::kernel32;

  # or

  use Win32::kernel32 qw( Sleep CopyFile GetVolumeInformation );


=head1 FUNCTIONS

=head4 Beep

Syntax:

    Win32::Beep ( [FREQUENCY, DURATION] )

Plays a simple tone on the speaker; C<FREQUENCY> is expressed
in hertz and ranges from 37 to 32767, C<DURATION> is expressed
in milliseconds.
Note that parameters are relevant only on Windows NT; on
Windows 95, parameters are ignored and the system plays the
default sound event (or a standard system beep on the speaker 
if you have no sound card).

Example:

    Win32::Beep(440, 1000);


=head4 CopyFile

Syntax:

    Win32::CopyFile ( SOURCE, TARGET, [SAFE] )

Copies the C<SOURCE> file to C<TARGET>. By default, it fails
if C<TARGET> already exists; to overwrite the already
existing file, the C<SAFE> flag must be set to 0.
Returns a true value if the operation was successfull,
a false one if it failed.

Example: