From: Jesse Vincent Date: Mon, 19 Oct 2009 21:18:11 +0000 (-0400) Subject: Updating Win32 0.39 to have the same line-endings as CPAN X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8883bb5ae00921bf912c003dc007071a4a437baa;p=p5sagit%2Fp5-mst-13.2.git Updating Win32 0.39 to have the same line-endings as CPAN --- diff --git a/cpan/Win32/Changes b/cpan/Win32/Changes index 364a902..b707793 100644 --- a/cpan/Win32/Changes +++ b/cpan/Win32/Changes @@ -1,137 +1,137 @@ -Revision history for the Perl extension Win32. - -0.39 [2009-01-19] - - Add support for Windows 2008 Server and Windows 7 in - Win32::GetOSName() and in the documentation for - Win32::GetOSVersion(). - - Make Win32::GetOSName() implementation testable. - - Document that the OSName for Win32s is actually "WinWin32s". - -0.38 [2008-06-27] - - Fix Cygwin releated problems in t/GetCurrentThreadId.t - (Jerry D. Hedden). - -0.37 [2008-06-26] - - Add Win32::GetCurrentProcessId() function - -0.36 [2008-04-17] - - Add typecasts for Win64 compilation - -0.35 [2008-03-31] - Integrate changes from bleadperl: - - Silence Borland compiler warning (Steve Hay) - - Fix memory leak in Win32::GetOSVersion (Vincent Pit) - - Test Win32::GetCurrentThreadId on cygwin (Reini Urban, Steve Hay) - -0.34 [2007-11-21] - - Document "WinVista" return value for Win32::GetOSName() - (Steve Hay). - -0.33 [2007-11-12] - - Update version to 0.33 for Perl 5.10 release - - Add $^O test in Makefile.PL for CPAN Testers - - Use Win32::GetLastError() instead of $^E in t/Names.t for - cygwin compatibility (Jerry D. Hedden). - -0.32 [2007-09-20] - - Additional #define's for older versions of VC++ (Dmitry Karasik). - - Win32::DomainName() doesn't return anything when the Workstation - service isn't running. Set $^E and adapt t/Names.t accordingly - (Steve Hay & Jerry D. Hedden). - - Fix t/Names.t to allow Win32::GetOSName() to return an empty - description as the 2nd return value (e.g. Vista without SP). - - Fix t/GetFileVersion.t for Perl 5.10 - -0.31 [2007-09-10] - - Apply Cygwin fixes from bleadperl (from Jerry D. Hedden). - - Make sure Win32::GetLongPathName() always returns drive - letters in uppercase (Jerry D. Hedden). - - Use uppercase environment variable names in t/Unicode.t - because the MSWin32 doesn't care, and Cygwin only works - with the uppercased version. - - new t/Names.t test (from Sébastien Aperghis-Tramoni) - -0.30 [2007-06-25] - - Fixed t/Unicode.t test for Cygwin (with help from Jerry D. Hedden). - - Fixed and documented Win32::GetShortPathName() to return undef - when the pathname doesn't exist (thanks to Steve Hay). - - Added t/GetShortPathName.t - -0.29 [2007-05-17] - - Fixed to compile with Borland BCC (thanks to Steve Hay). - -0.28_01 [2007-05-16] - - Increase version number as 0.28 was already used by an ActivePerl - release (for essentially 0.27 plus the Win32::IsAdminUser() change). - - - Add MODULE and PROTOTYPES directives to silence warnings from - newer versions of xsubpp. - - - Use the Cygwin codepath in Win32::GetFullPathName() when - PERL_IMPLICIT_SYS is not defined, because the other code - relies on the virtualization code in win32/vdir.h. - -0.27_02 [2007-05-15] - - We need Windows 2000 or later for the Unicode support because - WC_NO_BEST_FIT_CHARS is not supported on Windows NT. - - - Fix Win32::GetFullPathName() on Windows NT to return an - empty file part if the original argument ends with a slash. - -0.27_01 [2007-04-18] - - Update Win32::IsAdminUser() to use the IsUserAnAdmin() function - in shell32.dll when available. On Windows Vista this will only - return true if the process is running with elevated privileges - and not just when the owner of the process is a member of the - "Administrators" group. - - - Win32::ExpandEnvironmentStrings() may return a Unicode string - (a string containing characters outside the system codepage) - - - new Win32::GetANSIPathName() function returns a pathname in - a form containing only characters from the system codepage - - - Win32::GetCwd() will return an ANSI version of the directory - name if the long name contains characters outside the system - codepage. - - - Win32::GetFolderPath() will return an ANSI pathname. Call - Win32::GetLongPathName() to get the canonical Unicode - representation. - - - Win32::GetFullPathName() will return an ANSI pathname. Call - Win32::GetLongPathName() to get the canonical Unicode - representation. - - - Win32::GetLongPathName() may return a Unicode path name. - Call Win32::GetANSIPathName() to get a representation using - only characters from the system codepage. - - - Win32::LoginName() may return a Unicode string. - - - new Win32::OutputDebugString() function sends a string to - the debugger. - - - new Win32::GetCurrentThreadId() function returns the thread - id (to complement the process id in $$). - - - new Win32::CreateDirectory() creates a new directory. The - name of the directory may contain Unicode characters outside - the system codepage. - - - new Win32::CreateFile() creates a new file. The name of the - file may contain Unicode characters outside the system codepage. - - -0.27 [2007-03-07] - - Extracted from the libwin32 distribution to simplify maintenance - because Win32 is a dual-life core module since 5.8.4. - - - Win32.pm and Win32.xs updated to version in bleadperl. - This includes all the Win32::* function from win32/win32.c - in core Perl, except for Win32::SetChildShowWindows(). - - - Install into 'perl' directory instead of 'site' for Perl 5.8.4 - and later. - - - Add some simple tests. +Revision history for the Perl extension Win32. + +0.39 [2009-01-19] + - Add support for Windows 2008 Server and Windows 7 in + Win32::GetOSName() and in the documentation for + Win32::GetOSVersion(). + - Make Win32::GetOSName() implementation testable. + - Document that the OSName for Win32s is actually "WinWin32s". + +0.38 [2008-06-27] + - Fix Cygwin releated problems in t/GetCurrentThreadId.t + (Jerry D. Hedden). + +0.37 [2008-06-26] + - Add Win32::GetCurrentProcessId() function + +0.36 [2008-04-17] + - Add typecasts for Win64 compilation + +0.35 [2008-03-31] + Integrate changes from bleadperl: + - Silence Borland compiler warning (Steve Hay) + - Fix memory leak in Win32::GetOSVersion (Vincent Pit) + - Test Win32::GetCurrentThreadId on cygwin (Reini Urban, Steve Hay) + +0.34 [2007-11-21] + - Document "WinVista" return value for Win32::GetOSName() + (Steve Hay). + +0.33 [2007-11-12] + - Update version to 0.33 for Perl 5.10 release + - Add $^O test in Makefile.PL for CPAN Testers + - Use Win32::GetLastError() instead of $^E in t/Names.t for + cygwin compatibility (Jerry D. Hedden). + +0.32 [2007-09-20] + - Additional #define's for older versions of VC++ (Dmitry Karasik). + - Win32::DomainName() doesn't return anything when the Workstation + service isn't running. Set $^E and adapt t/Names.t accordingly + (Steve Hay & Jerry D. Hedden). + - Fix t/Names.t to allow Win32::GetOSName() to return an empty + description as the 2nd return value (e.g. Vista without SP). + - Fix t/GetFileVersion.t for Perl 5.10 + +0.31 [2007-09-10] + - Apply Cygwin fixes from bleadperl (from Jerry D. Hedden). + - Make sure Win32::GetLongPathName() always returns drive + letters in uppercase (Jerry D. Hedden). + - Use uppercase environment variable names in t/Unicode.t + because the MSWin32 doesn't care, and Cygwin only works + with the uppercased version. + - new t/Names.t test (from Sébastien Aperghis-Tramoni) + +0.30 [2007-06-25] + - Fixed t/Unicode.t test for Cygwin (with help from Jerry D. Hedden). + - Fixed and documented Win32::GetShortPathName() to return undef + when the pathname doesn't exist (thanks to Steve Hay). + - Added t/GetShortPathName.t + +0.29 [2007-05-17] + - Fixed to compile with Borland BCC (thanks to Steve Hay). + +0.28_01 [2007-05-16] + - Increase version number as 0.28 was already used by an ActivePerl + release (for essentially 0.27 plus the Win32::IsAdminUser() change). + + - Add MODULE and PROTOTYPES directives to silence warnings from + newer versions of xsubpp. + + - Use the Cygwin codepath in Win32::GetFullPathName() when + PERL_IMPLICIT_SYS is not defined, because the other code + relies on the virtualization code in win32/vdir.h. + +0.27_02 [2007-05-15] + - We need Windows 2000 or later for the Unicode support because + WC_NO_BEST_FIT_CHARS is not supported on Windows NT. + + - Fix Win32::GetFullPathName() on Windows NT to return an + empty file part if the original argument ends with a slash. + +0.27_01 [2007-04-18] + - Update Win32::IsAdminUser() to use the IsUserAnAdmin() function + in shell32.dll when available. On Windows Vista this will only + return true if the process is running with elevated privileges + and not just when the owner of the process is a member of the + "Administrators" group. + + - Win32::ExpandEnvironmentStrings() may return a Unicode string + (a string containing characters outside the system codepage) + + - new Win32::GetANSIPathName() function returns a pathname in + a form containing only characters from the system codepage + + - Win32::GetCwd() will return an ANSI version of the directory + name if the long name contains characters outside the system + codepage. + + - Win32::GetFolderPath() will return an ANSI pathname. Call + Win32::GetLongPathName() to get the canonical Unicode + representation. + + - Win32::GetFullPathName() will return an ANSI pathname. Call + Win32::GetLongPathName() to get the canonical Unicode + representation. + + - Win32::GetLongPathName() may return a Unicode path name. + Call Win32::GetANSIPathName() to get a representation using + only characters from the system codepage. + + - Win32::LoginName() may return a Unicode string. + + - new Win32::OutputDebugString() function sends a string to + the debugger. + + - new Win32::GetCurrentThreadId() function returns the thread + id (to complement the process id in $$). + + - new Win32::CreateDirectory() creates a new directory. The + name of the directory may contain Unicode characters outside + the system codepage. + + - new Win32::CreateFile() creates a new file. The name of the + file may contain Unicode characters outside the system codepage. + + +0.27 [2007-03-07] + - Extracted from the libwin32 distribution to simplify maintenance + because Win32 is a dual-life core module since 5.8.4. + + - Win32.pm and Win32.xs updated to version in bleadperl. + This includes all the Win32::* function from win32/win32.c + in core Perl, except for Win32::SetChildShowWindows(). + + - Install into 'perl' directory instead of 'site' for Perl 5.8.4 + and later. + + - Add some simple tests. diff --git a/cpan/Win32/Makefile.PL b/cpan/Win32/Makefile.PL index 6f9b008..913641e 100644 --- a/cpan/Win32/Makefile.PL +++ b/cpan/Win32/Makefile.PL @@ -1,18 +1,18 @@ -use 5.006; -use strict; -use warnings; -use ExtUtils::MakeMaker; - -unless ($^O eq "MSWin32" || $^O eq "cygwin") { - die "OS unsupported\n"; -} - -my %param = ( - NAME => 'Win32', - VERSION_FROM => 'Win32.pm', - INSTALLDIRS => ($] >= 5.008004 ? 'perl' : 'site'), -); -$param{NO_META} = 1 if eval "$ExtUtils::MakeMaker::VERSION" >= 6.10_03; -$param{LIBS} = ['-L/lib/w32api -lole32 -lversion'] if $^O eq "cygwin"; - -WriteMakefile(%param); +use 5.006; +use strict; +use warnings; +use ExtUtils::MakeMaker; + +unless ($^O eq "MSWin32" || $^O eq "cygwin") { + die "OS unsupported\n"; +} + +my %param = ( + NAME => 'Win32', + VERSION_FROM => 'Win32.pm', + INSTALLDIRS => ($] >= 5.008004 ? 'perl' : 'site'), +); +$param{NO_META} = 1 if eval "$ExtUtils::MakeMaker::VERSION" >= 6.10_03; +$param{LIBS} = ['-L/lib/w32api -lole32 -lversion'] if $^O eq "cygwin"; + +WriteMakefile(%param); diff --git a/cpan/Win32/Win32.pm b/cpan/Win32/Win32.pm index 4015eac..bc231ba 100644 --- a/cpan/Win32/Win32.pm +++ b/cpan/Win32/Win32.pm @@ -1,793 +1,793 @@ -package Win32; - -BEGIN { - use strict; - use vars qw|$VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK|; - - require Exporter; - require DynaLoader; - - @ISA = qw|Exporter DynaLoader|; - $VERSION = '0.39'; - $XS_VERSION = $VERSION; - $VERSION = eval $VERSION; - - @EXPORT = qw( - NULL - WIN31_CLASS - OWNER_SECURITY_INFORMATION - GROUP_SECURITY_INFORMATION - DACL_SECURITY_INFORMATION - SACL_SECURITY_INFORMATION - MB_ICONHAND - MB_ICONQUESTION - MB_ICONEXCLAMATION - MB_ICONASTERISK - MB_ICONWARNING - MB_ICONERROR - MB_ICONINFORMATION - MB_ICONSTOP - ); - @EXPORT_OK = qw( - GetOSName - SW_HIDE - SW_SHOWNORMAL - SW_SHOWMINIMIZED - SW_SHOWMAXIMIZED - SW_SHOWNOACTIVATE - - CSIDL_DESKTOP - CSIDL_PROGRAMS - CSIDL_PERSONAL - CSIDL_FAVORITES - CSIDL_STARTUP - CSIDL_RECENT - CSIDL_SENDTO - CSIDL_STARTMENU - CSIDL_MYMUSIC - CSIDL_MYVIDEO - CSIDL_DESKTOPDIRECTORY - CSIDL_NETHOOD - CSIDL_FONTS - CSIDL_TEMPLATES - CSIDL_COMMON_STARTMENU - CSIDL_COMMON_PROGRAMS - CSIDL_COMMON_STARTUP - CSIDL_COMMON_DESKTOPDIRECTORY - CSIDL_APPDATA - CSIDL_PRINTHOOD - CSIDL_LOCAL_APPDATA - CSIDL_COMMON_FAVORITES - CSIDL_INTERNET_CACHE - CSIDL_COOKIES - CSIDL_HISTORY - CSIDL_COMMON_APPDATA - CSIDL_WINDOWS - CSIDL_SYSTEM - CSIDL_PROGRAM_FILES - CSIDL_MYPICTURES - CSIDL_PROFILE - CSIDL_PROGRAM_FILES_COMMON - CSIDL_COMMON_TEMPLATES - CSIDL_COMMON_DOCUMENTS - CSIDL_COMMON_ADMINTOOLS - CSIDL_ADMINTOOLS - CSIDL_COMMON_MUSIC - CSIDL_COMMON_PICTURES - CSIDL_COMMON_VIDEO - CSIDL_RESOURCES - CSIDL_RESOURCES_LOCALIZED - CSIDL_CDBURN_AREA - ); -} - -# We won't bother with the constant stuff, too much of a hassle. Just hard -# code it here. - -sub NULL { 0 } -sub WIN31_CLASS { &NULL } - -sub OWNER_SECURITY_INFORMATION { 0x00000001 } -sub GROUP_SECURITY_INFORMATION { 0x00000002 } -sub DACL_SECURITY_INFORMATION { 0x00000004 } -sub SACL_SECURITY_INFORMATION { 0x00000008 } - -sub MB_ICONHAND { 0x00000010 } -sub MB_ICONQUESTION { 0x00000020 } -sub MB_ICONEXCLAMATION { 0x00000030 } -sub MB_ICONASTERISK { 0x00000040 } -sub MB_ICONWARNING { 0x00000030 } -sub MB_ICONERROR { 0x00000010 } -sub MB_ICONINFORMATION { 0x00000040 } -sub MB_ICONSTOP { 0x00000010 } - -# -# Newly added constants. These have an empty prototype, unlike the -# the ones above, which aren't prototyped for compatibility reasons. -# -sub SW_HIDE () { 0 } -sub SW_SHOWNORMAL () { 1 } -sub SW_SHOWMINIMIZED () { 2 } -sub SW_SHOWMAXIMIZED () { 3 } -sub SW_SHOWNOACTIVATE () { 4 } - -sub CSIDL_DESKTOP () { 0x0000 } # -sub CSIDL_PROGRAMS () { 0x0002 } # Start Menu\Programs -sub CSIDL_PERSONAL () { 0x0005 } # "My Documents" folder -sub CSIDL_FAVORITES () { 0x0006 } # \Favorites -sub CSIDL_STARTUP () { 0x0007 } # Start Menu\Programs\Startup -sub CSIDL_RECENT () { 0x0008 } # \Recent -sub CSIDL_SENDTO () { 0x0009 } # \SendTo -sub CSIDL_STARTMENU () { 0x000B } # \Start Menu -sub CSIDL_MYMUSIC () { 0x000D } # "My Music" folder -sub CSIDL_MYVIDEO () { 0x000E } # "My Videos" folder -sub CSIDL_DESKTOPDIRECTORY () { 0x0010 } # \Desktop -sub CSIDL_NETHOOD () { 0x0013 } # \nethood -sub CSIDL_FONTS () { 0x0014 } # windows\fonts -sub CSIDL_TEMPLATES () { 0x0015 } -sub CSIDL_COMMON_STARTMENU () { 0x0016 } # All Users\Start Menu -sub CSIDL_COMMON_PROGRAMS () { 0x0017 } # All Users\Start Menu\Programs -sub CSIDL_COMMON_STARTUP () { 0x0018 } # All Users\Startup -sub CSIDL_COMMON_DESKTOPDIRECTORY () { 0x0019 } # All Users\Desktop -sub CSIDL_APPDATA () { 0x001A } # Application Data, new for NT4 -sub CSIDL_PRINTHOOD () { 0x001B } # \PrintHood -sub CSIDL_LOCAL_APPDATA () { 0x001C } # non roaming, user\Local Settings\Application Data -sub CSIDL_COMMON_FAVORITES () { 0x001F } -sub CSIDL_INTERNET_CACHE () { 0x0020 } -sub CSIDL_COOKIES () { 0x0021 } -sub CSIDL_HISTORY () { 0x0022 } -sub CSIDL_COMMON_APPDATA () { 0x0023 } # All Users\Application Data -sub CSIDL_WINDOWS () { 0x0024 } # GetWindowsDirectory() -sub CSIDL_SYSTEM () { 0x0025 } # GetSystemDirectory() -sub CSIDL_PROGRAM_FILES () { 0x0026 } # C:\Program Files -sub CSIDL_MYPICTURES () { 0x0027 } # "My Pictures", new for Win2K -sub CSIDL_PROFILE () { 0x0028 } # USERPROFILE -sub CSIDL_PROGRAM_FILES_COMMON () { 0x002B } # C:\Program Files\Common -sub CSIDL_COMMON_TEMPLATES () { 0x002D } # All Users\Templates -sub CSIDL_COMMON_DOCUMENTS () { 0x002E } # All Users\Documents -sub CSIDL_COMMON_ADMINTOOLS () { 0x002F } # All Users\Start Menu\Programs\Administrative Tools -sub CSIDL_ADMINTOOLS () { 0x0030 } # \Start Menu\Programs\Administrative Tools -sub CSIDL_COMMON_MUSIC () { 0x0035 } # All Users\My Music -sub CSIDL_COMMON_PICTURES () { 0x0036 } # All Users\My Pictures -sub CSIDL_COMMON_VIDEO () { 0x0037 } # All Users\My Video -sub CSIDL_RESOURCES () { 0x0038 } # %windir%\Resources\, For theme and other windows resources. -sub CSIDL_RESOURCES_LOCALIZED () { 0x0039 } # %windir%\Resources\, for theme and other windows specific resources. -sub CSIDL_CDBURN_AREA () { 0x003B } # \Local Settings\Application Data\Microsoft\CD Burning - -### This method is just a simple interface into GetOSVersion(). More -### specific or demanding situations should use that instead. - -my ($cached_os, $cached_desc); - -sub GetOSName { - unless (defined $cached_os) { - my($desc, $major, $minor, $build, $id, undef, undef, undef, $producttype) - = Win32::GetOSVersion(); - ($cached_os, $cached_desc) = _GetOSName($desc, $major, $minor, $build, $id, $producttype); - } - return wantarray ? ($cached_os, $cached_desc) : $cached_os; -} - -sub _GetOSName { - my($desc, $major, $minor, $build, $id, $producttype) = @_; - - my($os,$tag); - if ($id == 0) { - $os = "Win32s"; - } - elsif ($id == 1) { - $os = { 0 => "95", 10 => "98", 90 => "Me" }->{$minor}; - } - elsif ($id == 2) { - if ($major == 3) { - $os = "NT3.51"; - } - elsif ($major == 4) { - $os = "NT4"; - } - elsif ($major == 5) { - $os = { 0 => "2000", 1 => "XP/.Net", 2 => "2003" }->{$minor}; - } - elsif ($major == 6) { - $os = { 0 => "Vista", 1 => "7" }->{$minor}; - # 2008 is same as Vista but has "Domaincontroller" or "Server" type - $os = "2008" if $os eq "Vista" && $producttype != 1; - } - } - - unless (defined $os) { - warn "Unknown Windows version [$id:$major:$minor]"; - return; - } - - # Take a look at the build numbers and try to deduce - # the exact release name, but we put that in the $desc - if ($os eq "95") { - $tag = { 67109814 => "(a)", 67306684 => "(b1)", "67109975" => "(b2)" }->{$build}; - } - elsif ($os eq "98" && $build eq "67766446") { - $tag = "(2nd ed)"; - } - if ($tag) { - $desc = length($desc) ? "$tag $desc" : $tag; - } - - return ("Win$os", $desc); -} - -# "no warnings 'redefine';" doesn't work for 5.8.7 and earlier -local $^W = 0; -bootstrap Win32; - -1; - -__END__ - -=head1 NAME - -Win32 - Interfaces to some Win32 API Functions - -=head1 DESCRIPTION - -The Win32 module contains functions to access Win32 APIs. - -=head2 Alphabetical Listing of Win32 Functions - -It is recommended to C before any of these functions; -however, for backwards compatibility, those marked as [CORE] will -automatically do this for you. - -In the function descriptions below the term I is used -to indicate that the string may contain characters outside the system -codepage. The caveat I -generally means Perl 5.8.9 and later, though some Unicode pathname -functionality may work on earlier versions. - -=over - -=item Win32::AbortSystemShutdown(MACHINE) - -Aborts a system shutdown (started by the -InitiateSystemShutdown function) on the specified MACHINE. - -=item Win32::BuildNumber() - -[CORE] Returns the ActivePerl build number. This function is -only available in the ActivePerl binary distribution. - -=item Win32::CopyFile(FROM, TO, OVERWRITE) - -[CORE] The Win32::CopyFile() function copies an existing file to a new -file. All file information like creation time and file attributes will -be copied to the new file. However it will B copy the security -information. If the destination file already exists it will only be -overwritten when the OVERWRITE parameter is true. But even this will -not overwrite a read-only file; you have to unlink() it first -yourself. - -=item Win32::CreateDirectory(DIRECTORY) - -Creates the DIRECTORY and returns a true value on success. Check $^E -on failure for extended error information. - -DIRECTORY may contain Unicode characters outside the system codepage. -Once the directory has been created you can use -Win32::GetANSIPathName() to get a name that can be passed to system -calls and external programs. - -=item Win32::CreateFile(FILE) - -Creates the FILE and returns a true value on success. Check $^E on -failure for extended error information. - -FILE may contain Unicode characters outside the system codepage. Once -the file has been created you can use Win32::GetANSIPathName() to get -a name that can be passed to system calls and external programs. - -=item Win32::DomainName() - -[CORE] Returns the name of the Microsoft Network domain or workgroup -that the owner of the current perl process is logged into. The -"Workstation" service must be running to determine this -information. This function does B work on Windows 9x. - -=item Win32::ExpandEnvironmentStrings(STRING) - -Takes STRING and replaces all referenced environment variable -names with their defined values. References to environment variables -take the form C<%VariableName%>. Case is ignored when looking up the -VariableName in the environment. If the variable is not found then the -original C<%VariableName%> text is retained. Has the same effect -as the following: - - $string =~ s/%([^%]*)%/$ENV{$1} || "%$1%"/eg - -However, this function may return a Unicode string if the environment -variable being expanded hasn't been assigned to via %ENV. Access -to %ENV is currently always using byte semantics. - -=item Win32::FormatMessage(ERRORCODE) - -[CORE] Converts the supplied Win32 error number (e.g. returned by -Win32::GetLastError()) to a descriptive string. Analogous to the -perror() standard-C library function. Note that C<$^E> used -in a string context has much the same effect. - - C:\> perl -e "$^E = 26; print $^E;" - The specified disk or diskette cannot be accessed - -=item Win32::FsType() - -[CORE] Returns the name of the filesystem of the currently active -drive (like 'FAT' or 'NTFS'). In list context it returns three values: -(FSTYPE, FLAGS, MAXCOMPLEN). FSTYPE is the filesystem type as -before. FLAGS is a combination of values of the following table: - - 0x00000001 supports case-sensitive filenames - 0x00000002 preserves the case of filenames - 0x00000004 supports Unicode in filenames - 0x00000008 preserves and enforces ACLs - 0x00000010 supports file-based compression - 0x00000020 supports disk quotas - 0x00000040 supports sparse files - 0x00000080 supports reparse points - 0x00000100 supports remote storage - 0x00008000 is a compressed volume (e.g. DoubleSpace) - 0x00010000 supports object identifiers - 0x00020000 supports the Encrypted File System (EFS) - -MAXCOMPLEN is the maximum length of a filename component (the part -between two backslashes) on this file system. - -=item Win32::FreeLibrary(HANDLE) - -Unloads a previously loaded dynamic-link library. The HANDLE is -no longer valid after this call. See L -for information on dynamically loading a library. - -=item Win32::GetANSIPathName(FILENAME) - -Returns an ANSI version of FILENAME. This may be the short name -if the long name cannot be represented in the system codepage. - -While not currently implemented, it is possible that in the future -this function will convert only parts of the path to FILENAME to a -short form. - -If FILENAME doesn't exist on the filesystem, or if the filesystem -doesn't support short ANSI filenames, then this function will -translate the Unicode name into the system codepage using replacement -characters. - -=item Win32::GetArchName() - -Use of this function is deprecated. It is equivalent with -$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X. - -=item Win32::GetChipName() - -Returns the processor type: 386, 486 or 586 for Intel processors, -21064 for the Alpha chip. - -=item Win32::GetCwd() - -[CORE] Returns the current active drive and directory. This function -does not return a UNC path, since the functionality required for such -a feature is not available under Windows 95. - -If supported by the core Perl version, this function will return an -ANSI path name for the current directory if the long pathname cannot -be represented in the system codepage. - -=item Win32::GetCurrentProcessId() - -Returns the process identifier of the current process. Until the -process terminates, the process identifier uniquely identifies the -process throughout the system. - -The current process identifier is normally also available via the -predefined $$ variable. Under fork() emulation however $$ may contain -a pseudo-process identifier that is only meaningful to the Perl -kill(), wait() and waitpid() functions. The -Win32::GetCurrentProcessId() function will always return the regular -Windows process id, even when called from inside a pseudo-process. - -=item Win32::GetCurrentThreadId() - -Returns the thread identifier of the calling thread. Until the thread -terminates, the thread identifier uniquely identifies the thread -throughout the system. - -=item Win32::GetFileVersion(FILENAME) - -Returns the file version number from the VERSIONINFO resource of -the executable file or DLL. This is a tuple of four 16 bit numbers. -In list context these four numbers will be returned. In scalar context -they are concatenated into a string, separated by dots. - -=item Win32::GetFolderPath(FOLDER [, CREATE]) - -Returns the full pathname of one of the Windows special folders. -The folder will be created if it doesn't exist and the optional CREATE -argument is true. The following FOLDER constants are defined by the -Win32 module, but only exported on demand: - - CSIDL_ADMINTOOLS - CSIDL_APPDATA - CSIDL_CDBURN_AREA - CSIDL_COMMON_ADMINTOOLS - CSIDL_COMMON_APPDATA - CSIDL_COMMON_DESKTOPDIRECTORY - CSIDL_COMMON_DOCUMENTS - CSIDL_COMMON_FAVORITES - CSIDL_COMMON_MUSIC - CSIDL_COMMON_PICTURES - CSIDL_COMMON_PROGRAMS - CSIDL_COMMON_STARTMENU - CSIDL_COMMON_STARTUP - CSIDL_COMMON_TEMPLATES - CSIDL_COMMON_VIDEO - CSIDL_COOKIES - CSIDL_DESKTOP - CSIDL_DESKTOPDIRECTORY - CSIDL_FAVORITES - CSIDL_FONTS - CSIDL_HISTORY - CSIDL_INTERNET_CACHE - CSIDL_LOCAL_APPDATA - CSIDL_MYMUSIC - CSIDL_MYPICTURES - CSIDL_MYVIDEO - CSIDL_NETHOOD - CSIDL_PERSONAL - CSIDL_PRINTHOOD - CSIDL_PROFILE - CSIDL_PROGRAMS - CSIDL_PROGRAM_FILES - CSIDL_PROGRAM_FILES_COMMON - CSIDL_RECENT - CSIDL_RESOURCES - CSIDL_RESOURCES_LOCALIZED - CSIDL_SENDTO - CSIDL_STARTMENU - CSIDL_STARTUP - CSIDL_SYSTEM - CSIDL_TEMPLATES - CSIDL_WINDOWS - -Note that not all folders are defined on all versions of Windows. - -Please refer to the MSDN documentation of the CSIDL constants, -currently available at: - -http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/enums/csidl.asp - -This function will return an ANSI folder path if the long name cannot -be represented in the system codepage. Use Win32::GetLongPathName() -on the result of Win32::GetFolderPath() if you want the Unicode -version of the folder name. - -=item Win32::GetFullPathName(FILENAME) - -[CORE] GetFullPathName combines the FILENAME with the current drive -and directory name and returns a fully qualified (aka, absolute) -path name. In list context it returns two elements: (PATH, FILE) where -PATH is the complete pathname component (including trailing backslash) -and FILE is just the filename part. Note that no attempt is made to -convert 8.3 components in the supplied FILENAME to longnames or -vice-versa. Compare with Win32::GetShortPathName() and -Win32::GetLongPathName(). - -If supported by the core Perl version, this function will return an -ANSI path name if the full pathname cannot be represented in the -system codepage. - -=item Win32::GetLastError() - -[CORE] Returns the last error value generated by a call to a Win32 API -function. Note that C<$^E> used in a numeric context amounts to the -same value. - -=item Win32::GetLongPathName(PATHNAME) - -[CORE] Returns a representation of PATHNAME composed of longname -components (if any). The result may not necessarily be longer -than PATHNAME. No attempt is made to convert PATHNAME to the -absolute path. Compare with Win32::GetShortPathName() and -Win32::GetFullPathName(). - -This function may return the pathname in Unicode if it cannot be -represented in the system codepage. Use Win32::GetANSIPathName() -before passing the path to a system call or another program. - -=item Win32::GetNextAvailDrive() - -[CORE] Returns a string in the form of ":" where is the first -available drive letter. - -=item Win32::GetOSVersion() - -[CORE] Returns the list (STRING, MAJOR, MINOR, BUILD, ID), where the -elements are, respectively: An arbitrary descriptive string, the major -version number of the operating system, the minor version number, the -build number, and a digit indicating the actual operating system. -For the ID, the values are 0 for Win32s, 1 for Windows 9X/Me and 2 for -Windows NT/2000/XP/2003/Vista/2008/7. In scalar context it returns just -the ID. - -Currently known values for ID MAJOR and MINOR are as follows: - - OS ID MAJOR MINOR - Win32s 0 - - - Windows 95 1 4 0 - Windows 98 1 4 10 - Windows Me 1 4 90 - Windows NT 3.51 2 3 51 - Windows NT 4 2 4 0 - Windows 2000 2 5 0 - Windows XP 2 5 1 - Windows Server 2003 2 5 2 - Windows Vista 2 6 0 - Windows Server 2008 2 6 0 - Windows 7 2 6 1 - -On Windows NT 4 SP6 and later this function returns the following -additional values: SPMAJOR, SPMINOR, SUITEMASK, PRODUCTTYPE. - -The version numbers for Windows Vista and Windows Server 2008 are -identical; the PRODUCTTYPE field must be used to differentiate -between them. - -SPMAJOR and SPMINOR are are the version numbers of the latest -installed service pack. - -SUITEMASK is a bitfield identifying the product suites available on -the system. Known bits are: - - VER_SUITE_SMALLBUSINESS 0x00000001 - VER_SUITE_ENTERPRISE 0x00000002 - VER_SUITE_BACKOFFICE 0x00000004 - VER_SUITE_COMMUNICATIONS 0x00000008 - VER_SUITE_TERMINAL 0x00000010 - VER_SUITE_SMALLBUSINESS_RESTRICTED 0x00000020 - VER_SUITE_EMBEDDEDNT 0x00000040 - VER_SUITE_DATACENTER 0x00000080 - VER_SUITE_SINGLEUSERTS 0x00000100 - VER_SUITE_PERSONAL 0x00000200 - VER_SUITE_BLADE 0x00000400 - VER_SUITE_EMBEDDED_RESTRICTED 0x00000800 - VER_SUITE_SECURITY_APPLIANCE 0x00001000 - -The VER_SUITE_xxx names are listed here to crossreference the Microsoft -documentation. The Win32 module does not provide symbolic names for these -constants. - -PRODUCTTYPE provides additional information about the system. It should -be one of the following integer values: - - 1 - Workstation (NT 4, 2000 Pro, XP Home, XP Pro, Vista) - 2 - Domaincontroller - 3 - Server (2000 Server, Server 2003, Server 2008) - -Note that a server that is also a domain controller is reported as -PRODUCTTYPE 2 (Domaincontroller) and not PRODUCTTYPE 3 (Server). - -=item Win32::GetOSName() - -In scalar context returns the name of the Win32 operating system -being used. In list context returns a two element list of the OS name -and whatever edition information is known about the particular build -(for Win9X boxes) and whatever service packs have been installed. -The latter is roughly equivalent to the first item returned by -GetOSVersion() in list context. - -Currently the possible values for the OS name are - - WinWin32s - Win95 - Win98 - WinMe - WinNT3.51 - WinNT4 - Win2000 - WinXP/.Net - Win2003 - WinVista - Win2008 - Win7 - -This routine is just a simple interface into GetOSVersion(). More -specific or demanding situations should use that instead. Another -option would be to use POSIX::uname(), however the latter appears to -report only the OS family name and not the specific OS. In scalar -context it returns just the ID. - -The name "WinXP/.Net" is used for historical reasons only, to maintain -backwards compatibility of the Win32 module. Windows .NET Server has -been renamed as Windows 2003 Server before final release and uses a -different major/minor version number than Windows XP. - -Similarly the name "WinWin32s" should have been "Win32s" but has been -kept as-is for backwards compatibility reasons too. - -=item Win32::GetShortPathName(PATHNAME) - -[CORE] Returns a representation of PATHNAME that is composed of short -(8.3) path components where available. For path components where the -file system has not generated the short form the returned path will -use the long form, so this function might still for instance return a -path containing spaces. Returns C when the PATHNAME does not -exist. Compare with Win32::GetFullPathName() and -Win32::GetLongPathName(). - -=item Win32::GetProcAddress(INSTANCE, PROCNAME) - -Returns the address of a function inside a loaded library. The -information about what you can do with this address has been lost in -the mist of time. Use the Win32::API module instead of this deprecated -function. - -=item Win32::GetTickCount() - -[CORE] Returns the number of milliseconds elapsed since the last -system boot. Resolution is limited to system timer ticks (about 10ms -on WinNT and 55ms on Win9X). - -=item Win32::GuidGen() - -Creates a globally unique 128 bit integer that can be used as a -persistent identifier in a distributed setting. To a very high degree -of certainty this function returns a unique value. No other -invocation, on the same or any other system (networked or not), should -return the same value. - -The return value is formatted according to OLE conventions, as groups -of hex digits with surrounding braces. For example: - - {09531CF1-D0C7-4860-840C-1C8C8735E2AD} - -=item Win32::InitiateSystemShutdown - -(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) - -Shutsdown the specified MACHINE, notifying users with the -supplied MESSAGE, within the specified TIMEOUT interval. Forces -closing of all documents without prompting the user if FORCECLOSE is -true, and reboots the machine if REBOOT is true. This function works -only on WinNT. - -=item Win32::IsAdminUser() - -Returns non zero if the account in whose security context the -current process/thread is running belongs to the local group of -Administrators in the built-in system domain; returns 0 if not. -On Windows Vista it will only return non-zero if the process is -actually running with elevated privileges. Returns C -and prints a warning if an error occurred. This function always -returns 1 on Win9X. - -=item Win32::IsWinNT() - -[CORE] Returns non zero if the Win32 subsystem is Windows NT. - -=item Win32::IsWin95() - -[CORE] Returns non zero if the Win32 subsystem is Windows 95. - -=item Win32::LoadLibrary(LIBNAME) - -Loads a dynamic link library into memory and returns its module -handle. This handle can be used with Win32::GetProcAddress() and -Win32::FreeLibrary(). This function is deprecated. Use the Win32::API -module instead. - -=item Win32::LoginName() - -[CORE] Returns the username of the owner of the current perl process. -The return value may be a Unicode string. - -=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE) - -Looks up ACCOUNT on SYSTEM and returns the domain name the SID and -the SID type. - -=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE) - -Looks up SID on SYSTEM and returns the account name, domain name, -and the SID type. - -=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]]) - -Create a dialogbox containing MESSAGE. FLAGS specifies the -required icon and buttons according to the following table: - - 0 = OK - 1 = OK and Cancel - 2 = Abort, Retry, and Ignore - 3 = Yes, No and Cancel - 4 = Yes and No - 5 = Retry and Cancel - - MB_ICONSTOP "X" in a red circle - MB_ICONQUESTION question mark in a bubble - MB_ICONEXCLAMATION exclamation mark in a yellow triangle - MB_ICONINFORMATION "i" in a bubble - -TITLE specifies an optional window title. The default is "Perl". - -The function returns the menu id of the selected push button: - - 0 Error - - 1 OK - 2 Cancel - 3 Abort - 4 Retry - 5 Ignore - 6 Yes - 7 No - -=item Win32::NodeName() - -[CORE] Returns the Microsoft Network node-name of the current machine. - -=item Win32::OutputDebugString(STRING) - -Sends a string to the application or system debugger for display. -The function does nothing if there is no active debugger. - -Alternatively one can use the I application to -watch the OutputDebugString() output: - -http://www.microsoft.com/technet/sysinternals/utilities/debugview.mspx - -=item Win32::RegisterServer(LIBRARYNAME) - -Loads the DLL LIBRARYNAME and calls the function DllRegisterServer. - -=item Win32::SetChildShowWindow(SHOWWINDOW) - -[CORE] Sets the I of child processes started by system(). -By default system() will create a new console window for child -processes if Perl itself is not running from a console. Calling -SetChildShowWindow(0) will make these new console windows invisible. -Calling SetChildShowWindow() without arguments reverts system() to the -default behavior. The return value of SetChildShowWindow() is the -previous setting or C. - -The following symbolic constants for SHOWWINDOW are available -(but not exported) from the Win32 module: SW_HIDE, SW_SHOWNORMAL, -SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED and SW_SHOWNOACTIVATE. - -=item Win32::SetCwd(NEWDIRECTORY) - -[CORE] Sets the current active drive and directory. This function does not -work with UNC paths, since the functionality required to required for -such a feature is not available under Windows 95. - -=item Win32::SetLastError(ERROR) - -[CORE] Sets the value of the last error encountered to ERROR. This is -that value that will be returned by the Win32::GetLastError() -function. - -=item Win32::Sleep(TIME) - -[CORE] Pauses for TIME milliseconds. The timeslices are made available -to other processes and threads. - -=item Win32::Spawn(COMMAND, ARGS, PID) - -[CORE] Spawns a new process using the supplied COMMAND, passing in -arguments in the string ARGS. The pid of the new process is stored in -PID. This function is deprecated. Please use the Win32::Process module -instead. - -=item Win32::UnregisterServer(LIBRARYNAME) - -Loads the DLL LIBRARYNAME and calls the function -DllUnregisterServer. - -=back - -=cut +package Win32; + +BEGIN { + use strict; + use vars qw|$VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK|; + + require Exporter; + require DynaLoader; + + @ISA = qw|Exporter DynaLoader|; + $VERSION = '0.39'; + $XS_VERSION = $VERSION; + $VERSION = eval $VERSION; + + @EXPORT = qw( + NULL + WIN31_CLASS + OWNER_SECURITY_INFORMATION + GROUP_SECURITY_INFORMATION + DACL_SECURITY_INFORMATION + SACL_SECURITY_INFORMATION + MB_ICONHAND + MB_ICONQUESTION + MB_ICONEXCLAMATION + MB_ICONASTERISK + MB_ICONWARNING + MB_ICONERROR + MB_ICONINFORMATION + MB_ICONSTOP + ); + @EXPORT_OK = qw( + GetOSName + SW_HIDE + SW_SHOWNORMAL + SW_SHOWMINIMIZED + SW_SHOWMAXIMIZED + SW_SHOWNOACTIVATE + + CSIDL_DESKTOP + CSIDL_PROGRAMS + CSIDL_PERSONAL + CSIDL_FAVORITES + CSIDL_STARTUP + CSIDL_RECENT + CSIDL_SENDTO + CSIDL_STARTMENU + CSIDL_MYMUSIC + CSIDL_MYVIDEO + CSIDL_DESKTOPDIRECTORY + CSIDL_NETHOOD + CSIDL_FONTS + CSIDL_TEMPLATES + CSIDL_COMMON_STARTMENU + CSIDL_COMMON_PROGRAMS + CSIDL_COMMON_STARTUP + CSIDL_COMMON_DESKTOPDIRECTORY + CSIDL_APPDATA + CSIDL_PRINTHOOD + CSIDL_LOCAL_APPDATA + CSIDL_COMMON_FAVORITES + CSIDL_INTERNET_CACHE + CSIDL_COOKIES + CSIDL_HISTORY + CSIDL_COMMON_APPDATA + CSIDL_WINDOWS + CSIDL_SYSTEM + CSIDL_PROGRAM_FILES + CSIDL_MYPICTURES + CSIDL_PROFILE + CSIDL_PROGRAM_FILES_COMMON + CSIDL_COMMON_TEMPLATES + CSIDL_COMMON_DOCUMENTS + CSIDL_COMMON_ADMINTOOLS + CSIDL_ADMINTOOLS + CSIDL_COMMON_MUSIC + CSIDL_COMMON_PICTURES + CSIDL_COMMON_VIDEO + CSIDL_RESOURCES + CSIDL_RESOURCES_LOCALIZED + CSIDL_CDBURN_AREA + ); +} + +# We won't bother with the constant stuff, too much of a hassle. Just hard +# code it here. + +sub NULL { 0 } +sub WIN31_CLASS { &NULL } + +sub OWNER_SECURITY_INFORMATION { 0x00000001 } +sub GROUP_SECURITY_INFORMATION { 0x00000002 } +sub DACL_SECURITY_INFORMATION { 0x00000004 } +sub SACL_SECURITY_INFORMATION { 0x00000008 } + +sub MB_ICONHAND { 0x00000010 } +sub MB_ICONQUESTION { 0x00000020 } +sub MB_ICONEXCLAMATION { 0x00000030 } +sub MB_ICONASTERISK { 0x00000040 } +sub MB_ICONWARNING { 0x00000030 } +sub MB_ICONERROR { 0x00000010 } +sub MB_ICONINFORMATION { 0x00000040 } +sub MB_ICONSTOP { 0x00000010 } + +# +# Newly added constants. These have an empty prototype, unlike the +# the ones above, which aren't prototyped for compatibility reasons. +# +sub SW_HIDE () { 0 } +sub SW_SHOWNORMAL () { 1 } +sub SW_SHOWMINIMIZED () { 2 } +sub SW_SHOWMAXIMIZED () { 3 } +sub SW_SHOWNOACTIVATE () { 4 } + +sub CSIDL_DESKTOP () { 0x0000 } # +sub CSIDL_PROGRAMS () { 0x0002 } # Start Menu\Programs +sub CSIDL_PERSONAL () { 0x0005 } # "My Documents" folder +sub CSIDL_FAVORITES () { 0x0006 } # \Favorites +sub CSIDL_STARTUP () { 0x0007 } # Start Menu\Programs\Startup +sub CSIDL_RECENT () { 0x0008 } # \Recent +sub CSIDL_SENDTO () { 0x0009 } # \SendTo +sub CSIDL_STARTMENU () { 0x000B } # \Start Menu +sub CSIDL_MYMUSIC () { 0x000D } # "My Music" folder +sub CSIDL_MYVIDEO () { 0x000E } # "My Videos" folder +sub CSIDL_DESKTOPDIRECTORY () { 0x0010 } # \Desktop +sub CSIDL_NETHOOD () { 0x0013 } # \nethood +sub CSIDL_FONTS () { 0x0014 } # windows\fonts +sub CSIDL_TEMPLATES () { 0x0015 } +sub CSIDL_COMMON_STARTMENU () { 0x0016 } # All Users\Start Menu +sub CSIDL_COMMON_PROGRAMS () { 0x0017 } # All Users\Start Menu\Programs +sub CSIDL_COMMON_STARTUP () { 0x0018 } # All Users\Startup +sub CSIDL_COMMON_DESKTOPDIRECTORY () { 0x0019 } # All Users\Desktop +sub CSIDL_APPDATA () { 0x001A } # Application Data, new for NT4 +sub CSIDL_PRINTHOOD () { 0x001B } # \PrintHood +sub CSIDL_LOCAL_APPDATA () { 0x001C } # non roaming, user\Local Settings\Application Data +sub CSIDL_COMMON_FAVORITES () { 0x001F } +sub CSIDL_INTERNET_CACHE () { 0x0020 } +sub CSIDL_COOKIES () { 0x0021 } +sub CSIDL_HISTORY () { 0x0022 } +sub CSIDL_COMMON_APPDATA () { 0x0023 } # All Users\Application Data +sub CSIDL_WINDOWS () { 0x0024 } # GetWindowsDirectory() +sub CSIDL_SYSTEM () { 0x0025 } # GetSystemDirectory() +sub CSIDL_PROGRAM_FILES () { 0x0026 } # C:\Program Files +sub CSIDL_MYPICTURES () { 0x0027 } # "My Pictures", new for Win2K +sub CSIDL_PROFILE () { 0x0028 } # USERPROFILE +sub CSIDL_PROGRAM_FILES_COMMON () { 0x002B } # C:\Program Files\Common +sub CSIDL_COMMON_TEMPLATES () { 0x002D } # All Users\Templates +sub CSIDL_COMMON_DOCUMENTS () { 0x002E } # All Users\Documents +sub CSIDL_COMMON_ADMINTOOLS () { 0x002F } # All Users\Start Menu\Programs\Administrative Tools +sub CSIDL_ADMINTOOLS () { 0x0030 } # \Start Menu\Programs\Administrative Tools +sub CSIDL_COMMON_MUSIC () { 0x0035 } # All Users\My Music +sub CSIDL_COMMON_PICTURES () { 0x0036 } # All Users\My Pictures +sub CSIDL_COMMON_VIDEO () { 0x0037 } # All Users\My Video +sub CSIDL_RESOURCES () { 0x0038 } # %windir%\Resources\, For theme and other windows resources. +sub CSIDL_RESOURCES_LOCALIZED () { 0x0039 } # %windir%\Resources\, for theme and other windows specific resources. +sub CSIDL_CDBURN_AREA () { 0x003B } # \Local Settings\Application Data\Microsoft\CD Burning + +### This method is just a simple interface into GetOSVersion(). More +### specific or demanding situations should use that instead. + +my ($cached_os, $cached_desc); + +sub GetOSName { + unless (defined $cached_os) { + my($desc, $major, $minor, $build, $id, undef, undef, undef, $producttype) + = Win32::GetOSVersion(); + ($cached_os, $cached_desc) = _GetOSName($desc, $major, $minor, $build, $id, $producttype); + } + return wantarray ? ($cached_os, $cached_desc) : $cached_os; +} + +sub _GetOSName { + my($desc, $major, $minor, $build, $id, $producttype) = @_; + + my($os,$tag); + if ($id == 0) { + $os = "Win32s"; + } + elsif ($id == 1) { + $os = { 0 => "95", 10 => "98", 90 => "Me" }->{$minor}; + } + elsif ($id == 2) { + if ($major == 3) { + $os = "NT3.51"; + } + elsif ($major == 4) { + $os = "NT4"; + } + elsif ($major == 5) { + $os = { 0 => "2000", 1 => "XP/.Net", 2 => "2003" }->{$minor}; + } + elsif ($major == 6) { + $os = { 0 => "Vista", 1 => "7" }->{$minor}; + # 2008 is same as Vista but has "Domaincontroller" or "Server" type + $os = "2008" if $os eq "Vista" && $producttype != 1; + } + } + + unless (defined $os) { + warn "Unknown Windows version [$id:$major:$minor]"; + return; + } + + # Take a look at the build numbers and try to deduce + # the exact release name, but we put that in the $desc + if ($os eq "95") { + $tag = { 67109814 => "(a)", 67306684 => "(b1)", "67109975" => "(b2)" }->{$build}; + } + elsif ($os eq "98" && $build eq "67766446") { + $tag = "(2nd ed)"; + } + if ($tag) { + $desc = length($desc) ? "$tag $desc" : $tag; + } + + return ("Win$os", $desc); +} + +# "no warnings 'redefine';" doesn't work for 5.8.7 and earlier +local $^W = 0; +bootstrap Win32; + +1; + +__END__ + +=head1 NAME + +Win32 - Interfaces to some Win32 API Functions + +=head1 DESCRIPTION + +The Win32 module contains functions to access Win32 APIs. + +=head2 Alphabetical Listing of Win32 Functions + +It is recommended to C before any of these functions; +however, for backwards compatibility, those marked as [CORE] will +automatically do this for you. + +In the function descriptions below the term I is used +to indicate that the string may contain characters outside the system +codepage. The caveat I +generally means Perl 5.8.9 and later, though some Unicode pathname +functionality may work on earlier versions. + +=over + +=item Win32::AbortSystemShutdown(MACHINE) + +Aborts a system shutdown (started by the +InitiateSystemShutdown function) on the specified MACHINE. + +=item Win32::BuildNumber() + +[CORE] Returns the ActivePerl build number. This function is +only available in the ActivePerl binary distribution. + +=item Win32::CopyFile(FROM, TO, OVERWRITE) + +[CORE] The Win32::CopyFile() function copies an existing file to a new +file. All file information like creation time and file attributes will +be copied to the new file. However it will B copy the security +information. If the destination file already exists it will only be +overwritten when the OVERWRITE parameter is true. But even this will +not overwrite a read-only file; you have to unlink() it first +yourself. + +=item Win32::CreateDirectory(DIRECTORY) + +Creates the DIRECTORY and returns a true value on success. Check $^E +on failure for extended error information. + +DIRECTORY may contain Unicode characters outside the system codepage. +Once the directory has been created you can use +Win32::GetANSIPathName() to get a name that can be passed to system +calls and external programs. + +=item Win32::CreateFile(FILE) + +Creates the FILE and returns a true value on success. Check $^E on +failure for extended error information. + +FILE may contain Unicode characters outside the system codepage. Once +the file has been created you can use Win32::GetANSIPathName() to get +a name that can be passed to system calls and external programs. + +=item Win32::DomainName() + +[CORE] Returns the name of the Microsoft Network domain or workgroup +that the owner of the current perl process is logged into. The +"Workstation" service must be running to determine this +information. This function does B work on Windows 9x. + +=item Win32::ExpandEnvironmentStrings(STRING) + +Takes STRING and replaces all referenced environment variable +names with their defined values. References to environment variables +take the form C<%VariableName%>. Case is ignored when looking up the +VariableName in the environment. If the variable is not found then the +original C<%VariableName%> text is retained. Has the same effect +as the following: + + $string =~ s/%([^%]*)%/$ENV{$1} || "%$1%"/eg + +However, this function may return a Unicode string if the environment +variable being expanded hasn't been assigned to via %ENV. Access +to %ENV is currently always using byte semantics. + +=item Win32::FormatMessage(ERRORCODE) + +[CORE] Converts the supplied Win32 error number (e.g. returned by +Win32::GetLastError()) to a descriptive string. Analogous to the +perror() standard-C library function. Note that C<$^E> used +in a string context has much the same effect. + + C:\> perl -e "$^E = 26; print $^E;" + The specified disk or diskette cannot be accessed + +=item Win32::FsType() + +[CORE] Returns the name of the filesystem of the currently active +drive (like 'FAT' or 'NTFS'). In list context it returns three values: +(FSTYPE, FLAGS, MAXCOMPLEN). FSTYPE is the filesystem type as +before. FLAGS is a combination of values of the following table: + + 0x00000001 supports case-sensitive filenames + 0x00000002 preserves the case of filenames + 0x00000004 supports Unicode in filenames + 0x00000008 preserves and enforces ACLs + 0x00000010 supports file-based compression + 0x00000020 supports disk quotas + 0x00000040 supports sparse files + 0x00000080 supports reparse points + 0x00000100 supports remote storage + 0x00008000 is a compressed volume (e.g. DoubleSpace) + 0x00010000 supports object identifiers + 0x00020000 supports the Encrypted File System (EFS) + +MAXCOMPLEN is the maximum length of a filename component (the part +between two backslashes) on this file system. + +=item Win32::FreeLibrary(HANDLE) + +Unloads a previously loaded dynamic-link library. The HANDLE is +no longer valid after this call. See L +for information on dynamically loading a library. + +=item Win32::GetANSIPathName(FILENAME) + +Returns an ANSI version of FILENAME. This may be the short name +if the long name cannot be represented in the system codepage. + +While not currently implemented, it is possible that in the future +this function will convert only parts of the path to FILENAME to a +short form. + +If FILENAME doesn't exist on the filesystem, or if the filesystem +doesn't support short ANSI filenames, then this function will +translate the Unicode name into the system codepage using replacement +characters. + +=item Win32::GetArchName() + +Use of this function is deprecated. It is equivalent with +$ENV{PROCESSOR_ARCHITECTURE}. This might not work on Win9X. + +=item Win32::GetChipName() + +Returns the processor type: 386, 486 or 586 for Intel processors, +21064 for the Alpha chip. + +=item Win32::GetCwd() + +[CORE] Returns the current active drive and directory. This function +does not return a UNC path, since the functionality required for such +a feature is not available under Windows 95. + +If supported by the core Perl version, this function will return an +ANSI path name for the current directory if the long pathname cannot +be represented in the system codepage. + +=item Win32::GetCurrentProcessId() + +Returns the process identifier of the current process. Until the +process terminates, the process identifier uniquely identifies the +process throughout the system. + +The current process identifier is normally also available via the +predefined $$ variable. Under fork() emulation however $$ may contain +a pseudo-process identifier that is only meaningful to the Perl +kill(), wait() and waitpid() functions. The +Win32::GetCurrentProcessId() function will always return the regular +Windows process id, even when called from inside a pseudo-process. + +=item Win32::GetCurrentThreadId() + +Returns the thread identifier of the calling thread. Until the thread +terminates, the thread identifier uniquely identifies the thread +throughout the system. + +=item Win32::GetFileVersion(FILENAME) + +Returns the file version number from the VERSIONINFO resource of +the executable file or DLL. This is a tuple of four 16 bit numbers. +In list context these four numbers will be returned. In scalar context +they are concatenated into a string, separated by dots. + +=item Win32::GetFolderPath(FOLDER [, CREATE]) + +Returns the full pathname of one of the Windows special folders. +The folder will be created if it doesn't exist and the optional CREATE +argument is true. The following FOLDER constants are defined by the +Win32 module, but only exported on demand: + + CSIDL_ADMINTOOLS + CSIDL_APPDATA + CSIDL_CDBURN_AREA + CSIDL_COMMON_ADMINTOOLS + CSIDL_COMMON_APPDATA + CSIDL_COMMON_DESKTOPDIRECTORY + CSIDL_COMMON_DOCUMENTS + CSIDL_COMMON_FAVORITES + CSIDL_COMMON_MUSIC + CSIDL_COMMON_PICTURES + CSIDL_COMMON_PROGRAMS + CSIDL_COMMON_STARTMENU + CSIDL_COMMON_STARTUP + CSIDL_COMMON_TEMPLATES + CSIDL_COMMON_VIDEO + CSIDL_COOKIES + CSIDL_DESKTOP + CSIDL_DESKTOPDIRECTORY + CSIDL_FAVORITES + CSIDL_FONTS + CSIDL_HISTORY + CSIDL_INTERNET_CACHE + CSIDL_LOCAL_APPDATA + CSIDL_MYMUSIC + CSIDL_MYPICTURES + CSIDL_MYVIDEO + CSIDL_NETHOOD + CSIDL_PERSONAL + CSIDL_PRINTHOOD + CSIDL_PROFILE + CSIDL_PROGRAMS + CSIDL_PROGRAM_FILES + CSIDL_PROGRAM_FILES_COMMON + CSIDL_RECENT + CSIDL_RESOURCES + CSIDL_RESOURCES_LOCALIZED + CSIDL_SENDTO + CSIDL_STARTMENU + CSIDL_STARTUP + CSIDL_SYSTEM + CSIDL_TEMPLATES + CSIDL_WINDOWS + +Note that not all folders are defined on all versions of Windows. + +Please refer to the MSDN documentation of the CSIDL constants, +currently available at: + +http://msdn.microsoft.com/library/default.asp?url=/library/en-us/shellcc/platform/shell/reference/enums/csidl.asp + +This function will return an ANSI folder path if the long name cannot +be represented in the system codepage. Use Win32::GetLongPathName() +on the result of Win32::GetFolderPath() if you want the Unicode +version of the folder name. + +=item Win32::GetFullPathName(FILENAME) + +[CORE] GetFullPathName combines the FILENAME with the current drive +and directory name and returns a fully qualified (aka, absolute) +path name. In list context it returns two elements: (PATH, FILE) where +PATH is the complete pathname component (including trailing backslash) +and FILE is just the filename part. Note that no attempt is made to +convert 8.3 components in the supplied FILENAME to longnames or +vice-versa. Compare with Win32::GetShortPathName() and +Win32::GetLongPathName(). + +If supported by the core Perl version, this function will return an +ANSI path name if the full pathname cannot be represented in the +system codepage. + +=item Win32::GetLastError() + +[CORE] Returns the last error value generated by a call to a Win32 API +function. Note that C<$^E> used in a numeric context amounts to the +same value. + +=item Win32::GetLongPathName(PATHNAME) + +[CORE] Returns a representation of PATHNAME composed of longname +components (if any). The result may not necessarily be longer +than PATHNAME. No attempt is made to convert PATHNAME to the +absolute path. Compare with Win32::GetShortPathName() and +Win32::GetFullPathName(). + +This function may return the pathname in Unicode if it cannot be +represented in the system codepage. Use Win32::GetANSIPathName() +before passing the path to a system call or another program. + +=item Win32::GetNextAvailDrive() + +[CORE] Returns a string in the form of ":" where is the first +available drive letter. + +=item Win32::GetOSVersion() + +[CORE] Returns the list (STRING, MAJOR, MINOR, BUILD, ID), where the +elements are, respectively: An arbitrary descriptive string, the major +version number of the operating system, the minor version number, the +build number, and a digit indicating the actual operating system. +For the ID, the values are 0 for Win32s, 1 for Windows 9X/Me and 2 for +Windows NT/2000/XP/2003/Vista/2008/7. In scalar context it returns just +the ID. + +Currently known values for ID MAJOR and MINOR are as follows: + + OS ID MAJOR MINOR + Win32s 0 - - + Windows 95 1 4 0 + Windows 98 1 4 10 + Windows Me 1 4 90 + Windows NT 3.51 2 3 51 + Windows NT 4 2 4 0 + Windows 2000 2 5 0 + Windows XP 2 5 1 + Windows Server 2003 2 5 2 + Windows Vista 2 6 0 + Windows Server 2008 2 6 0 + Windows 7 2 6 1 + +On Windows NT 4 SP6 and later this function returns the following +additional values: SPMAJOR, SPMINOR, SUITEMASK, PRODUCTTYPE. + +The version numbers for Windows Vista and Windows Server 2008 are +identical; the PRODUCTTYPE field must be used to differentiate +between them. + +SPMAJOR and SPMINOR are are the version numbers of the latest +installed service pack. + +SUITEMASK is a bitfield identifying the product suites available on +the system. Known bits are: + + VER_SUITE_SMALLBUSINESS 0x00000001 + VER_SUITE_ENTERPRISE 0x00000002 + VER_SUITE_BACKOFFICE 0x00000004 + VER_SUITE_COMMUNICATIONS 0x00000008 + VER_SUITE_TERMINAL 0x00000010 + VER_SUITE_SMALLBUSINESS_RESTRICTED 0x00000020 + VER_SUITE_EMBEDDEDNT 0x00000040 + VER_SUITE_DATACENTER 0x00000080 + VER_SUITE_SINGLEUSERTS 0x00000100 + VER_SUITE_PERSONAL 0x00000200 + VER_SUITE_BLADE 0x00000400 + VER_SUITE_EMBEDDED_RESTRICTED 0x00000800 + VER_SUITE_SECURITY_APPLIANCE 0x00001000 + +The VER_SUITE_xxx names are listed here to crossreference the Microsoft +documentation. The Win32 module does not provide symbolic names for these +constants. + +PRODUCTTYPE provides additional information about the system. It should +be one of the following integer values: + + 1 - Workstation (NT 4, 2000 Pro, XP Home, XP Pro, Vista) + 2 - Domaincontroller + 3 - Server (2000 Server, Server 2003, Server 2008) + +Note that a server that is also a domain controller is reported as +PRODUCTTYPE 2 (Domaincontroller) and not PRODUCTTYPE 3 (Server). + +=item Win32::GetOSName() + +In scalar context returns the name of the Win32 operating system +being used. In list context returns a two element list of the OS name +and whatever edition information is known about the particular build +(for Win9X boxes) and whatever service packs have been installed. +The latter is roughly equivalent to the first item returned by +GetOSVersion() in list context. + +Currently the possible values for the OS name are + + WinWin32s + Win95 + Win98 + WinMe + WinNT3.51 + WinNT4 + Win2000 + WinXP/.Net + Win2003 + WinVista + Win2008 + Win7 + +This routine is just a simple interface into GetOSVersion(). More +specific or demanding situations should use that instead. Another +option would be to use POSIX::uname(), however the latter appears to +report only the OS family name and not the specific OS. In scalar +context it returns just the ID. + +The name "WinXP/.Net" is used for historical reasons only, to maintain +backwards compatibility of the Win32 module. Windows .NET Server has +been renamed as Windows 2003 Server before final release and uses a +different major/minor version number than Windows XP. + +Similarly the name "WinWin32s" should have been "Win32s" but has been +kept as-is for backwards compatibility reasons too. + +=item Win32::GetShortPathName(PATHNAME) + +[CORE] Returns a representation of PATHNAME that is composed of short +(8.3) path components where available. For path components where the +file system has not generated the short form the returned path will +use the long form, so this function might still for instance return a +path containing spaces. Returns C when the PATHNAME does not +exist. Compare with Win32::GetFullPathName() and +Win32::GetLongPathName(). + +=item Win32::GetProcAddress(INSTANCE, PROCNAME) + +Returns the address of a function inside a loaded library. The +information about what you can do with this address has been lost in +the mist of time. Use the Win32::API module instead of this deprecated +function. + +=item Win32::GetTickCount() + +[CORE] Returns the number of milliseconds elapsed since the last +system boot. Resolution is limited to system timer ticks (about 10ms +on WinNT and 55ms on Win9X). + +=item Win32::GuidGen() + +Creates a globally unique 128 bit integer that can be used as a +persistent identifier in a distributed setting. To a very high degree +of certainty this function returns a unique value. No other +invocation, on the same or any other system (networked or not), should +return the same value. + +The return value is formatted according to OLE conventions, as groups +of hex digits with surrounding braces. For example: + + {09531CF1-D0C7-4860-840C-1C8C8735E2AD} + +=item Win32::InitiateSystemShutdown + +(MACHINE, MESSAGE, TIMEOUT, FORCECLOSE, REBOOT) + +Shutsdown the specified MACHINE, notifying users with the +supplied MESSAGE, within the specified TIMEOUT interval. Forces +closing of all documents without prompting the user if FORCECLOSE is +true, and reboots the machine if REBOOT is true. This function works +only on WinNT. + +=item Win32::IsAdminUser() + +Returns non zero if the account in whose security context the +current process/thread is running belongs to the local group of +Administrators in the built-in system domain; returns 0 if not. +On Windows Vista it will only return non-zero if the process is +actually running with elevated privileges. Returns C +and prints a warning if an error occurred. This function always +returns 1 on Win9X. + +=item Win32::IsWinNT() + +[CORE] Returns non zero if the Win32 subsystem is Windows NT. + +=item Win32::IsWin95() + +[CORE] Returns non zero if the Win32 subsystem is Windows 95. + +=item Win32::LoadLibrary(LIBNAME) + +Loads a dynamic link library into memory and returns its module +handle. This handle can be used with Win32::GetProcAddress() and +Win32::FreeLibrary(). This function is deprecated. Use the Win32::API +module instead. + +=item Win32::LoginName() + +[CORE] Returns the username of the owner of the current perl process. +The return value may be a Unicode string. + +=item Win32::LookupAccountName(SYSTEM, ACCOUNT, DOMAIN, SID, SIDTYPE) + +Looks up ACCOUNT on SYSTEM and returns the domain name the SID and +the SID type. + +=item Win32::LookupAccountSID(SYSTEM, SID, ACCOUNT, DOMAIN, SIDTYPE) + +Looks up SID on SYSTEM and returns the account name, domain name, +and the SID type. + +=item Win32::MsgBox(MESSAGE [, FLAGS [, TITLE]]) + +Create a dialogbox containing MESSAGE. FLAGS specifies the +required icon and buttons according to the following table: + + 0 = OK + 1 = OK and Cancel + 2 = Abort, Retry, and Ignore + 3 = Yes, No and Cancel + 4 = Yes and No + 5 = Retry and Cancel + + MB_ICONSTOP "X" in a red circle + MB_ICONQUESTION question mark in a bubble + MB_ICONEXCLAMATION exclamation mark in a yellow triangle + MB_ICONINFORMATION "i" in a bubble + +TITLE specifies an optional window title. The default is "Perl". + +The function returns the menu id of the selected push button: + + 0 Error + + 1 OK + 2 Cancel + 3 Abort + 4 Retry + 5 Ignore + 6 Yes + 7 No + +=item Win32::NodeName() + +[CORE] Returns the Microsoft Network node-name of the current machine. + +=item Win32::OutputDebugString(STRING) + +Sends a string to the application or system debugger for display. +The function does nothing if there is no active debugger. + +Alternatively one can use the I application to +watch the OutputDebugString() output: + +http://www.microsoft.com/technet/sysinternals/utilities/debugview.mspx + +=item Win32::RegisterServer(LIBRARYNAME) + +Loads the DLL LIBRARYNAME and calls the function DllRegisterServer. + +=item Win32::SetChildShowWindow(SHOWWINDOW) + +[CORE] Sets the I of child processes started by system(). +By default system() will create a new console window for child +processes if Perl itself is not running from a console. Calling +SetChildShowWindow(0) will make these new console windows invisible. +Calling SetChildShowWindow() without arguments reverts system() to the +default behavior. The return value of SetChildShowWindow() is the +previous setting or C. + +The following symbolic constants for SHOWWINDOW are available +(but not exported) from the Win32 module: SW_HIDE, SW_SHOWNORMAL, +SW_SHOWMINIMIZED, SW_SHOWMAXIMIZED and SW_SHOWNOACTIVATE. + +=item Win32::SetCwd(NEWDIRECTORY) + +[CORE] Sets the current active drive and directory. This function does not +work with UNC paths, since the functionality required to required for +such a feature is not available under Windows 95. + +=item Win32::SetLastError(ERROR) + +[CORE] Sets the value of the last error encountered to ERROR. This is +that value that will be returned by the Win32::GetLastError() +function. + +=item Win32::Sleep(TIME) + +[CORE] Pauses for TIME milliseconds. The timeslices are made available +to other processes and threads. + +=item Win32::Spawn(COMMAND, ARGS, PID) + +[CORE] Spawns a new process using the supplied COMMAND, passing in +arguments in the string ARGS. The pid of the new process is stored in +PID. This function is deprecated. Please use the Win32::Process module +instead. + +=item Win32::UnregisterServer(LIBRARYNAME) + +Loads the DLL LIBRARYNAME and calls the function +DllUnregisterServer. + +=back + +=cut diff --git a/cpan/Win32/Win32.xs b/cpan/Win32/Win32.xs index ae2bad2..1ccdcc3 100644 --- a/cpan/Win32/Win32.xs +++ b/cpan/Win32/Win32.xs @@ -1,1719 +1,1719 @@ -#include -#include -#include - -#define PERL_NO_GET_CONTEXT -#include "EXTERN.h" -#include "perl.h" -#include "XSUB.h" - -#ifndef countof -# define countof(array) (sizeof (array) / sizeof (*(array))) -#endif - -#define SE_SHUTDOWN_NAMEA "SeShutdownPrivilege" - -#ifndef WC_NO_BEST_FIT_CHARS -# define WC_NO_BEST_FIT_CHARS 0x00000400 -#endif - -#define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn) - -typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathA)(HWND, char*, int, BOOL); -typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathW)(HWND, WCHAR*, int, BOOL); -typedef HRESULT (WINAPI *PFNSHGetFolderPathA)(HWND, int, HANDLE, DWORD, LPTSTR); -typedef HRESULT (WINAPI *PFNSHGetFolderPathW)(HWND, int, HANDLE, DWORD, LPWSTR); -typedef BOOL (WINAPI *PFNCreateEnvironmentBlock)(void**, HANDLE, BOOL); -typedef BOOL (WINAPI *PFNDestroyEnvironmentBlock)(void*); -typedef int (__stdcall *PFNDllRegisterServer)(void); -typedef int (__stdcall *PFNDllUnregisterServer)(void); -typedef DWORD (__stdcall *PFNNetApiBufferFree)(void*); -typedef DWORD (__stdcall *PFNNetWkstaGetInfo)(LPWSTR, DWORD, void*); - -typedef BOOL (__stdcall *PFNOpenProcessToken)(HANDLE, DWORD, HANDLE*); -typedef BOOL (__stdcall *PFNOpenThreadToken)(HANDLE, DWORD, BOOL, HANDLE*); -typedef BOOL (__stdcall *PFNGetTokenInformation)(HANDLE, TOKEN_INFORMATION_CLASS, void*, DWORD, DWORD*); -typedef BOOL (__stdcall *PFNAllocateAndInitializeSid)(PSID_IDENTIFIER_AUTHORITY, BYTE, DWORD, DWORD, - DWORD, DWORD, DWORD, DWORD, DWORD, DWORD, PSID*); -typedef BOOL (__stdcall *PFNEqualSid)(PSID, PSID); -typedef void* (__stdcall *PFNFreeSid)(PSID); -typedef BOOL (__stdcall *PFNIsUserAnAdmin)(void); - -#ifndef CSIDL_MYMUSIC -# define CSIDL_MYMUSIC 0x000D -#endif -#ifndef CSIDL_MYVIDEO -# define CSIDL_MYVIDEO 0x000E -#endif -#ifndef CSIDL_LOCAL_APPDATA -# define CSIDL_LOCAL_APPDATA 0x001C -#endif -#ifndef CSIDL_COMMON_FAVORITES -# define CSIDL_COMMON_FAVORITES 0x001F -#endif -#ifndef CSIDL_INTERNET_CACHE -# define CSIDL_INTERNET_CACHE 0x0020 -#endif -#ifndef CSIDL_COOKIES -# define CSIDL_COOKIES 0x0021 -#endif -#ifndef CSIDL_HISTORY -# define CSIDL_HISTORY 0x0022 -#endif -#ifndef CSIDL_COMMON_APPDATA -# define CSIDL_COMMON_APPDATA 0x0023 -#endif -#ifndef CSIDL_WINDOWS -# define CSIDL_WINDOWS 0x0024 -#endif -#ifndef CSIDL_PROGRAM_FILES -# define CSIDL_PROGRAM_FILES 0x0026 -#endif -#ifndef CSIDL_MYPICTURES -# define CSIDL_MYPICTURES 0x0027 -#endif -#ifndef CSIDL_PROFILE -# define CSIDL_PROFILE 0x0028 -#endif -#ifndef CSIDL_PROGRAM_FILES_COMMON -# define CSIDL_PROGRAM_FILES_COMMON 0x002B -#endif -#ifndef CSIDL_COMMON_TEMPLATES -# define CSIDL_COMMON_TEMPLATES 0x002D -#endif -#ifndef CSIDL_COMMON_DOCUMENTS -# define CSIDL_COMMON_DOCUMENTS 0x002E -#endif -#ifndef CSIDL_COMMON_ADMINTOOLS -# define CSIDL_COMMON_ADMINTOOLS 0x002F -#endif -#ifndef CSIDL_ADMINTOOLS -# define CSIDL_ADMINTOOLS 0x0030 -#endif -#ifndef CSIDL_COMMON_MUSIC -# define CSIDL_COMMON_MUSIC 0x0035 -#endif -#ifndef CSIDL_COMMON_PICTURES -# define CSIDL_COMMON_PICTURES 0x0036 -#endif -#ifndef CSIDL_COMMON_VIDEO -# define CSIDL_COMMON_VIDEO 0x0037 -#endif -#ifndef CSIDL_CDBURN_AREA -# define CSIDL_CDBURN_AREA 0x003B -#endif -#ifndef CSIDL_FLAG_CREATE -# define CSIDL_FLAG_CREATE 0x8000 -#endif - -/* Use explicit struct definition because wSuiteMask and - * wProductType are not defined in the VC++ 6.0 headers. - * WORD type has been replaced by unsigned short because - * WORD is already used by Perl itself. - */ -struct { - DWORD dwOSVersionInfoSize; - DWORD dwMajorVersion; - DWORD dwMinorVersion; - DWORD dwBuildNumber; - DWORD dwPlatformId; - CHAR szCSDVersion[128]; - unsigned short wServicePackMajor; - unsigned short wServicePackMinor; - unsigned short wSuiteMask; - BYTE wProductType; - BYTE wReserved; -} g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0}; -BOOL g_osver_ex = TRUE; - -#define ONE_K_BUFSIZE 1024 - -int -IsWin95(void) -{ - return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS); -} - -int -IsWinNT(void) -{ - return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT); -} - -int -IsWin2000(void) -{ - return (g_osver.dwMajorVersion > 4); -} - -/* Convert SV to wide character string. The return value must be - * freed using Safefree(). - */ -WCHAR* -sv_to_wstr(pTHX_ SV *sv) -{ - DWORD wlen; - WCHAR *wstr; - STRLEN len; - char *str = SvPV(sv, len); - UINT cp = SvUTF8(sv) ? CP_UTF8 : CP_ACP; - - wlen = MultiByteToWideChar(cp, 0, str, (int)(len+1), NULL, 0); - New(0, wstr, wlen, WCHAR); - MultiByteToWideChar(cp, 0, str, (int)(len+1), wstr, wlen); - - return wstr; -} - -/* Convert wide character string to mortal SV. Use UTF8 encoding - * if the string cannot be represented in the system codepage. - */ -SV * -wstr_to_sv(pTHX_ WCHAR *wstr) -{ - int wlen = (int)wcslen(wstr)+1; - BOOL use_default = FALSE; - int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, NULL, 0, NULL, NULL); - SV *sv = sv_2mortal(newSV(len)); - - len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, SvPVX(sv), len, NULL, &use_default); - if (use_default) { - len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, NULL, 0, NULL, NULL); - sv_grow(sv, len); - len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, SvPVX(sv), len, NULL, NULL); - SvUTF8_on(sv); - } - /* Shouldn't really ever fail since we ask for the required length first, but who knows... */ - if (len) { - SvPOK_on(sv); - SvCUR_set(sv, len-1); - } - return sv; -} - -/* Retrieve a variable from the Unicode environment in a mortal SV. - * - * Recreates the Unicode environment because a bug in earlier Perl versions - * overwrites it with the ANSI version, which contains replacement - * characters for the characters not in the ANSI codepage. - */ -SV* -get_unicode_env(pTHX_ WCHAR *name) -{ - SV *sv = NULL; - void *env; - HANDLE token; - HMODULE module; - PFNOpenProcessToken pfnOpenProcessToken; - - /* Get security token for the current process owner */ - module = LoadLibrary("advapi32.dll"); - if (!module) - return NULL; - - GETPROC(OpenProcessToken); - - if (pfnOpenProcessToken == NULL || - !pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY | TOKEN_DUPLICATE, &token)) - { - FreeLibrary(module); - return NULL; - } - FreeLibrary(module); - - /* Create a Unicode environment block for this process */ - module = LoadLibrary("userenv.dll"); - if (module) { - PFNCreateEnvironmentBlock pfnCreateEnvironmentBlock; - PFNDestroyEnvironmentBlock pfnDestroyEnvironmentBlock; - - GETPROC(CreateEnvironmentBlock); - GETPROC(DestroyEnvironmentBlock); - - if (pfnCreateEnvironmentBlock && pfnDestroyEnvironmentBlock && - pfnCreateEnvironmentBlock(&env, token, FALSE)) - { - size_t name_len = wcslen(name); - WCHAR *entry = env; - while (*entry) { - size_t i; - size_t entry_len = wcslen(entry); - BOOL equal = (entry_len > name_len) && (entry[name_len] == '='); - - for (i=0; equal && i < name_len; ++i) - equal = (towupper(entry[i]) == towupper(name[i])); - - if (equal) { - sv = wstr_to_sv(aTHX_ entry+name_len+1); - break; - } - entry += entry_len+1; - } - pfnDestroyEnvironmentBlock(env); - } - FreeLibrary(module); - } - CloseHandle(token); - return sv; -} - -/* Define both an ANSI and a Wide version of win32_longpath */ - -#define CHAR_T char -#define WIN32_FIND_DATA_T WIN32_FIND_DATAA -#define FN_FINDFIRSTFILE FindFirstFileA -#define FN_STRLEN strlen -#define FN_STRCPY strcpy -#define LONGPATH my_longpathA -#include "longpath.inc" - -#define CHAR_T WCHAR -#define WIN32_FIND_DATA_T WIN32_FIND_DATAW -#define FN_FINDFIRSTFILE FindFirstFileW -#define FN_STRLEN wcslen -#define FN_STRCPY wcscpy -#define LONGPATH my_longpathW -#include "longpath.inc" - -/* The my_ansipath() function takes a Unicode filename and converts it - * into the current Windows codepage. If some characters cannot be mapped, - * then it will convert the short name instead. - * - * The buffer to the ansi pathname must be freed with Safefree() when it - * it no longer needed. - * - * The argument to my_ansipath() must exist before this function is - * called; otherwise there is no way to determine the short path name. - * - * Ideas for future refinement: - * - Only convert those segments of the path that are not in the current - * codepage, but leave the other segments in their long form. - * - If the resulting name is longer than MAX_PATH, start converting - * additional path segments into short names until the full name - * is shorter than MAX_PATH. Shorten the filename part last! - */ - -/* This is a modified version of core Perl win32/win32.c(win32_ansipath). - * It uses New() etc. instead of win32_malloc(). - */ - -char * -my_ansipath(const WCHAR *widename) -{ - char *name; - BOOL use_default = FALSE; - int widelen = (int)wcslen(widename)+1; - int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, - NULL, 0, NULL, NULL); - New(0, name, len, char); - WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, - name, len, NULL, &use_default); - if (use_default) { - DWORD shortlen = GetShortPathNameW(widename, NULL, 0); - if (shortlen) { - WCHAR *shortname; - New(0, shortname, shortlen, WCHAR); - shortlen = GetShortPathNameW(widename, shortname, shortlen)+1; - - len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, - NULL, 0, NULL, NULL); - Renew(name, len, char); - WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, - name, len, NULL, NULL); - Safefree(shortname); - } - } - return name; -} - -/* Convert wide character path to ANSI path and return as mortal SV. */ -SV* -wstr_to_ansipath(pTHX_ WCHAR *wstr) -{ - char *ansi = my_ansipath(wstr); - SV *sv = sv_2mortal(newSVpvn(ansi, strlen(ansi))); - Safefree(ansi); - return sv; -} - -#ifdef __CYGWIN__ - -char* -get_childdir(void) -{ - dTHX; - char* ptr; - - if (IsWin2000()) { - WCHAR filename[MAX_PATH+1]; - GetCurrentDirectoryW(MAX_PATH+1, filename); - ptr = my_ansipath(filename); - } - else { - char filename[MAX_PATH+1]; - GetCurrentDirectoryA(MAX_PATH+1, filename); - New(0, ptr, strlen(filename)+1, char); - strcpy(ptr, filename); - } - return ptr; -} - -void -free_childdir(char *d) -{ - dTHX; - Safefree(d); -} - -void* -get_childenv(void) -{ - return NULL; -} - -void -free_childenv(void *d) -{ -} - -# define PerlDir_mapA(dir) (dir) - -#endif - -XS(w32_ExpandEnvironmentStrings) -{ - dXSARGS; - - if (items != 1) - croak("usage: Win32::ExpandEnvironmentStrings($String);\n"); - - if (IsWin2000()) { - WCHAR value[31*1024]; - WCHAR *source = sv_to_wstr(aTHX_ ST(0)); - ExpandEnvironmentStringsW(source, value, countof(value)-1); - ST(0) = wstr_to_sv(aTHX_ value); - Safefree(source); - XSRETURN(1); - } - else { - char value[31*1024]; - ExpandEnvironmentStringsA(SvPV_nolen(ST(0)), value, countof(value)-2); - XSRETURN_PV(value); - } -} - -XS(w32_IsAdminUser) -{ - dXSARGS; - HMODULE module; - PFNIsUserAnAdmin pfnIsUserAnAdmin; - PFNOpenThreadToken pfnOpenThreadToken; - PFNOpenProcessToken pfnOpenProcessToken; - PFNGetTokenInformation pfnGetTokenInformation; - PFNAllocateAndInitializeSid pfnAllocateAndInitializeSid; - PFNEqualSid pfnEqualSid; - PFNFreeSid pfnFreeSid; - HANDLE hTok; - DWORD dwTokInfoLen; - TOKEN_GROUPS *lpTokInfo; - SID_IDENTIFIER_AUTHORITY NtAuth = SECURITY_NT_AUTHORITY; - PSID pAdminSid; - int iRetVal; - unsigned int i; - - if (items) - croak("usage: Win32::IsAdminUser()"); - - /* There is no concept of "Administrator" user accounts on Win9x systems, - so just return true. */ - if (IsWin95()) - XSRETURN_YES; - - /* Use IsUserAnAdmin() when available. On Vista this will only return TRUE - * if the process is running with elevated privileges and not just when the - * process owner is a member of the "Administrators" group. - */ - module = LoadLibrary("shell32.dll"); - if (module) { - GETPROC(IsUserAnAdmin); - if (pfnIsUserAnAdmin) { - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSViv(pfnIsUserAnAdmin() ? 1 : 0)); - FreeLibrary(module); - XSRETURN(1); - } - FreeLibrary(module); - } - - module = LoadLibrary("advapi32.dll"); - if (!module) { - warn("Cannot load advapi32.dll library"); - XSRETURN_UNDEF; - } - - GETPROC(OpenThreadToken); - GETPROC(OpenProcessToken); - GETPROC(GetTokenInformation); - GETPROC(AllocateAndInitializeSid); - GETPROC(EqualSid); - GETPROC(FreeSid); - - if (!(pfnOpenThreadToken && pfnOpenProcessToken && - pfnGetTokenInformation && pfnAllocateAndInitializeSid && - pfnEqualSid && pfnFreeSid)) - { - warn("Cannot load functions from advapi32.dll library"); - FreeLibrary(module); - XSRETURN_UNDEF; - } - - if (!pfnOpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) { - if (!pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) { - warn("Cannot open thread token or process token"); - FreeLibrary(module); - XSRETURN_UNDEF; - } - } - - pfnGetTokenInformation(hTok, TokenGroups, NULL, 0, &dwTokInfoLen); - if (!New(1, lpTokInfo, dwTokInfoLen, TOKEN_GROUPS)) { - warn("Cannot allocate token information structure"); - CloseHandle(hTok); - FreeLibrary(module); - XSRETURN_UNDEF; - } - - if (!pfnGetTokenInformation(hTok, TokenGroups, lpTokInfo, dwTokInfoLen, - &dwTokInfoLen)) - { - warn("Cannot get token information"); - Safefree(lpTokInfo); - CloseHandle(hTok); - FreeLibrary(module); - XSRETURN_UNDEF; - } - - if (!pfnAllocateAndInitializeSid(&NtAuth, 2, SECURITY_BUILTIN_DOMAIN_RID, - DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid)) - { - warn("Cannot allocate administrators' SID"); - Safefree(lpTokInfo); - CloseHandle(hTok); - FreeLibrary(module); - XSRETURN_UNDEF; - } - - iRetVal = 0; - for (i = 0; i < lpTokInfo->GroupCount; ++i) { - if (pfnEqualSid(lpTokInfo->Groups[i].Sid, pAdminSid)) { - iRetVal = 1; - break; - } - } - - pfnFreeSid(pAdminSid); - Safefree(lpTokInfo); - CloseHandle(hTok); - FreeLibrary(module); - - EXTEND(SP, 1); - ST(0) = sv_2mortal(newSViv(iRetVal)); - XSRETURN(1); -} - -XS(w32_LookupAccountName) -{ - dXSARGS; - char SID[400]; - DWORD SIDLen; - SID_NAME_USE snu; - char Domain[256]; - DWORD DomLen; - BOOL bResult; - - if (items != 5) - croak("usage: Win32::LookupAccountName($system, $account, $domain, " - "$sid, $sidtype);\n"); - - SIDLen = sizeof(SID); - DomLen = sizeof(Domain); - - bResult = LookupAccountNameA(SvPV_nolen(ST(0)), /* System */ - SvPV_nolen(ST(1)), /* Account name */ - &SID, /* SID structure */ - &SIDLen, /* Size of SID buffer */ - Domain, /* Domain buffer */ - &DomLen, /* Domain buffer size */ - &snu); /* SID name type */ - if (bResult) { - sv_setpv(ST(2), Domain); - sv_setpvn(ST(3), SID, SIDLen); - sv_setiv(ST(4), snu); - XSRETURN_YES; - } - XSRETURN_NO; -} - - -XS(w32_LookupAccountSID) -{ - dXSARGS; - PSID sid; - char Account[256]; - DWORD AcctLen = sizeof(Account); - char Domain[256]; - DWORD DomLen = sizeof(Domain); - SID_NAME_USE snu; - BOOL bResult; - - if (items != 5) - croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype);\n"); - - sid = SvPV_nolen(ST(1)); - if (IsValidSid(sid)) { - bResult = LookupAccountSidA(SvPV_nolen(ST(0)), /* System */ - sid, /* SID structure */ - Account, /* Account name buffer */ - &AcctLen, /* name buffer length */ - Domain, /* Domain buffer */ - &DomLen, /* Domain buffer length */ - &snu); /* SID name type */ - if (bResult) { - sv_setpv(ST(2), Account); - sv_setpv(ST(3), Domain); - sv_setiv(ST(4), (IV)snu); - XSRETURN_YES; - } - } - XSRETURN_NO; -} - -XS(w32_InitiateSystemShutdown) -{ - dXSARGS; - HANDLE hToken; /* handle to process token */ - TOKEN_PRIVILEGES tkp; /* pointer to token structure */ - BOOL bRet; - char *machineName, *message; - - if (items != 5) - croak("usage: Win32::InitiateSystemShutdown($machineName, $message, " - "$timeOut, $forceClose, $reboot);\n"); - - machineName = SvPV_nolen(ST(0)); - - if (OpenProcessToken(GetCurrentProcess(), - TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY, - &hToken)) - { - LookupPrivilegeValueA(machineName, - SE_SHUTDOWN_NAMEA, - &tkp.Privileges[0].Luid); - - tkp.PrivilegeCount = 1; /* only setting one */ - tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED; - - /* Get shutdown privilege for this process. */ - AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, - (PTOKEN_PRIVILEGES)NULL, 0); - } - - message = SvPV_nolen(ST(1)); - bRet = InitiateSystemShutdownA(machineName, message, (DWORD)SvIV(ST(2)), - (BOOL)SvIV(ST(3)), (BOOL)SvIV(ST(4))); - - /* Disable shutdown privilege. */ - tkp.Privileges[0].Attributes = 0; - AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, - (PTOKEN_PRIVILEGES)NULL, 0); - CloseHandle(hToken); - XSRETURN_IV(bRet); -} - -XS(w32_AbortSystemShutdown) -{ - dXSARGS; - HANDLE hToken; /* handle to process token */ - TOKEN_PRIVILEGES tkp; /* pointer to token structure */ - BOOL bRet; - char *machineName; - - if (items != 1) - croak("usage: Win32::AbortSystemShutdown($machineName);\n"); - - machineName = SvPV_nolen(ST(0)); - - if (OpenProcessToken(GetCurrentProcess(), - TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY, - &hToken)) - { - LookupPrivilegeValueA(machineName, - SE_SHUTDOWN_NAMEA, - &tkp.Privileges[0].Luid); - - tkp.PrivilegeCount = 1; /* only setting one */ - tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED; - - /* Get shutdown privilege for this process. */ - AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, - (PTOKEN_PRIVILEGES)NULL, 0); - } - - bRet = AbortSystemShutdownA(machineName); - - /* Disable shutdown privilege. */ - tkp.Privileges[0].Attributes = 0; - AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, - (PTOKEN_PRIVILEGES)NULL, 0); - CloseHandle(hToken); - XSRETURN_IV(bRet); -} - - -XS(w32_MsgBox) -{ - dXSARGS; - DWORD flags = MB_ICONEXCLAMATION; - I32 result; - - if (items < 1 || items > 3) - croak("usage: Win32::MsgBox($message [, $flags [, $title]]);\n"); - - if (items > 1) - flags = (DWORD)SvIV(ST(1)); - - if (IsWin2000()) { - WCHAR *title = NULL; - WCHAR *msg = sv_to_wstr(aTHX_ ST(0)); - if (items > 2) - title = sv_to_wstr(aTHX_ ST(2)); - result = MessageBoxW(GetActiveWindow(), msg, title ? title : L"Perl", flags); - Safefree(msg); - if (title) - Safefree(title); - } - else { - char *title = "Perl"; - char *msg = SvPV_nolen(ST(0)); - if (items > 2) - title = SvPV_nolen(ST(2)); - result = MessageBoxA(GetActiveWindow(), msg, title, flags); - } - XSRETURN_IV(result); -} - -XS(w32_LoadLibrary) -{ - dXSARGS; - HANDLE hHandle; - - if (items != 1) - croak("usage: Win32::LoadLibrary($libname)\n"); - hHandle = LoadLibraryA(SvPV_nolen(ST(0))); -#ifdef _WIN64 - XSRETURN_IV((DWORD_PTR)hHandle); -#else - XSRETURN_IV((DWORD)hHandle); -#endif -} - -XS(w32_FreeLibrary) -{ - dXSARGS; - - if (items != 1) - croak("usage: Win32::FreeLibrary($handle)\n"); - if (FreeLibrary(INT2PTR(HINSTANCE, SvIV(ST(0))))) { - XSRETURN_YES; - } - XSRETURN_NO; -} - -XS(w32_GetProcAddress) -{ - dXSARGS; - - if (items != 2) - croak("usage: Win32::GetProcAddress($hinstance, $procname)\n"); - XSRETURN_IV(PTR2IV(GetProcAddress(INT2PTR(HINSTANCE, SvIV(ST(0))), SvPV_nolen(ST(1))))); -} - -XS(w32_RegisterServer) -{ - dXSARGS; - BOOL result = FALSE; - HMODULE module; - - if (items != 1) - croak("usage: Win32::RegisterServer($libname)\n"); - - module = LoadLibraryA(SvPV_nolen(ST(0))); - if (module) { - PFNDllRegisterServer pfnDllRegisterServer; - GETPROC(DllRegisterServer); - if (pfnDllRegisterServer && pfnDllRegisterServer() == 0) - result = TRUE; - FreeLibrary(module); - } - ST(0) = boolSV(result); - XSRETURN(1); -} - -XS(w32_UnregisterServer) -{ - dXSARGS; - BOOL result = FALSE; - HINSTANCE module; - - if (items != 1) - croak("usage: Win32::UnregisterServer($libname)\n"); - - module = LoadLibraryA(SvPV_nolen(ST(0))); - if (module) { - PFNDllUnregisterServer pfnDllUnregisterServer; - GETPROC(DllUnregisterServer); - if (pfnDllUnregisterServer && pfnDllUnregisterServer() == 0) - result = TRUE; - FreeLibrary(module); - } - ST(0) = boolSV(result); - XSRETURN(1); -} - -/* XXX rather bogus */ -XS(w32_GetArchName) -{ - dXSARGS; - XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE")); -} - -XS(w32_GetChipName) -{ - dXSARGS; - SYSTEM_INFO sysinfo; - - Zero(&sysinfo,1,SYSTEM_INFO); - GetSystemInfo(&sysinfo); - /* XXX docs say dwProcessorType is deprecated on NT */ - XSRETURN_IV(sysinfo.dwProcessorType); -} - -XS(w32_GuidGen) -{ - dXSARGS; - GUID guid; - char szGUID[50] = {'\0'}; - HRESULT hr = CoCreateGuid(&guid); - - if (SUCCEEDED(hr)) { - LPOLESTR pStr = NULL; - if (SUCCEEDED(StringFromCLSID(&guid, &pStr))) { - WideCharToMultiByte(CP_ACP, 0, pStr, (int)wcslen(pStr), szGUID, - sizeof(szGUID), NULL, NULL); - CoTaskMemFree(pStr); - XSRETURN_PV(szGUID); - } - } - XSRETURN_UNDEF; -} - -XS(w32_GetFolderPath) -{ - dXSARGS; - char path[MAX_PATH+1]; - WCHAR wpath[MAX_PATH+1]; - int folder; - int create = 0; - HMODULE module; - - if (items != 1 && items != 2) - croak("usage: Win32::GetFolderPath($csidl [, $create])\n"); - - folder = (int)SvIV(ST(0)); - if (items == 2) - create = SvTRUE(ST(1)) ? CSIDL_FLAG_CREATE : 0; - - module = LoadLibrary("shfolder.dll"); - if (module) { - PFNSHGetFolderPathA pfna; - if (IsWin2000()) { - PFNSHGetFolderPathW pfnw; - pfnw = (PFNSHGetFolderPathW)GetProcAddress(module, "SHGetFolderPathW"); - if (pfnw && SUCCEEDED(pfnw(NULL, folder|create, NULL, 0, wpath))) { - FreeLibrary(module); - ST(0) = wstr_to_ansipath(aTHX_ wpath); - XSRETURN(1); - } - } - pfna = (PFNSHGetFolderPathA)GetProcAddress(module, "SHGetFolderPathA"); - if (pfna && SUCCEEDED(pfna(NULL, folder|create, NULL, 0, path))) { - FreeLibrary(module); - XSRETURN_PV(path); - } - FreeLibrary(module); - } - - module = LoadLibrary("shell32.dll"); - if (module) { - PFNSHGetSpecialFolderPathA pfna; - if (IsWin2000()) { - PFNSHGetSpecialFolderPathW pfnw; - pfnw = (PFNSHGetSpecialFolderPathW)GetProcAddress(module, "SHGetSpecialFolderPathW"); - if (pfnw && pfnw(NULL, wpath, folder, !!create)) { - FreeLibrary(module); - ST(0) = wstr_to_ansipath(aTHX_ wpath); - XSRETURN(1); - } - } - pfna = (PFNSHGetSpecialFolderPathA)GetProcAddress(module, "SHGetSpecialFolderPathA"); - if (pfna && pfna(NULL, path, folder, !!create)) { - FreeLibrary(module); - XSRETURN_PV(path); - } - FreeLibrary(module); - } - - /* SHGetFolderPathW() and SHGetSpecialFolderPathW() may fail on older - * Perl versions that have replaced the Unicode environment with an - * ANSI version. Let's go spelunking in the registry now... - */ - if (IsWin2000()) { - SV *sv; - HKEY hkey; - HKEY root = HKEY_CURRENT_USER; - WCHAR *name = NULL; - - switch (folder) { - case CSIDL_ADMINTOOLS: name = L"Administrative Tools"; break; - case CSIDL_APPDATA: name = L"AppData"; break; - case CSIDL_CDBURN_AREA: name = L"CD Burning"; break; - case CSIDL_COOKIES: name = L"Cookies"; break; - case CSIDL_DESKTOP: - case CSIDL_DESKTOPDIRECTORY: name = L"Desktop"; break; - case CSIDL_FAVORITES: name = L"Favorites"; break; - case CSIDL_FONTS: name = L"Fonts"; break; - case CSIDL_HISTORY: name = L"History"; break; - case CSIDL_INTERNET_CACHE: name = L"Cache"; break; - case CSIDL_LOCAL_APPDATA: name = L"Local AppData"; break; - case CSIDL_MYMUSIC: name = L"My Music"; break; - case CSIDL_MYPICTURES: name = L"My Pictures"; break; - case CSIDL_MYVIDEO: name = L"My Video"; break; - case CSIDL_NETHOOD: name = L"NetHood"; break; - case CSIDL_PERSONAL: name = L"Personal"; break; - case CSIDL_PRINTHOOD: name = L"PrintHood"; break; - case CSIDL_PROGRAMS: name = L"Programs"; break; - case CSIDL_RECENT: name = L"Recent"; break; - case CSIDL_SENDTO: name = L"SendTo"; break; - case CSIDL_STARTMENU: name = L"Start Menu"; break; - case CSIDL_STARTUP: name = L"Startup"; break; - case CSIDL_TEMPLATES: name = L"Templates"; break; - /* XXX L"Local Settings" */ - } - - if (!name) { - root = HKEY_LOCAL_MACHINE; - switch (folder) { - case CSIDL_COMMON_ADMINTOOLS: name = L"Common Administrative Tools"; break; - case CSIDL_COMMON_APPDATA: name = L"Common AppData"; break; - case CSIDL_COMMON_DESKTOPDIRECTORY: name = L"Common Desktop"; break; - case CSIDL_COMMON_DOCUMENTS: name = L"Common Documents"; break; - case CSIDL_COMMON_FAVORITES: name = L"Common Favorites"; break; - case CSIDL_COMMON_PROGRAMS: name = L"Common Programs"; break; - case CSIDL_COMMON_STARTMENU: name = L"Common Start Menu"; break; - case CSIDL_COMMON_STARTUP: name = L"Common Startup"; break; - case CSIDL_COMMON_TEMPLATES: name = L"Common Templates"; break; - case CSIDL_COMMON_MUSIC: name = L"CommonMusic"; break; - case CSIDL_COMMON_PICTURES: name = L"CommonPictures"; break; - case CSIDL_COMMON_VIDEO: name = L"CommonVideo"; break; - } - } - /* XXX todo - * case CSIDL_SYSTEM # GetSystemDirectory() - * case CSIDL_RESOURCES # %windir%\Resources\, For theme and other windows resources. - * case CSIDL_RESOURCES_LOCALIZED # %windir%\Resources\, for theme and other windows specific resources. - */ - -#define SHELL_FOLDERS "Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders" - - if (name && RegOpenKeyEx(root, SHELL_FOLDERS, 0, KEY_QUERY_VALUE, &hkey) == ERROR_SUCCESS) { - WCHAR data[MAX_PATH+1]; - DWORD cb = sizeof(data)-sizeof(WCHAR); - DWORD type = REG_NONE; - long rc = RegQueryValueExW(hkey, name, NULL, &type, (BYTE*)&data, &cb); - RegCloseKey(hkey); - if (rc == ERROR_SUCCESS && type == REG_SZ && cb > sizeof(WCHAR) && data[0]) { - /* Make sure the string is properly terminated */ - data[cb/sizeof(WCHAR)] = '\0'; - ST(0) = wstr_to_ansipath(aTHX_ data); - XSRETURN(1); - } - } - -#undef SHELL_FOLDERS - - /* Unders some circumstances the registry entries seem to have a null string - * as their value even when the directory already exists. The environment - * variables do get set though, so try re-create a Unicode environment and - * check if they are there. - */ - sv = NULL; - switch (folder) { - case CSIDL_APPDATA: sv = get_unicode_env(aTHX_ L"APPDATA"); break; - case CSIDL_PROFILE: sv = get_unicode_env(aTHX_ L"USERPROFILE"); break; - case CSIDL_PROGRAM_FILES: sv = get_unicode_env(aTHX_ L"ProgramFiles"); break; - case CSIDL_PROGRAM_FILES_COMMON: sv = get_unicode_env(aTHX_ L"CommonProgramFiles"); break; - case CSIDL_WINDOWS: sv = get_unicode_env(aTHX_ L"SystemRoot"); break; - } - if (sv) { - ST(0) = sv; - XSRETURN(1); - } - } - - XSRETURN_UNDEF; -} - -XS(w32_GetFileVersion) -{ - dXSARGS; - DWORD size; - DWORD handle; - char *filename; - char *data; - - if (items != 1) - croak("usage: Win32::GetFileVersion($filename)\n"); - - filename = SvPV_nolen(ST(0)); - size = GetFileVersionInfoSize(filename, &handle); - if (!size) - XSRETURN_UNDEF; - - New(0, data, size, char); - if (!data) - XSRETURN_UNDEF; - - if (GetFileVersionInfo(filename, handle, size, data)) { - VS_FIXEDFILEINFO *info; - UINT len; - if (VerQueryValue(data, "\\", (void**)&info, &len)) { - int dwValueMS1 = (info->dwFileVersionMS>>16); - int dwValueMS2 = (info->dwFileVersionMS&0xffff); - int dwValueLS1 = (info->dwFileVersionLS>>16); - int dwValueLS2 = (info->dwFileVersionLS&0xffff); - - if (GIMME_V == G_ARRAY) { - EXTEND(SP, 4); - XST_mIV(0, dwValueMS1); - XST_mIV(1, dwValueMS2); - XST_mIV(2, dwValueLS1); - XST_mIV(3, dwValueLS2); - items = 4; - } - else { - char version[50]; - sprintf(version, "%d.%d.%d.%d", dwValueMS1, dwValueMS2, dwValueLS1, dwValueLS2); - XST_mPV(0, version); - } - } - } - else - items = 0; - - Safefree(data); - XSRETURN(items); -} - -#ifdef __CYGWIN__ -XS(w32_SetChildShowWindow) -{ - /* This function doesn't do anything useful for cygwin. In the - * MSWin32 case it modifies w32_showwindow, which is used by - * win32_spawnvp(). Since w32_showwindow is an internal variable - * inside the thread_intern structure, the MSWin32 implementation - * lives in win32/win32.c in the core Perl distribution. - */ - dXSARGS; - XSRETURN_UNDEF; -} -#endif - -XS(w32_GetCwd) -{ - dXSARGS; - /* Make the host for current directory */ - char* ptr = PerlEnv_get_childdir(); - /* - * If ptr != Nullch - * then it worked, set PV valid, - * else return 'undef' - */ - if (ptr) { - SV *sv = sv_newmortal(); - sv_setpv(sv, ptr); - PerlEnv_free_childdir(ptr); - -#ifndef INCOMPLETE_TAINTS - SvTAINTED_on(sv); -#endif - - EXTEND(SP,1); - ST(0) = sv; - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -XS(w32_SetCwd) -{ - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)"); - - if (IsWin2000() && SvUTF8(ST(0))) { - WCHAR *wide = sv_to_wstr(aTHX_ ST(0)); - char *ansi = my_ansipath(wide); - int rc = PerlDir_chdir(ansi); - Safefree(wide); - Safefree(ansi); - if (!rc) - XSRETURN_YES; - } - else { - if (!PerlDir_chdir(SvPV_nolen(ST(0)))) - XSRETURN_YES; - } - - XSRETURN_NO; -} - -XS(w32_GetNextAvailDrive) -{ - dXSARGS; - char ix = 'C'; - char root[] = "_:\\"; - - EXTEND(SP,1); - while (ix <= 'Z') { - root[0] = ix++; - if (GetDriveType(root) == 1) { - root[2] = '\0'; - XSRETURN_PV(root); - } - } - XSRETURN_UNDEF; -} - -XS(w32_GetLastError) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(GetLastError()); -} - -XS(w32_SetLastError) -{ - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::SetLastError($error)"); - SetLastError((DWORD)SvIV(ST(0))); - XSRETURN_EMPTY; -} - -XS(w32_LoginName) -{ - dXSARGS; - EXTEND(SP,1); - if (IsWin2000()) { - WCHAR name[128]; - DWORD size = countof(name); - if (GetUserNameW(name, &size)) { - ST(0) = wstr_to_sv(aTHX_ name); - XSRETURN(1); - } - } - else { - char name[128]; - DWORD size = countof(name); - if (GetUserNameA(name, &size)) { - /* size includes NULL */ - ST(0) = sv_2mortal(newSVpvn(name, size-1)); - XSRETURN(1); - } - } - XSRETURN_UNDEF; -} - -XS(w32_NodeName) -{ - dXSARGS; - char name[MAX_COMPUTERNAME_LENGTH+1]; - DWORD size = sizeof(name); - EXTEND(SP,1); - if (GetComputerName(name,&size)) { - /* size does NOT include NULL :-( */ - ST(0) = sv_2mortal(newSVpvn(name,size)); - XSRETURN(1); - } - XSRETURN_UNDEF; -} - - -XS(w32_DomainName) -{ - dXSARGS; - HMODULE module = LoadLibrary("netapi32.dll"); - PFNNetApiBufferFree pfnNetApiBufferFree; - PFNNetWkstaGetInfo pfnNetWkstaGetInfo; - - if (module) { - GETPROC(NetApiBufferFree); - GETPROC(NetWkstaGetInfo); - } - EXTEND(SP,1); - if (module && pfnNetWkstaGetInfo && pfnNetApiBufferFree) { - /* this way is more reliable, in case user has a local account. */ - char dname[256]; - DWORD dnamelen = sizeof(dname); - struct { - DWORD wki100_platform_id; - LPWSTR wki100_computername; - LPWSTR wki100_langroup; - DWORD wki100_ver_major; - DWORD wki100_ver_minor; - } *pwi; - DWORD retval; - retval = pfnNetWkstaGetInfo(NULL, 100, &pwi); - /* NERR_Success *is* 0*/ - if (retval == 0) { - if (pwi->wki100_langroup && *(pwi->wki100_langroup)) { - WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup, - -1, (LPSTR)dname, dnamelen, NULL, NULL); - } - else { - WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername, - -1, (LPSTR)dname, dnamelen, NULL, NULL); - } - pfnNetApiBufferFree(pwi); - FreeLibrary(module); - XSRETURN_PV(dname); - } - FreeLibrary(module); - SetLastError(retval); - } - else { - /* Win95 doesn't have NetWksta*(), so do it the old way */ - char name[256]; - DWORD size = sizeof(name); - if (module) - FreeLibrary(module); - if (GetUserName(name,&size)) { - char sid[ONE_K_BUFSIZE]; - DWORD sidlen = sizeof(sid); - char dname[256]; - DWORD dnamelen = sizeof(dname); - SID_NAME_USE snu; - if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen, - dname, &dnamelen, &snu)) { - XSRETURN_PV(dname); /* all that for this */ - } - } - } - XSRETURN_UNDEF; -} - -XS(w32_FsType) -{ - dXSARGS; - char fsname[256]; - DWORD flags, filecomplen; - if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, - &flags, fsname, sizeof(fsname))) { - if (GIMME_V == G_ARRAY) { - XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname)))); - XPUSHs(sv_2mortal(newSViv(flags))); - XPUSHs(sv_2mortal(newSViv(filecomplen))); - PUTBACK; - return; - } - EXTEND(SP,1); - XSRETURN_PV(fsname); - } - XSRETURN_EMPTY; -} - -XS(w32_GetOSVersion) -{ - dXSARGS; - - if (GIMME_V == G_SCALAR) { - XSRETURN_IV(g_osver.dwPlatformId); - } - XPUSHs(sv_2mortal(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion)))); - - XPUSHs(sv_2mortal(newSViv(g_osver.dwMajorVersion))); - XPUSHs(sv_2mortal(newSViv(g_osver.dwMinorVersion))); - XPUSHs(sv_2mortal(newSViv(g_osver.dwBuildNumber))); - XPUSHs(sv_2mortal(newSViv(g_osver.dwPlatformId))); - if (g_osver_ex) { - XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMajor))); - XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMinor))); - XPUSHs(sv_2mortal(newSViv(g_osver.wSuiteMask))); - XPUSHs(sv_2mortal(newSViv(g_osver.wProductType))); - } - PUTBACK; -} - -XS(w32_IsWinNT) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(IsWinNT()); -} - -XS(w32_IsWin95) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(IsWin95()); -} - -XS(w32_FormatMessage) -{ - dXSARGS; - DWORD source = 0; - char msgbuf[ONE_K_BUFSIZE]; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)"); - - if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, - &source, (DWORD)SvIV(ST(0)), 0, - msgbuf, sizeof(msgbuf)-1, NULL)) - { - XSRETURN_PV(msgbuf); - } - - XSRETURN_UNDEF; -} - -XS(w32_Spawn) -{ - dXSARGS; - char *cmd, *args; - void *env; - char *dir; - PROCESS_INFORMATION stProcInfo; - STARTUPINFO stStartInfo; - BOOL bSuccess = FALSE; - - if (items != 3) - Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)"); - - cmd = SvPV_nolen(ST(0)); - args = SvPV_nolen(ST(1)); - - env = PerlEnv_get_childenv(); - dir = PerlEnv_get_childdir(); - - memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ - stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ - stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ - stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ - - if (CreateProcess( - cmd, /* Image path */ - args, /* Arguments for command line */ - NULL, /* Default process security */ - NULL, /* Default thread security */ - FALSE, /* Must be TRUE to use std handles */ - NORMAL_PRIORITY_CLASS, /* No special scheduling */ - env, /* Inherit our environment block */ - dir, /* Inherit our currrent directory */ - &stStartInfo, /* -> Startup info */ - &stProcInfo)) /* <- Process info (if OK) */ - { - int pid = (int)stProcInfo.dwProcessId; - if (IsWin95() && pid < 0) - pid = -pid; - sv_setiv(ST(2), pid); - CloseHandle(stProcInfo.hThread);/* library source code does this. */ - bSuccess = TRUE; - } - PerlEnv_free_childenv(env); - PerlEnv_free_childdir(dir); - XSRETURN_IV(bSuccess); -} - -XS(w32_GetTickCount) -{ - dXSARGS; - DWORD msec = GetTickCount(); - EXTEND(SP,1); - if ((IV)msec > 0) - XSRETURN_IV(msec); - XSRETURN_NV(msec); -} - -XS(w32_GetShortPathName) -{ - dXSARGS; - SV *shortpath; - DWORD len; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)"); - - if (IsWin2000()) { - WCHAR wshort[MAX_PATH+1]; - WCHAR *wlong = sv_to_wstr(aTHX_ ST(0)); - len = GetShortPathNameW(wlong, wshort, countof(wshort)); - Safefree(wlong); - if (len && len < sizeof(wshort)) { - ST(0) = wstr_to_sv(aTHX_ wshort); - XSRETURN(1); - } - XSRETURN_UNDEF; - } - - shortpath = sv_mortalcopy(ST(0)); - SvUPGRADE(shortpath, SVt_PV); - if (!SvPVX(shortpath) || !SvLEN(shortpath)) - XSRETURN_UNDEF; - - /* src == target is allowed */ - do { - len = GetShortPathName(SvPVX(shortpath), - SvPVX(shortpath), - (DWORD)SvLEN(shortpath)); - } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1)); - if (len) { - SvCUR_set(shortpath,len); - *SvEND(shortpath) = '\0'; - ST(0) = shortpath; - XSRETURN(1); - } - XSRETURN_UNDEF; -} - -XS(w32_GetFullPathName) -{ - dXSARGS; - char *fullname; - char *ansi = NULL; - -/* The code below relies on the fact that PerlDir_mapX() returns an - * absolute path, which is only true under PERL_IMPLICIT_SYS when - * we use the virtualization code from win32/vdir.h. - * Without it PerlDir_mapX() is a no-op and we need to use the same - * code as we use for Cygwin. - */ -#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS) - char buffer[2*MAX_PATH]; -#endif - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)"); - -#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS) - if (IsWin2000()) { - WCHAR *filename = sv_to_wstr(aTHX_ ST(0)); - WCHAR full[2*MAX_PATH]; - DWORD len = GetFullPathNameW(filename, countof(full), full, NULL); - Safefree(filename); - if (len == 0 || len >= countof(full)) - XSRETURN_EMPTY; - ansi = fullname = my_ansipath(full); - } - else { - DWORD len = GetFullPathNameA(SvPV_nolen(ST(0)), countof(buffer), buffer, NULL); - if (len == 0 || len >= countof(buffer)) - XSRETURN_EMPTY; - fullname = buffer; - } -#else - /* Don't use my_ansipath() unless the $filename argument is in Unicode. - * If the relative path doesn't exist, GetShortPathName() will fail and - * my_ansipath() will use the long name with replacement characters. - * In that case we will be better off using PerlDir_mapA(), which - * already uses the ANSI name of the current directory. - * - * XXX The one missing case is where we could downgrade $filename - * XXX from UTF8 into the current codepage. - */ - if (IsWin2000() && SvUTF8(ST(0))) { - WCHAR *filename = sv_to_wstr(aTHX_ ST(0)); - WCHAR *mappedname = PerlDir_mapW(filename); - Safefree(filename); - ansi = fullname = my_ansipath(mappedname); - } - else { - fullname = PerlDir_mapA(SvPV_nolen(ST(0))); - } -# if PERL_VERSION < 8 - { - /* PerlDir_mapX() in Perl 5.6 used to return forward slashes */ - char *str = fullname; - while (*str) { - if (*str == '/') - *str = '\\'; - ++str; - } - } -# endif -#endif - - /* GetFullPathName() on Windows NT drops trailing backslash */ - if (g_osver.dwMajorVersion == 4 && *fullname) { - STRLEN len; - char *pv = SvPV(ST(0), len); - char *lastchar = fullname + strlen(fullname) - 1; - /* If ST(0) ends with a slash, but fullname doesn't ... */ - if (len && (pv[len-1] == '/' || pv[len-1] == '\\') && *lastchar != '\\') { - /* fullname is the MAX_PATH+1 sized buffer returned from PerlDir_mapA() - * or the 2*MAX_PATH sized local buffer in the __CYGWIN__ case. - */ - strcpy(lastchar+1, "\\"); - } - } - - if (GIMME_V == G_ARRAY) { - char *filepart = strrchr(fullname, '\\'); - - EXTEND(SP,1); - if (filepart) { - XST_mPV(1, ++filepart); - *filepart = '\0'; - } - else { - XST_mPVN(1, "", 0); - } - items = 2; - } - XST_mPV(0, fullname); - - if (ansi) - Safefree(ansi); - XSRETURN(items); -} - -XS(w32_GetLongPathName) -{ - dXSARGS; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)"); - - if (IsWin2000()) { - WCHAR *wstr = sv_to_wstr(aTHX_ ST(0)); - WCHAR wide_path[MAX_PATH+1]; - WCHAR *long_path; - - wcscpy(wide_path, wstr); - Safefree(wstr); - long_path = my_longpathW(wide_path); - if (long_path) { - ST(0) = wstr_to_sv(aTHX_ long_path); - XSRETURN(1); - } - } - else { - SV *path; - char tmpbuf[MAX_PATH+1]; - char *pathstr; - STRLEN len; - - path = ST(0); - pathstr = SvPV(path,len); - strcpy(tmpbuf, pathstr); - pathstr = my_longpathA(tmpbuf); - if (pathstr) { - ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr))); - XSRETURN(1); - } - } - XSRETURN_EMPTY; -} - -XS(w32_GetANSIPathName) -{ - dXSARGS; - WCHAR *wide_path; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::GetANSIPathName($pathname)"); - - wide_path = sv_to_wstr(aTHX_ ST(0)); - ST(0) = wstr_to_ansipath(aTHX_ wide_path); - Safefree(wide_path); - XSRETURN(1); -} - -XS(w32_Sleep) -{ - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)"); - Sleep((DWORD)SvIV(ST(0))); - XSRETURN_YES; -} - -XS(w32_CopyFile) -{ - dXSARGS; - BOOL bResult; - char szSourceFile[MAX_PATH+1]; - - if (items != 3) - Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); - strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0)))); - bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2))); - if (bResult) - XSRETURN_YES; - XSRETURN_NO; -} - -XS(w32_OutputDebugString) -{ - dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::OutputDebugString($string)"); - - if (SvUTF8(ST(0))) { - WCHAR *str = sv_to_wstr(aTHX_ ST(0)); - OutputDebugStringW(str); - Safefree(str); - } - else - OutputDebugStringA(SvPV_nolen(ST(0))); - - XSRETURN_EMPTY; -} - -XS(w32_GetCurrentProcessId) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(GetCurrentProcessId()); -} - -XS(w32_GetCurrentThreadId) -{ - dXSARGS; - EXTEND(SP,1); - XSRETURN_IV(GetCurrentThreadId()); -} - -XS(w32_CreateDirectory) -{ - dXSARGS; - BOOL result; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::CreateDirectory($dir)"); - - if (IsWin2000() && SvUTF8(ST(0))) { - WCHAR *dir = sv_to_wstr(aTHX_ ST(0)); - result = CreateDirectoryW(dir, NULL); - Safefree(dir); - } - else { - result = CreateDirectoryA(SvPV_nolen(ST(0)), NULL); - } - - ST(0) = boolSV(result); - XSRETURN(1); -} - -XS(w32_CreateFile) -{ - dXSARGS; - HANDLE handle; - - if (items != 1) - Perl_croak(aTHX_ "usage: Win32::CreateFile($file)"); - - if (IsWin2000() && SvUTF8(ST(0))) { - WCHAR *file = sv_to_wstr(aTHX_ ST(0)); - handle = CreateFileW(file, GENERIC_WRITE, FILE_SHARE_WRITE, - NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL); - Safefree(file); - } - else { - handle = CreateFileA(SvPV_nolen(ST(0)), GENERIC_WRITE, FILE_SHARE_WRITE, - NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL); - } - - if (handle != INVALID_HANDLE_VALUE) - CloseHandle(handle); - - ST(0) = boolSV(handle != INVALID_HANDLE_VALUE); - XSRETURN(1); -} - -MODULE = Win32 PACKAGE = Win32 - -PROTOTYPES: DISABLE - -BOOT: -{ - char *file = __FILE__; - - if (g_osver.dwOSVersionInfoSize == 0) { - g_osver.dwOSVersionInfoSize = sizeof(g_osver); - if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) { - g_osver_ex = FALSE; - g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); - GetVersionExA((OSVERSIONINFOA*)&g_osver); - } - } - - newXS("Win32::LookupAccountName", w32_LookupAccountName, file); - newXS("Win32::LookupAccountSID", w32_LookupAccountSID, file); - newXS("Win32::InitiateSystemShutdown", w32_InitiateSystemShutdown, file); - newXS("Win32::AbortSystemShutdown", w32_AbortSystemShutdown, file); - newXS("Win32::ExpandEnvironmentStrings", w32_ExpandEnvironmentStrings, file); - newXS("Win32::MsgBox", w32_MsgBox, file); - newXS("Win32::LoadLibrary", w32_LoadLibrary, file); - newXS("Win32::FreeLibrary", w32_FreeLibrary, file); - newXS("Win32::GetProcAddress", w32_GetProcAddress, file); - newXS("Win32::RegisterServer", w32_RegisterServer, file); - newXS("Win32::UnregisterServer", w32_UnregisterServer, file); - newXS("Win32::GetArchName", w32_GetArchName, file); - newXS("Win32::GetChipName", w32_GetChipName, file); - newXS("Win32::GuidGen", w32_GuidGen, file); - newXS("Win32::GetFolderPath", w32_GetFolderPath, file); - newXS("Win32::IsAdminUser", w32_IsAdminUser, file); - newXS("Win32::GetFileVersion", w32_GetFileVersion, file); - - newXS("Win32::GetCwd", w32_GetCwd, file); - newXS("Win32::SetCwd", w32_SetCwd, file); - newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); - newXS("Win32::GetLastError", w32_GetLastError, file); - newXS("Win32::SetLastError", w32_SetLastError, file); - newXS("Win32::LoginName", w32_LoginName, file); - newXS("Win32::NodeName", w32_NodeName, file); - newXS("Win32::DomainName", w32_DomainName, file); - newXS("Win32::FsType", w32_FsType, file); - newXS("Win32::GetOSVersion", w32_GetOSVersion, file); - newXS("Win32::IsWinNT", w32_IsWinNT, file); - newXS("Win32::IsWin95", w32_IsWin95, file); - newXS("Win32::FormatMessage", w32_FormatMessage, file); - newXS("Win32::Spawn", w32_Spawn, file); - newXS("Win32::GetTickCount", w32_GetTickCount, file); - newXS("Win32::GetShortPathName", w32_GetShortPathName, file); - newXS("Win32::GetFullPathName", w32_GetFullPathName, file); - newXS("Win32::GetLongPathName", w32_GetLongPathName, file); - newXS("Win32::GetANSIPathName", w32_GetANSIPathName, file); - newXS("Win32::CopyFile", w32_CopyFile, file); - newXS("Win32::Sleep", w32_Sleep, file); - newXS("Win32::OutputDebugString", w32_OutputDebugString, file); - newXS("Win32::GetCurrentProcessId", w32_GetCurrentProcessId, file); - newXS("Win32::GetCurrentThreadId", w32_GetCurrentThreadId, file); - newXS("Win32::CreateDirectory", w32_CreateDirectory, file); - newXS("Win32::CreateFile", w32_CreateFile, file); -#ifdef __CYGWIN__ - newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); -#endif - XSRETURN_YES; -} +#include +#include +#include + +#define PERL_NO_GET_CONTEXT +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" + +#ifndef countof +# define countof(array) (sizeof (array) / sizeof (*(array))) +#endif + +#define SE_SHUTDOWN_NAMEA "SeShutdownPrivilege" + +#ifndef WC_NO_BEST_FIT_CHARS +# define WC_NO_BEST_FIT_CHARS 0x00000400 +#endif + +#define GETPROC(fn) pfn##fn = (PFN##fn)GetProcAddress(module, #fn) + +typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathA)(HWND, char*, int, BOOL); +typedef BOOL (WINAPI *PFNSHGetSpecialFolderPathW)(HWND, WCHAR*, int, BOOL); +typedef HRESULT (WINAPI *PFNSHGetFolderPathA)(HWND, int, HANDLE, DWORD, LPTSTR); +typedef HRESULT (WINAPI *PFNSHGetFolderPathW)(HWND, int, HANDLE, DWORD, LPWSTR); +typedef BOOL (WINAPI *PFNCreateEnvironmentBlock)(void**, HANDLE, BOOL); +typedef BOOL (WINAPI *PFNDestroyEnvironmentBlock)(void*); +typedef int (__stdcall *PFNDllRegisterServer)(void); +typedef int (__stdcall *PFNDllUnregisterServer)(void); +typedef DWORD (__stdcall *PFNNetApiBufferFree)(void*); +typedef DWORD (__stdcall *PFNNetWkstaGetInfo)(LPWSTR, DWORD, void*); + +typedef BOOL (__stdcall *PFNOpenProcessToken)(HANDLE, DWORD, HANDLE*); +typedef BOOL (__stdcall *PFNOpenThreadToken)(HANDLE, DWORD, BOOL, HANDLE*); +typedef BOOL (__stdcall *PFNGetTokenInformation)(HANDLE, TOKEN_INFORMATION_CLASS, void*, DWORD, DWORD*); +typedef BOOL (__stdcall *PFNAllocateAndInitializeSid)(PSID_IDENTIFIER_AUTHORITY, BYTE, DWORD, DWORD, + DWORD, DWORD, DWORD, DWORD, DWORD, DWORD, PSID*); +typedef BOOL (__stdcall *PFNEqualSid)(PSID, PSID); +typedef void* (__stdcall *PFNFreeSid)(PSID); +typedef BOOL (__stdcall *PFNIsUserAnAdmin)(void); + +#ifndef CSIDL_MYMUSIC +# define CSIDL_MYMUSIC 0x000D +#endif +#ifndef CSIDL_MYVIDEO +# define CSIDL_MYVIDEO 0x000E +#endif +#ifndef CSIDL_LOCAL_APPDATA +# define CSIDL_LOCAL_APPDATA 0x001C +#endif +#ifndef CSIDL_COMMON_FAVORITES +# define CSIDL_COMMON_FAVORITES 0x001F +#endif +#ifndef CSIDL_INTERNET_CACHE +# define CSIDL_INTERNET_CACHE 0x0020 +#endif +#ifndef CSIDL_COOKIES +# define CSIDL_COOKIES 0x0021 +#endif +#ifndef CSIDL_HISTORY +# define CSIDL_HISTORY 0x0022 +#endif +#ifndef CSIDL_COMMON_APPDATA +# define CSIDL_COMMON_APPDATA 0x0023 +#endif +#ifndef CSIDL_WINDOWS +# define CSIDL_WINDOWS 0x0024 +#endif +#ifndef CSIDL_PROGRAM_FILES +# define CSIDL_PROGRAM_FILES 0x0026 +#endif +#ifndef CSIDL_MYPICTURES +# define CSIDL_MYPICTURES 0x0027 +#endif +#ifndef CSIDL_PROFILE +# define CSIDL_PROFILE 0x0028 +#endif +#ifndef CSIDL_PROGRAM_FILES_COMMON +# define CSIDL_PROGRAM_FILES_COMMON 0x002B +#endif +#ifndef CSIDL_COMMON_TEMPLATES +# define CSIDL_COMMON_TEMPLATES 0x002D +#endif +#ifndef CSIDL_COMMON_DOCUMENTS +# define CSIDL_COMMON_DOCUMENTS 0x002E +#endif +#ifndef CSIDL_COMMON_ADMINTOOLS +# define CSIDL_COMMON_ADMINTOOLS 0x002F +#endif +#ifndef CSIDL_ADMINTOOLS +# define CSIDL_ADMINTOOLS 0x0030 +#endif +#ifndef CSIDL_COMMON_MUSIC +# define CSIDL_COMMON_MUSIC 0x0035 +#endif +#ifndef CSIDL_COMMON_PICTURES +# define CSIDL_COMMON_PICTURES 0x0036 +#endif +#ifndef CSIDL_COMMON_VIDEO +# define CSIDL_COMMON_VIDEO 0x0037 +#endif +#ifndef CSIDL_CDBURN_AREA +# define CSIDL_CDBURN_AREA 0x003B +#endif +#ifndef CSIDL_FLAG_CREATE +# define CSIDL_FLAG_CREATE 0x8000 +#endif + +/* Use explicit struct definition because wSuiteMask and + * wProductType are not defined in the VC++ 6.0 headers. + * WORD type has been replaced by unsigned short because + * WORD is already used by Perl itself. + */ +struct { + DWORD dwOSVersionInfoSize; + DWORD dwMajorVersion; + DWORD dwMinorVersion; + DWORD dwBuildNumber; + DWORD dwPlatformId; + CHAR szCSDVersion[128]; + unsigned short wServicePackMajor; + unsigned short wServicePackMinor; + unsigned short wSuiteMask; + BYTE wProductType; + BYTE wReserved; +} g_osver = {0, 0, 0, 0, 0, "", 0, 0, 0, 0, 0}; +BOOL g_osver_ex = TRUE; + +#define ONE_K_BUFSIZE 1024 + +int +IsWin95(void) +{ + return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_WINDOWS); +} + +int +IsWinNT(void) +{ + return (g_osver.dwPlatformId == VER_PLATFORM_WIN32_NT); +} + +int +IsWin2000(void) +{ + return (g_osver.dwMajorVersion > 4); +} + +/* Convert SV to wide character string. The return value must be + * freed using Safefree(). + */ +WCHAR* +sv_to_wstr(pTHX_ SV *sv) +{ + DWORD wlen; + WCHAR *wstr; + STRLEN len; + char *str = SvPV(sv, len); + UINT cp = SvUTF8(sv) ? CP_UTF8 : CP_ACP; + + wlen = MultiByteToWideChar(cp, 0, str, (int)(len+1), NULL, 0); + New(0, wstr, wlen, WCHAR); + MultiByteToWideChar(cp, 0, str, (int)(len+1), wstr, wlen); + + return wstr; +} + +/* Convert wide character string to mortal SV. Use UTF8 encoding + * if the string cannot be represented in the system codepage. + */ +SV * +wstr_to_sv(pTHX_ WCHAR *wstr) +{ + int wlen = (int)wcslen(wstr)+1; + BOOL use_default = FALSE; + int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, NULL, 0, NULL, NULL); + SV *sv = sv_2mortal(newSV(len)); + + len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, wstr, wlen, SvPVX(sv), len, NULL, &use_default); + if (use_default) { + len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, NULL, 0, NULL, NULL); + sv_grow(sv, len); + len = WideCharToMultiByte(CP_UTF8, 0, wstr, wlen, SvPVX(sv), len, NULL, NULL); + SvUTF8_on(sv); + } + /* Shouldn't really ever fail since we ask for the required length first, but who knows... */ + if (len) { + SvPOK_on(sv); + SvCUR_set(sv, len-1); + } + return sv; +} + +/* Retrieve a variable from the Unicode environment in a mortal SV. + * + * Recreates the Unicode environment because a bug in earlier Perl versions + * overwrites it with the ANSI version, which contains replacement + * characters for the characters not in the ANSI codepage. + */ +SV* +get_unicode_env(pTHX_ WCHAR *name) +{ + SV *sv = NULL; + void *env; + HANDLE token; + HMODULE module; + PFNOpenProcessToken pfnOpenProcessToken; + + /* Get security token for the current process owner */ + module = LoadLibrary("advapi32.dll"); + if (!module) + return NULL; + + GETPROC(OpenProcessToken); + + if (pfnOpenProcessToken == NULL || + !pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY | TOKEN_DUPLICATE, &token)) + { + FreeLibrary(module); + return NULL; + } + FreeLibrary(module); + + /* Create a Unicode environment block for this process */ + module = LoadLibrary("userenv.dll"); + if (module) { + PFNCreateEnvironmentBlock pfnCreateEnvironmentBlock; + PFNDestroyEnvironmentBlock pfnDestroyEnvironmentBlock; + + GETPROC(CreateEnvironmentBlock); + GETPROC(DestroyEnvironmentBlock); + + if (pfnCreateEnvironmentBlock && pfnDestroyEnvironmentBlock && + pfnCreateEnvironmentBlock(&env, token, FALSE)) + { + size_t name_len = wcslen(name); + WCHAR *entry = env; + while (*entry) { + size_t i; + size_t entry_len = wcslen(entry); + BOOL equal = (entry_len > name_len) && (entry[name_len] == '='); + + for (i=0; equal && i < name_len; ++i) + equal = (towupper(entry[i]) == towupper(name[i])); + + if (equal) { + sv = wstr_to_sv(aTHX_ entry+name_len+1); + break; + } + entry += entry_len+1; + } + pfnDestroyEnvironmentBlock(env); + } + FreeLibrary(module); + } + CloseHandle(token); + return sv; +} + +/* Define both an ANSI and a Wide version of win32_longpath */ + +#define CHAR_T char +#define WIN32_FIND_DATA_T WIN32_FIND_DATAA +#define FN_FINDFIRSTFILE FindFirstFileA +#define FN_STRLEN strlen +#define FN_STRCPY strcpy +#define LONGPATH my_longpathA +#include "longpath.inc" + +#define CHAR_T WCHAR +#define WIN32_FIND_DATA_T WIN32_FIND_DATAW +#define FN_FINDFIRSTFILE FindFirstFileW +#define FN_STRLEN wcslen +#define FN_STRCPY wcscpy +#define LONGPATH my_longpathW +#include "longpath.inc" + +/* The my_ansipath() function takes a Unicode filename and converts it + * into the current Windows codepage. If some characters cannot be mapped, + * then it will convert the short name instead. + * + * The buffer to the ansi pathname must be freed with Safefree() when it + * it no longer needed. + * + * The argument to my_ansipath() must exist before this function is + * called; otherwise there is no way to determine the short path name. + * + * Ideas for future refinement: + * - Only convert those segments of the path that are not in the current + * codepage, but leave the other segments in their long form. + * - If the resulting name is longer than MAX_PATH, start converting + * additional path segments into short names until the full name + * is shorter than MAX_PATH. Shorten the filename part last! + */ + +/* This is a modified version of core Perl win32/win32.c(win32_ansipath). + * It uses New() etc. instead of win32_malloc(). + */ + +char * +my_ansipath(const WCHAR *widename) +{ + char *name; + BOOL use_default = FALSE; + int widelen = (int)wcslen(widename)+1; + int len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, + NULL, 0, NULL, NULL); + New(0, name, len, char); + WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, widename, widelen, + name, len, NULL, &use_default); + if (use_default) { + DWORD shortlen = GetShortPathNameW(widename, NULL, 0); + if (shortlen) { + WCHAR *shortname; + New(0, shortname, shortlen, WCHAR); + shortlen = GetShortPathNameW(widename, shortname, shortlen)+1; + + len = WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, + NULL, 0, NULL, NULL); + Renew(name, len, char); + WideCharToMultiByte(CP_ACP, WC_NO_BEST_FIT_CHARS, shortname, shortlen, + name, len, NULL, NULL); + Safefree(shortname); + } + } + return name; +} + +/* Convert wide character path to ANSI path and return as mortal SV. */ +SV* +wstr_to_ansipath(pTHX_ WCHAR *wstr) +{ + char *ansi = my_ansipath(wstr); + SV *sv = sv_2mortal(newSVpvn(ansi, strlen(ansi))); + Safefree(ansi); + return sv; +} + +#ifdef __CYGWIN__ + +char* +get_childdir(void) +{ + dTHX; + char* ptr; + + if (IsWin2000()) { + WCHAR filename[MAX_PATH+1]; + GetCurrentDirectoryW(MAX_PATH+1, filename); + ptr = my_ansipath(filename); + } + else { + char filename[MAX_PATH+1]; + GetCurrentDirectoryA(MAX_PATH+1, filename); + New(0, ptr, strlen(filename)+1, char); + strcpy(ptr, filename); + } + return ptr; +} + +void +free_childdir(char *d) +{ + dTHX; + Safefree(d); +} + +void* +get_childenv(void) +{ + return NULL; +} + +void +free_childenv(void *d) +{ +} + +# define PerlDir_mapA(dir) (dir) + +#endif + +XS(w32_ExpandEnvironmentStrings) +{ + dXSARGS; + + if (items != 1) + croak("usage: Win32::ExpandEnvironmentStrings($String);\n"); + + if (IsWin2000()) { + WCHAR value[31*1024]; + WCHAR *source = sv_to_wstr(aTHX_ ST(0)); + ExpandEnvironmentStringsW(source, value, countof(value)-1); + ST(0) = wstr_to_sv(aTHX_ value); + Safefree(source); + XSRETURN(1); + } + else { + char value[31*1024]; + ExpandEnvironmentStringsA(SvPV_nolen(ST(0)), value, countof(value)-2); + XSRETURN_PV(value); + } +} + +XS(w32_IsAdminUser) +{ + dXSARGS; + HMODULE module; + PFNIsUserAnAdmin pfnIsUserAnAdmin; + PFNOpenThreadToken pfnOpenThreadToken; + PFNOpenProcessToken pfnOpenProcessToken; + PFNGetTokenInformation pfnGetTokenInformation; + PFNAllocateAndInitializeSid pfnAllocateAndInitializeSid; + PFNEqualSid pfnEqualSid; + PFNFreeSid pfnFreeSid; + HANDLE hTok; + DWORD dwTokInfoLen; + TOKEN_GROUPS *lpTokInfo; + SID_IDENTIFIER_AUTHORITY NtAuth = SECURITY_NT_AUTHORITY; + PSID pAdminSid; + int iRetVal; + unsigned int i; + + if (items) + croak("usage: Win32::IsAdminUser()"); + + /* There is no concept of "Administrator" user accounts on Win9x systems, + so just return true. */ + if (IsWin95()) + XSRETURN_YES; + + /* Use IsUserAnAdmin() when available. On Vista this will only return TRUE + * if the process is running with elevated privileges and not just when the + * process owner is a member of the "Administrators" group. + */ + module = LoadLibrary("shell32.dll"); + if (module) { + GETPROC(IsUserAnAdmin); + if (pfnIsUserAnAdmin) { + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSViv(pfnIsUserAnAdmin() ? 1 : 0)); + FreeLibrary(module); + XSRETURN(1); + } + FreeLibrary(module); + } + + module = LoadLibrary("advapi32.dll"); + if (!module) { + warn("Cannot load advapi32.dll library"); + XSRETURN_UNDEF; + } + + GETPROC(OpenThreadToken); + GETPROC(OpenProcessToken); + GETPROC(GetTokenInformation); + GETPROC(AllocateAndInitializeSid); + GETPROC(EqualSid); + GETPROC(FreeSid); + + if (!(pfnOpenThreadToken && pfnOpenProcessToken && + pfnGetTokenInformation && pfnAllocateAndInitializeSid && + pfnEqualSid && pfnFreeSid)) + { + warn("Cannot load functions from advapi32.dll library"); + FreeLibrary(module); + XSRETURN_UNDEF; + } + + if (!pfnOpenThreadToken(GetCurrentThread(), TOKEN_QUERY, FALSE, &hTok)) { + if (!pfnOpenProcessToken(GetCurrentProcess(), TOKEN_QUERY, &hTok)) { + warn("Cannot open thread token or process token"); + FreeLibrary(module); + XSRETURN_UNDEF; + } + } + + pfnGetTokenInformation(hTok, TokenGroups, NULL, 0, &dwTokInfoLen); + if (!New(1, lpTokInfo, dwTokInfoLen, TOKEN_GROUPS)) { + warn("Cannot allocate token information structure"); + CloseHandle(hTok); + FreeLibrary(module); + XSRETURN_UNDEF; + } + + if (!pfnGetTokenInformation(hTok, TokenGroups, lpTokInfo, dwTokInfoLen, + &dwTokInfoLen)) + { + warn("Cannot get token information"); + Safefree(lpTokInfo); + CloseHandle(hTok); + FreeLibrary(module); + XSRETURN_UNDEF; + } + + if (!pfnAllocateAndInitializeSid(&NtAuth, 2, SECURITY_BUILTIN_DOMAIN_RID, + DOMAIN_ALIAS_RID_ADMINS, 0, 0, 0, 0, 0, 0, &pAdminSid)) + { + warn("Cannot allocate administrators' SID"); + Safefree(lpTokInfo); + CloseHandle(hTok); + FreeLibrary(module); + XSRETURN_UNDEF; + } + + iRetVal = 0; + for (i = 0; i < lpTokInfo->GroupCount; ++i) { + if (pfnEqualSid(lpTokInfo->Groups[i].Sid, pAdminSid)) { + iRetVal = 1; + break; + } + } + + pfnFreeSid(pAdminSid); + Safefree(lpTokInfo); + CloseHandle(hTok); + FreeLibrary(module); + + EXTEND(SP, 1); + ST(0) = sv_2mortal(newSViv(iRetVal)); + XSRETURN(1); +} + +XS(w32_LookupAccountName) +{ + dXSARGS; + char SID[400]; + DWORD SIDLen; + SID_NAME_USE snu; + char Domain[256]; + DWORD DomLen; + BOOL bResult; + + if (items != 5) + croak("usage: Win32::LookupAccountName($system, $account, $domain, " + "$sid, $sidtype);\n"); + + SIDLen = sizeof(SID); + DomLen = sizeof(Domain); + + bResult = LookupAccountNameA(SvPV_nolen(ST(0)), /* System */ + SvPV_nolen(ST(1)), /* Account name */ + &SID, /* SID structure */ + &SIDLen, /* Size of SID buffer */ + Domain, /* Domain buffer */ + &DomLen, /* Domain buffer size */ + &snu); /* SID name type */ + if (bResult) { + sv_setpv(ST(2), Domain); + sv_setpvn(ST(3), SID, SIDLen); + sv_setiv(ST(4), snu); + XSRETURN_YES; + } + XSRETURN_NO; +} + + +XS(w32_LookupAccountSID) +{ + dXSARGS; + PSID sid; + char Account[256]; + DWORD AcctLen = sizeof(Account); + char Domain[256]; + DWORD DomLen = sizeof(Domain); + SID_NAME_USE snu; + BOOL bResult; + + if (items != 5) + croak("usage: Win32::LookupAccountSID($system, $sid, $account, $domain, $sidtype);\n"); + + sid = SvPV_nolen(ST(1)); + if (IsValidSid(sid)) { + bResult = LookupAccountSidA(SvPV_nolen(ST(0)), /* System */ + sid, /* SID structure */ + Account, /* Account name buffer */ + &AcctLen, /* name buffer length */ + Domain, /* Domain buffer */ + &DomLen, /* Domain buffer length */ + &snu); /* SID name type */ + if (bResult) { + sv_setpv(ST(2), Account); + sv_setpv(ST(3), Domain); + sv_setiv(ST(4), (IV)snu); + XSRETURN_YES; + } + } + XSRETURN_NO; +} + +XS(w32_InitiateSystemShutdown) +{ + dXSARGS; + HANDLE hToken; /* handle to process token */ + TOKEN_PRIVILEGES tkp; /* pointer to token structure */ + BOOL bRet; + char *machineName, *message; + + if (items != 5) + croak("usage: Win32::InitiateSystemShutdown($machineName, $message, " + "$timeOut, $forceClose, $reboot);\n"); + + machineName = SvPV_nolen(ST(0)); + + if (OpenProcessToken(GetCurrentProcess(), + TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY, + &hToken)) + { + LookupPrivilegeValueA(machineName, + SE_SHUTDOWN_NAMEA, + &tkp.Privileges[0].Luid); + + tkp.PrivilegeCount = 1; /* only setting one */ + tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED; + + /* Get shutdown privilege for this process. */ + AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, + (PTOKEN_PRIVILEGES)NULL, 0); + } + + message = SvPV_nolen(ST(1)); + bRet = InitiateSystemShutdownA(machineName, message, (DWORD)SvIV(ST(2)), + (BOOL)SvIV(ST(3)), (BOOL)SvIV(ST(4))); + + /* Disable shutdown privilege. */ + tkp.Privileges[0].Attributes = 0; + AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, + (PTOKEN_PRIVILEGES)NULL, 0); + CloseHandle(hToken); + XSRETURN_IV(bRet); +} + +XS(w32_AbortSystemShutdown) +{ + dXSARGS; + HANDLE hToken; /* handle to process token */ + TOKEN_PRIVILEGES tkp; /* pointer to token structure */ + BOOL bRet; + char *machineName; + + if (items != 1) + croak("usage: Win32::AbortSystemShutdown($machineName);\n"); + + machineName = SvPV_nolen(ST(0)); + + if (OpenProcessToken(GetCurrentProcess(), + TOKEN_ADJUST_PRIVILEGES | TOKEN_QUERY, + &hToken)) + { + LookupPrivilegeValueA(machineName, + SE_SHUTDOWN_NAMEA, + &tkp.Privileges[0].Luid); + + tkp.PrivilegeCount = 1; /* only setting one */ + tkp.Privileges[0].Attributes = SE_PRIVILEGE_ENABLED; + + /* Get shutdown privilege for this process. */ + AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, + (PTOKEN_PRIVILEGES)NULL, 0); + } + + bRet = AbortSystemShutdownA(machineName); + + /* Disable shutdown privilege. */ + tkp.Privileges[0].Attributes = 0; + AdjustTokenPrivileges(hToken, FALSE, &tkp, 0, + (PTOKEN_PRIVILEGES)NULL, 0); + CloseHandle(hToken); + XSRETURN_IV(bRet); +} + + +XS(w32_MsgBox) +{ + dXSARGS; + DWORD flags = MB_ICONEXCLAMATION; + I32 result; + + if (items < 1 || items > 3) + croak("usage: Win32::MsgBox($message [, $flags [, $title]]);\n"); + + if (items > 1) + flags = (DWORD)SvIV(ST(1)); + + if (IsWin2000()) { + WCHAR *title = NULL; + WCHAR *msg = sv_to_wstr(aTHX_ ST(0)); + if (items > 2) + title = sv_to_wstr(aTHX_ ST(2)); + result = MessageBoxW(GetActiveWindow(), msg, title ? title : L"Perl", flags); + Safefree(msg); + if (title) + Safefree(title); + } + else { + char *title = "Perl"; + char *msg = SvPV_nolen(ST(0)); + if (items > 2) + title = SvPV_nolen(ST(2)); + result = MessageBoxA(GetActiveWindow(), msg, title, flags); + } + XSRETURN_IV(result); +} + +XS(w32_LoadLibrary) +{ + dXSARGS; + HANDLE hHandle; + + if (items != 1) + croak("usage: Win32::LoadLibrary($libname)\n"); + hHandle = LoadLibraryA(SvPV_nolen(ST(0))); +#ifdef _WIN64 + XSRETURN_IV((DWORD_PTR)hHandle); +#else + XSRETURN_IV((DWORD)hHandle); +#endif +} + +XS(w32_FreeLibrary) +{ + dXSARGS; + + if (items != 1) + croak("usage: Win32::FreeLibrary($handle)\n"); + if (FreeLibrary(INT2PTR(HINSTANCE, SvIV(ST(0))))) { + XSRETURN_YES; + } + XSRETURN_NO; +} + +XS(w32_GetProcAddress) +{ + dXSARGS; + + if (items != 2) + croak("usage: Win32::GetProcAddress($hinstance, $procname)\n"); + XSRETURN_IV(PTR2IV(GetProcAddress(INT2PTR(HINSTANCE, SvIV(ST(0))), SvPV_nolen(ST(1))))); +} + +XS(w32_RegisterServer) +{ + dXSARGS; + BOOL result = FALSE; + HMODULE module; + + if (items != 1) + croak("usage: Win32::RegisterServer($libname)\n"); + + module = LoadLibraryA(SvPV_nolen(ST(0))); + if (module) { + PFNDllRegisterServer pfnDllRegisterServer; + GETPROC(DllRegisterServer); + if (pfnDllRegisterServer && pfnDllRegisterServer() == 0) + result = TRUE; + FreeLibrary(module); + } + ST(0) = boolSV(result); + XSRETURN(1); +} + +XS(w32_UnregisterServer) +{ + dXSARGS; + BOOL result = FALSE; + HINSTANCE module; + + if (items != 1) + croak("usage: Win32::UnregisterServer($libname)\n"); + + module = LoadLibraryA(SvPV_nolen(ST(0))); + if (module) { + PFNDllUnregisterServer pfnDllUnregisterServer; + GETPROC(DllUnregisterServer); + if (pfnDllUnregisterServer && pfnDllUnregisterServer() == 0) + result = TRUE; + FreeLibrary(module); + } + ST(0) = boolSV(result); + XSRETURN(1); +} + +/* XXX rather bogus */ +XS(w32_GetArchName) +{ + dXSARGS; + XSRETURN_PV(getenv("PROCESSOR_ARCHITECTURE")); +} + +XS(w32_GetChipName) +{ + dXSARGS; + SYSTEM_INFO sysinfo; + + Zero(&sysinfo,1,SYSTEM_INFO); + GetSystemInfo(&sysinfo); + /* XXX docs say dwProcessorType is deprecated on NT */ + XSRETURN_IV(sysinfo.dwProcessorType); +} + +XS(w32_GuidGen) +{ + dXSARGS; + GUID guid; + char szGUID[50] = {'\0'}; + HRESULT hr = CoCreateGuid(&guid); + + if (SUCCEEDED(hr)) { + LPOLESTR pStr = NULL; + if (SUCCEEDED(StringFromCLSID(&guid, &pStr))) { + WideCharToMultiByte(CP_ACP, 0, pStr, (int)wcslen(pStr), szGUID, + sizeof(szGUID), NULL, NULL); + CoTaskMemFree(pStr); + XSRETURN_PV(szGUID); + } + } + XSRETURN_UNDEF; +} + +XS(w32_GetFolderPath) +{ + dXSARGS; + char path[MAX_PATH+1]; + WCHAR wpath[MAX_PATH+1]; + int folder; + int create = 0; + HMODULE module; + + if (items != 1 && items != 2) + croak("usage: Win32::GetFolderPath($csidl [, $create])\n"); + + folder = (int)SvIV(ST(0)); + if (items == 2) + create = SvTRUE(ST(1)) ? CSIDL_FLAG_CREATE : 0; + + module = LoadLibrary("shfolder.dll"); + if (module) { + PFNSHGetFolderPathA pfna; + if (IsWin2000()) { + PFNSHGetFolderPathW pfnw; + pfnw = (PFNSHGetFolderPathW)GetProcAddress(module, "SHGetFolderPathW"); + if (pfnw && SUCCEEDED(pfnw(NULL, folder|create, NULL, 0, wpath))) { + FreeLibrary(module); + ST(0) = wstr_to_ansipath(aTHX_ wpath); + XSRETURN(1); + } + } + pfna = (PFNSHGetFolderPathA)GetProcAddress(module, "SHGetFolderPathA"); + if (pfna && SUCCEEDED(pfna(NULL, folder|create, NULL, 0, path))) { + FreeLibrary(module); + XSRETURN_PV(path); + } + FreeLibrary(module); + } + + module = LoadLibrary("shell32.dll"); + if (module) { + PFNSHGetSpecialFolderPathA pfna; + if (IsWin2000()) { + PFNSHGetSpecialFolderPathW pfnw; + pfnw = (PFNSHGetSpecialFolderPathW)GetProcAddress(module, "SHGetSpecialFolderPathW"); + if (pfnw && pfnw(NULL, wpath, folder, !!create)) { + FreeLibrary(module); + ST(0) = wstr_to_ansipath(aTHX_ wpath); + XSRETURN(1); + } + } + pfna = (PFNSHGetSpecialFolderPathA)GetProcAddress(module, "SHGetSpecialFolderPathA"); + if (pfna && pfna(NULL, path, folder, !!create)) { + FreeLibrary(module); + XSRETURN_PV(path); + } + FreeLibrary(module); + } + + /* SHGetFolderPathW() and SHGetSpecialFolderPathW() may fail on older + * Perl versions that have replaced the Unicode environment with an + * ANSI version. Let's go spelunking in the registry now... + */ + if (IsWin2000()) { + SV *sv; + HKEY hkey; + HKEY root = HKEY_CURRENT_USER; + WCHAR *name = NULL; + + switch (folder) { + case CSIDL_ADMINTOOLS: name = L"Administrative Tools"; break; + case CSIDL_APPDATA: name = L"AppData"; break; + case CSIDL_CDBURN_AREA: name = L"CD Burning"; break; + case CSIDL_COOKIES: name = L"Cookies"; break; + case CSIDL_DESKTOP: + case CSIDL_DESKTOPDIRECTORY: name = L"Desktop"; break; + case CSIDL_FAVORITES: name = L"Favorites"; break; + case CSIDL_FONTS: name = L"Fonts"; break; + case CSIDL_HISTORY: name = L"History"; break; + case CSIDL_INTERNET_CACHE: name = L"Cache"; break; + case CSIDL_LOCAL_APPDATA: name = L"Local AppData"; break; + case CSIDL_MYMUSIC: name = L"My Music"; break; + case CSIDL_MYPICTURES: name = L"My Pictures"; break; + case CSIDL_MYVIDEO: name = L"My Video"; break; + case CSIDL_NETHOOD: name = L"NetHood"; break; + case CSIDL_PERSONAL: name = L"Personal"; break; + case CSIDL_PRINTHOOD: name = L"PrintHood"; break; + case CSIDL_PROGRAMS: name = L"Programs"; break; + case CSIDL_RECENT: name = L"Recent"; break; + case CSIDL_SENDTO: name = L"SendTo"; break; + case CSIDL_STARTMENU: name = L"Start Menu"; break; + case CSIDL_STARTUP: name = L"Startup"; break; + case CSIDL_TEMPLATES: name = L"Templates"; break; + /* XXX L"Local Settings" */ + } + + if (!name) { + root = HKEY_LOCAL_MACHINE; + switch (folder) { + case CSIDL_COMMON_ADMINTOOLS: name = L"Common Administrative Tools"; break; + case CSIDL_COMMON_APPDATA: name = L"Common AppData"; break; + case CSIDL_COMMON_DESKTOPDIRECTORY: name = L"Common Desktop"; break; + case CSIDL_COMMON_DOCUMENTS: name = L"Common Documents"; break; + case CSIDL_COMMON_FAVORITES: name = L"Common Favorites"; break; + case CSIDL_COMMON_PROGRAMS: name = L"Common Programs"; break; + case CSIDL_COMMON_STARTMENU: name = L"Common Start Menu"; break; + case CSIDL_COMMON_STARTUP: name = L"Common Startup"; break; + case CSIDL_COMMON_TEMPLATES: name = L"Common Templates"; break; + case CSIDL_COMMON_MUSIC: name = L"CommonMusic"; break; + case CSIDL_COMMON_PICTURES: name = L"CommonPictures"; break; + case CSIDL_COMMON_VIDEO: name = L"CommonVideo"; break; + } + } + /* XXX todo + * case CSIDL_SYSTEM # GetSystemDirectory() + * case CSIDL_RESOURCES # %windir%\Resources\, For theme and other windows resources. + * case CSIDL_RESOURCES_LOCALIZED # %windir%\Resources\, for theme and other windows specific resources. + */ + +#define SHELL_FOLDERS "Software\\Microsoft\\Windows\\CurrentVersion\\Explorer\\Shell Folders" + + if (name && RegOpenKeyEx(root, SHELL_FOLDERS, 0, KEY_QUERY_VALUE, &hkey) == ERROR_SUCCESS) { + WCHAR data[MAX_PATH+1]; + DWORD cb = sizeof(data)-sizeof(WCHAR); + DWORD type = REG_NONE; + long rc = RegQueryValueExW(hkey, name, NULL, &type, (BYTE*)&data, &cb); + RegCloseKey(hkey); + if (rc == ERROR_SUCCESS && type == REG_SZ && cb > sizeof(WCHAR) && data[0]) { + /* Make sure the string is properly terminated */ + data[cb/sizeof(WCHAR)] = '\0'; + ST(0) = wstr_to_ansipath(aTHX_ data); + XSRETURN(1); + } + } + +#undef SHELL_FOLDERS + + /* Unders some circumstances the registry entries seem to have a null string + * as their value even when the directory already exists. The environment + * variables do get set though, so try re-create a Unicode environment and + * check if they are there. + */ + sv = NULL; + switch (folder) { + case CSIDL_APPDATA: sv = get_unicode_env(aTHX_ L"APPDATA"); break; + case CSIDL_PROFILE: sv = get_unicode_env(aTHX_ L"USERPROFILE"); break; + case CSIDL_PROGRAM_FILES: sv = get_unicode_env(aTHX_ L"ProgramFiles"); break; + case CSIDL_PROGRAM_FILES_COMMON: sv = get_unicode_env(aTHX_ L"CommonProgramFiles"); break; + case CSIDL_WINDOWS: sv = get_unicode_env(aTHX_ L"SystemRoot"); break; + } + if (sv) { + ST(0) = sv; + XSRETURN(1); + } + } + + XSRETURN_UNDEF; +} + +XS(w32_GetFileVersion) +{ + dXSARGS; + DWORD size; + DWORD handle; + char *filename; + char *data; + + if (items != 1) + croak("usage: Win32::GetFileVersion($filename)\n"); + + filename = SvPV_nolen(ST(0)); + size = GetFileVersionInfoSize(filename, &handle); + if (!size) + XSRETURN_UNDEF; + + New(0, data, size, char); + if (!data) + XSRETURN_UNDEF; + + if (GetFileVersionInfo(filename, handle, size, data)) { + VS_FIXEDFILEINFO *info; + UINT len; + if (VerQueryValue(data, "\\", (void**)&info, &len)) { + int dwValueMS1 = (info->dwFileVersionMS>>16); + int dwValueMS2 = (info->dwFileVersionMS&0xffff); + int dwValueLS1 = (info->dwFileVersionLS>>16); + int dwValueLS2 = (info->dwFileVersionLS&0xffff); + + if (GIMME_V == G_ARRAY) { + EXTEND(SP, 4); + XST_mIV(0, dwValueMS1); + XST_mIV(1, dwValueMS2); + XST_mIV(2, dwValueLS1); + XST_mIV(3, dwValueLS2); + items = 4; + } + else { + char version[50]; + sprintf(version, "%d.%d.%d.%d", dwValueMS1, dwValueMS2, dwValueLS1, dwValueLS2); + XST_mPV(0, version); + } + } + } + else + items = 0; + + Safefree(data); + XSRETURN(items); +} + +#ifdef __CYGWIN__ +XS(w32_SetChildShowWindow) +{ + /* This function doesn't do anything useful for cygwin. In the + * MSWin32 case it modifies w32_showwindow, which is used by + * win32_spawnvp(). Since w32_showwindow is an internal variable + * inside the thread_intern structure, the MSWin32 implementation + * lives in win32/win32.c in the core Perl distribution. + */ + dXSARGS; + XSRETURN_UNDEF; +} +#endif + +XS(w32_GetCwd) +{ + dXSARGS; + /* Make the host for current directory */ + char* ptr = PerlEnv_get_childdir(); + /* + * If ptr != Nullch + * then it worked, set PV valid, + * else return 'undef' + */ + if (ptr) { + SV *sv = sv_newmortal(); + sv_setpv(sv, ptr); + PerlEnv_free_childdir(ptr); + +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + + EXTEND(SP,1); + ST(0) = sv; + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +XS(w32_SetCwd) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::SetCwd($cwd)"); + + if (IsWin2000() && SvUTF8(ST(0))) { + WCHAR *wide = sv_to_wstr(aTHX_ ST(0)); + char *ansi = my_ansipath(wide); + int rc = PerlDir_chdir(ansi); + Safefree(wide); + Safefree(ansi); + if (!rc) + XSRETURN_YES; + } + else { + if (!PerlDir_chdir(SvPV_nolen(ST(0)))) + XSRETURN_YES; + } + + XSRETURN_NO; +} + +XS(w32_GetNextAvailDrive) +{ + dXSARGS; + char ix = 'C'; + char root[] = "_:\\"; + + EXTEND(SP,1); + while (ix <= 'Z') { + root[0] = ix++; + if (GetDriveType(root) == 1) { + root[2] = '\0'; + XSRETURN_PV(root); + } + } + XSRETURN_UNDEF; +} + +XS(w32_GetLastError) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(GetLastError()); +} + +XS(w32_SetLastError) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::SetLastError($error)"); + SetLastError((DWORD)SvIV(ST(0))); + XSRETURN_EMPTY; +} + +XS(w32_LoginName) +{ + dXSARGS; + EXTEND(SP,1); + if (IsWin2000()) { + WCHAR name[128]; + DWORD size = countof(name); + if (GetUserNameW(name, &size)) { + ST(0) = wstr_to_sv(aTHX_ name); + XSRETURN(1); + } + } + else { + char name[128]; + DWORD size = countof(name); + if (GetUserNameA(name, &size)) { + /* size includes NULL */ + ST(0) = sv_2mortal(newSVpvn(name, size-1)); + XSRETURN(1); + } + } + XSRETURN_UNDEF; +} + +XS(w32_NodeName) +{ + dXSARGS; + char name[MAX_COMPUTERNAME_LENGTH+1]; + DWORD size = sizeof(name); + EXTEND(SP,1); + if (GetComputerName(name,&size)) { + /* size does NOT include NULL :-( */ + ST(0) = sv_2mortal(newSVpvn(name,size)); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +XS(w32_DomainName) +{ + dXSARGS; + HMODULE module = LoadLibrary("netapi32.dll"); + PFNNetApiBufferFree pfnNetApiBufferFree; + PFNNetWkstaGetInfo pfnNetWkstaGetInfo; + + if (module) { + GETPROC(NetApiBufferFree); + GETPROC(NetWkstaGetInfo); + } + EXTEND(SP,1); + if (module && pfnNetWkstaGetInfo && pfnNetApiBufferFree) { + /* this way is more reliable, in case user has a local account. */ + char dname[256]; + DWORD dnamelen = sizeof(dname); + struct { + DWORD wki100_platform_id; + LPWSTR wki100_computername; + LPWSTR wki100_langroup; + DWORD wki100_ver_major; + DWORD wki100_ver_minor; + } *pwi; + DWORD retval; + retval = pfnNetWkstaGetInfo(NULL, 100, &pwi); + /* NERR_Success *is* 0*/ + if (retval == 0) { + if (pwi->wki100_langroup && *(pwi->wki100_langroup)) { + WideCharToMultiByte(CP_ACP, 0, pwi->wki100_langroup, + -1, (LPSTR)dname, dnamelen, NULL, NULL); + } + else { + WideCharToMultiByte(CP_ACP, 0, pwi->wki100_computername, + -1, (LPSTR)dname, dnamelen, NULL, NULL); + } + pfnNetApiBufferFree(pwi); + FreeLibrary(module); + XSRETURN_PV(dname); + } + FreeLibrary(module); + SetLastError(retval); + } + else { + /* Win95 doesn't have NetWksta*(), so do it the old way */ + char name[256]; + DWORD size = sizeof(name); + if (module) + FreeLibrary(module); + if (GetUserName(name,&size)) { + char sid[ONE_K_BUFSIZE]; + DWORD sidlen = sizeof(sid); + char dname[256]; + DWORD dnamelen = sizeof(dname); + SID_NAME_USE snu; + if (LookupAccountName(NULL, name, (PSID)&sid, &sidlen, + dname, &dnamelen, &snu)) { + XSRETURN_PV(dname); /* all that for this */ + } + } + } + XSRETURN_UNDEF; +} + +XS(w32_FsType) +{ + dXSARGS; + char fsname[256]; + DWORD flags, filecomplen; + if (GetVolumeInformation(NULL, NULL, 0, NULL, &filecomplen, + &flags, fsname, sizeof(fsname))) { + if (GIMME_V == G_ARRAY) { + XPUSHs(sv_2mortal(newSVpvn(fsname,strlen(fsname)))); + XPUSHs(sv_2mortal(newSViv(flags))); + XPUSHs(sv_2mortal(newSViv(filecomplen))); + PUTBACK; + return; + } + EXTEND(SP,1); + XSRETURN_PV(fsname); + } + XSRETURN_EMPTY; +} + +XS(w32_GetOSVersion) +{ + dXSARGS; + + if (GIMME_V == G_SCALAR) { + XSRETURN_IV(g_osver.dwPlatformId); + } + XPUSHs(sv_2mortal(newSVpvn(g_osver.szCSDVersion, strlen(g_osver.szCSDVersion)))); + + XPUSHs(sv_2mortal(newSViv(g_osver.dwMajorVersion))); + XPUSHs(sv_2mortal(newSViv(g_osver.dwMinorVersion))); + XPUSHs(sv_2mortal(newSViv(g_osver.dwBuildNumber))); + XPUSHs(sv_2mortal(newSViv(g_osver.dwPlatformId))); + if (g_osver_ex) { + XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMajor))); + XPUSHs(sv_2mortal(newSViv(g_osver.wServicePackMinor))); + XPUSHs(sv_2mortal(newSViv(g_osver.wSuiteMask))); + XPUSHs(sv_2mortal(newSViv(g_osver.wProductType))); + } + PUTBACK; +} + +XS(w32_IsWinNT) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(IsWinNT()); +} + +XS(w32_IsWin95) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(IsWin95()); +} + +XS(w32_FormatMessage) +{ + dXSARGS; + DWORD source = 0; + char msgbuf[ONE_K_BUFSIZE]; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::FormatMessage($errno)"); + + if (FormatMessageA(FORMAT_MESSAGE_FROM_SYSTEM, + &source, (DWORD)SvIV(ST(0)), 0, + msgbuf, sizeof(msgbuf)-1, NULL)) + { + XSRETURN_PV(msgbuf); + } + + XSRETURN_UNDEF; +} + +XS(w32_Spawn) +{ + dXSARGS; + char *cmd, *args; + void *env; + char *dir; + PROCESS_INFORMATION stProcInfo; + STARTUPINFO stStartInfo; + BOOL bSuccess = FALSE; + + if (items != 3) + Perl_croak(aTHX_ "usage: Win32::Spawn($cmdName, $args, $PID)"); + + cmd = SvPV_nolen(ST(0)); + args = SvPV_nolen(ST(1)); + + env = PerlEnv_get_childenv(); + dir = PerlEnv_get_childdir(); + + memset(&stStartInfo, 0, sizeof(stStartInfo)); /* Clear the block */ + stStartInfo.cb = sizeof(stStartInfo); /* Set the structure size */ + stStartInfo.dwFlags = STARTF_USESHOWWINDOW; /* Enable wShowWindow control */ + stStartInfo.wShowWindow = SW_SHOWMINNOACTIVE; /* Start min (normal) */ + + if (CreateProcess( + cmd, /* Image path */ + args, /* Arguments for command line */ + NULL, /* Default process security */ + NULL, /* Default thread security */ + FALSE, /* Must be TRUE to use std handles */ + NORMAL_PRIORITY_CLASS, /* No special scheduling */ + env, /* Inherit our environment block */ + dir, /* Inherit our currrent directory */ + &stStartInfo, /* -> Startup info */ + &stProcInfo)) /* <- Process info (if OK) */ + { + int pid = (int)stProcInfo.dwProcessId; + if (IsWin95() && pid < 0) + pid = -pid; + sv_setiv(ST(2), pid); + CloseHandle(stProcInfo.hThread);/* library source code does this. */ + bSuccess = TRUE; + } + PerlEnv_free_childenv(env); + PerlEnv_free_childdir(dir); + XSRETURN_IV(bSuccess); +} + +XS(w32_GetTickCount) +{ + dXSARGS; + DWORD msec = GetTickCount(); + EXTEND(SP,1); + if ((IV)msec > 0) + XSRETURN_IV(msec); + XSRETURN_NV(msec); +} + +XS(w32_GetShortPathName) +{ + dXSARGS; + SV *shortpath; + DWORD len; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetShortPathName($longPathName)"); + + if (IsWin2000()) { + WCHAR wshort[MAX_PATH+1]; + WCHAR *wlong = sv_to_wstr(aTHX_ ST(0)); + len = GetShortPathNameW(wlong, wshort, countof(wshort)); + Safefree(wlong); + if (len && len < sizeof(wshort)) { + ST(0) = wstr_to_sv(aTHX_ wshort); + XSRETURN(1); + } + XSRETURN_UNDEF; + } + + shortpath = sv_mortalcopy(ST(0)); + SvUPGRADE(shortpath, SVt_PV); + if (!SvPVX(shortpath) || !SvLEN(shortpath)) + XSRETURN_UNDEF; + + /* src == target is allowed */ + do { + len = GetShortPathName(SvPVX(shortpath), + SvPVX(shortpath), + (DWORD)SvLEN(shortpath)); + } while (len >= SvLEN(shortpath) && sv_grow(shortpath,len+1)); + if (len) { + SvCUR_set(shortpath,len); + *SvEND(shortpath) = '\0'; + ST(0) = shortpath; + XSRETURN(1); + } + XSRETURN_UNDEF; +} + +XS(w32_GetFullPathName) +{ + dXSARGS; + char *fullname; + char *ansi = NULL; + +/* The code below relies on the fact that PerlDir_mapX() returns an + * absolute path, which is only true under PERL_IMPLICIT_SYS when + * we use the virtualization code from win32/vdir.h. + * Without it PerlDir_mapX() is a no-op and we need to use the same + * code as we use for Cygwin. + */ +#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS) + char buffer[2*MAX_PATH]; +#endif + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetFullPathName($filename)"); + +#if __CYGWIN__ || !defined(PERL_IMPLICIT_SYS) + if (IsWin2000()) { + WCHAR *filename = sv_to_wstr(aTHX_ ST(0)); + WCHAR full[2*MAX_PATH]; + DWORD len = GetFullPathNameW(filename, countof(full), full, NULL); + Safefree(filename); + if (len == 0 || len >= countof(full)) + XSRETURN_EMPTY; + ansi = fullname = my_ansipath(full); + } + else { + DWORD len = GetFullPathNameA(SvPV_nolen(ST(0)), countof(buffer), buffer, NULL); + if (len == 0 || len >= countof(buffer)) + XSRETURN_EMPTY; + fullname = buffer; + } +#else + /* Don't use my_ansipath() unless the $filename argument is in Unicode. + * If the relative path doesn't exist, GetShortPathName() will fail and + * my_ansipath() will use the long name with replacement characters. + * In that case we will be better off using PerlDir_mapA(), which + * already uses the ANSI name of the current directory. + * + * XXX The one missing case is where we could downgrade $filename + * XXX from UTF8 into the current codepage. + */ + if (IsWin2000() && SvUTF8(ST(0))) { + WCHAR *filename = sv_to_wstr(aTHX_ ST(0)); + WCHAR *mappedname = PerlDir_mapW(filename); + Safefree(filename); + ansi = fullname = my_ansipath(mappedname); + } + else { + fullname = PerlDir_mapA(SvPV_nolen(ST(0))); + } +# if PERL_VERSION < 8 + { + /* PerlDir_mapX() in Perl 5.6 used to return forward slashes */ + char *str = fullname; + while (*str) { + if (*str == '/') + *str = '\\'; + ++str; + } + } +# endif +#endif + + /* GetFullPathName() on Windows NT drops trailing backslash */ + if (g_osver.dwMajorVersion == 4 && *fullname) { + STRLEN len; + char *pv = SvPV(ST(0), len); + char *lastchar = fullname + strlen(fullname) - 1; + /* If ST(0) ends with a slash, but fullname doesn't ... */ + if (len && (pv[len-1] == '/' || pv[len-1] == '\\') && *lastchar != '\\') { + /* fullname is the MAX_PATH+1 sized buffer returned from PerlDir_mapA() + * or the 2*MAX_PATH sized local buffer in the __CYGWIN__ case. + */ + strcpy(lastchar+1, "\\"); + } + } + + if (GIMME_V == G_ARRAY) { + char *filepart = strrchr(fullname, '\\'); + + EXTEND(SP,1); + if (filepart) { + XST_mPV(1, ++filepart); + *filepart = '\0'; + } + else { + XST_mPVN(1, "", 0); + } + items = 2; + } + XST_mPV(0, fullname); + + if (ansi) + Safefree(ansi); + XSRETURN(items); +} + +XS(w32_GetLongPathName) +{ + dXSARGS; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetLongPathName($pathname)"); + + if (IsWin2000()) { + WCHAR *wstr = sv_to_wstr(aTHX_ ST(0)); + WCHAR wide_path[MAX_PATH+1]; + WCHAR *long_path; + + wcscpy(wide_path, wstr); + Safefree(wstr); + long_path = my_longpathW(wide_path); + if (long_path) { + ST(0) = wstr_to_sv(aTHX_ long_path); + XSRETURN(1); + } + } + else { + SV *path; + char tmpbuf[MAX_PATH+1]; + char *pathstr; + STRLEN len; + + path = ST(0); + pathstr = SvPV(path,len); + strcpy(tmpbuf, pathstr); + pathstr = my_longpathA(tmpbuf); + if (pathstr) { + ST(0) = sv_2mortal(newSVpvn(pathstr, strlen(pathstr))); + XSRETURN(1); + } + } + XSRETURN_EMPTY; +} + +XS(w32_GetANSIPathName) +{ + dXSARGS; + WCHAR *wide_path; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::GetANSIPathName($pathname)"); + + wide_path = sv_to_wstr(aTHX_ ST(0)); + ST(0) = wstr_to_ansipath(aTHX_ wide_path); + Safefree(wide_path); + XSRETURN(1); +} + +XS(w32_Sleep) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::Sleep($milliseconds)"); + Sleep((DWORD)SvIV(ST(0))); + XSRETURN_YES; +} + +XS(w32_CopyFile) +{ + dXSARGS; + BOOL bResult; + char szSourceFile[MAX_PATH+1]; + + if (items != 3) + Perl_croak(aTHX_ "usage: Win32::CopyFile($from, $to, $overwrite)"); + strcpy(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(0)))); + bResult = CopyFileA(szSourceFile, PerlDir_mapA(SvPV_nolen(ST(1))), !SvTRUE(ST(2))); + if (bResult) + XSRETURN_YES; + XSRETURN_NO; +} + +XS(w32_OutputDebugString) +{ + dXSARGS; + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::OutputDebugString($string)"); + + if (SvUTF8(ST(0))) { + WCHAR *str = sv_to_wstr(aTHX_ ST(0)); + OutputDebugStringW(str); + Safefree(str); + } + else + OutputDebugStringA(SvPV_nolen(ST(0))); + + XSRETURN_EMPTY; +} + +XS(w32_GetCurrentProcessId) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(GetCurrentProcessId()); +} + +XS(w32_GetCurrentThreadId) +{ + dXSARGS; + EXTEND(SP,1); + XSRETURN_IV(GetCurrentThreadId()); +} + +XS(w32_CreateDirectory) +{ + dXSARGS; + BOOL result; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::CreateDirectory($dir)"); + + if (IsWin2000() && SvUTF8(ST(0))) { + WCHAR *dir = sv_to_wstr(aTHX_ ST(0)); + result = CreateDirectoryW(dir, NULL); + Safefree(dir); + } + else { + result = CreateDirectoryA(SvPV_nolen(ST(0)), NULL); + } + + ST(0) = boolSV(result); + XSRETURN(1); +} + +XS(w32_CreateFile) +{ + dXSARGS; + HANDLE handle; + + if (items != 1) + Perl_croak(aTHX_ "usage: Win32::CreateFile($file)"); + + if (IsWin2000() && SvUTF8(ST(0))) { + WCHAR *file = sv_to_wstr(aTHX_ ST(0)); + handle = CreateFileW(file, GENERIC_WRITE, FILE_SHARE_WRITE, + NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL); + Safefree(file); + } + else { + handle = CreateFileA(SvPV_nolen(ST(0)), GENERIC_WRITE, FILE_SHARE_WRITE, + NULL, CREATE_NEW, FILE_ATTRIBUTE_NORMAL, NULL); + } + + if (handle != INVALID_HANDLE_VALUE) + CloseHandle(handle); + + ST(0) = boolSV(handle != INVALID_HANDLE_VALUE); + XSRETURN(1); +} + +MODULE = Win32 PACKAGE = Win32 + +PROTOTYPES: DISABLE + +BOOT: +{ + char *file = __FILE__; + + if (g_osver.dwOSVersionInfoSize == 0) { + g_osver.dwOSVersionInfoSize = sizeof(g_osver); + if (!GetVersionExA((OSVERSIONINFOA*)&g_osver)) { + g_osver_ex = FALSE; + g_osver.dwOSVersionInfoSize = sizeof(OSVERSIONINFOA); + GetVersionExA((OSVERSIONINFOA*)&g_osver); + } + } + + newXS("Win32::LookupAccountName", w32_LookupAccountName, file); + newXS("Win32::LookupAccountSID", w32_LookupAccountSID, file); + newXS("Win32::InitiateSystemShutdown", w32_InitiateSystemShutdown, file); + newXS("Win32::AbortSystemShutdown", w32_AbortSystemShutdown, file); + newXS("Win32::ExpandEnvironmentStrings", w32_ExpandEnvironmentStrings, file); + newXS("Win32::MsgBox", w32_MsgBox, file); + newXS("Win32::LoadLibrary", w32_LoadLibrary, file); + newXS("Win32::FreeLibrary", w32_FreeLibrary, file); + newXS("Win32::GetProcAddress", w32_GetProcAddress, file); + newXS("Win32::RegisterServer", w32_RegisterServer, file); + newXS("Win32::UnregisterServer", w32_UnregisterServer, file); + newXS("Win32::GetArchName", w32_GetArchName, file); + newXS("Win32::GetChipName", w32_GetChipName, file); + newXS("Win32::GuidGen", w32_GuidGen, file); + newXS("Win32::GetFolderPath", w32_GetFolderPath, file); + newXS("Win32::IsAdminUser", w32_IsAdminUser, file); + newXS("Win32::GetFileVersion", w32_GetFileVersion, file); + + newXS("Win32::GetCwd", w32_GetCwd, file); + newXS("Win32::SetCwd", w32_SetCwd, file); + newXS("Win32::GetNextAvailDrive", w32_GetNextAvailDrive, file); + newXS("Win32::GetLastError", w32_GetLastError, file); + newXS("Win32::SetLastError", w32_SetLastError, file); + newXS("Win32::LoginName", w32_LoginName, file); + newXS("Win32::NodeName", w32_NodeName, file); + newXS("Win32::DomainName", w32_DomainName, file); + newXS("Win32::FsType", w32_FsType, file); + newXS("Win32::GetOSVersion", w32_GetOSVersion, file); + newXS("Win32::IsWinNT", w32_IsWinNT, file); + newXS("Win32::IsWin95", w32_IsWin95, file); + newXS("Win32::FormatMessage", w32_FormatMessage, file); + newXS("Win32::Spawn", w32_Spawn, file); + newXS("Win32::GetTickCount", w32_GetTickCount, file); + newXS("Win32::GetShortPathName", w32_GetShortPathName, file); + newXS("Win32::GetFullPathName", w32_GetFullPathName, file); + newXS("Win32::GetLongPathName", w32_GetLongPathName, file); + newXS("Win32::GetANSIPathName", w32_GetANSIPathName, file); + newXS("Win32::CopyFile", w32_CopyFile, file); + newXS("Win32::Sleep", w32_Sleep, file); + newXS("Win32::OutputDebugString", w32_OutputDebugString, file); + newXS("Win32::GetCurrentProcessId", w32_GetCurrentProcessId, file); + newXS("Win32::GetCurrentThreadId", w32_GetCurrentThreadId, file); + newXS("Win32::CreateDirectory", w32_CreateDirectory, file); + newXS("Win32::CreateFile", w32_CreateFile, file); +#ifdef __CYGWIN__ + newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file); +#endif + XSRETURN_YES; +} diff --git a/cpan/Win32/longpath.inc b/cpan/Win32/longpath.inc index ea6c1de..2e5fd84 100644 --- a/cpan/Win32/longpath.inc +++ b/cpan/Win32/longpath.inc @@ -1,111 +1,111 @@ -#ifndef isSLASH -#define isSLASH(c) ((c) == '/' || (c) == '\\') -#define SKIP_SLASHES(s) \ - STMT_START { \ - while (*(s) && isSLASH(*(s))) \ - ++(s); \ - } STMT_END -#define COPY_NONSLASHES(d,s) \ - STMT_START { \ - while (*(s) && !isSLASH(*(s))) \ - *(d)++ = *(s)++; \ - } STMT_END -#endif - -/* Find the longname of a given path. path is destructively modified. - * It should have space for at least MAX_PATH characters. */ - -CHAR_T * -LONGPATH(CHAR_T *path) -{ - WIN32_FIND_DATA_T fdata; - HANDLE fhand; - CHAR_T tmpbuf[MAX_PATH+1]; - CHAR_T *tmpstart = tmpbuf; - CHAR_T *start = path; - CHAR_T sep; - if (!path) - return NULL; - - /* drive prefix */ - if (isALPHA(path[0]) && path[1] == ':') { - start = path + 2; - *tmpstart++ = toupper(path[0]); - *tmpstart++ = ':'; - } - /* UNC prefix */ - else if (isSLASH(path[0]) && isSLASH(path[1])) { - start = path + 2; - *tmpstart++ = path[0]; - *tmpstart++ = path[1]; - SKIP_SLASHES(start); - COPY_NONSLASHES(tmpstart,start); /* copy machine name */ - if (*start) { - *tmpstart++ = *start++; - SKIP_SLASHES(start); - COPY_NONSLASHES(tmpstart,start); /* copy share name */ - } - } - *tmpstart = '\0'; - while (*start) { - /* copy initial slash, if any */ - if (isSLASH(*start)) { - *tmpstart++ = *start++; - *tmpstart = '\0'; - SKIP_SLASHES(start); - } - - /* FindFirstFile() expands "." and "..", so we need to pass - * those through unmolested */ - if (*start == '.' - && (!start[1] || isSLASH(start[1]) - || (start[1] == '.' && (!start[2] || isSLASH(start[2]))))) - { - COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */ - *tmpstart = '\0'; - continue; - } - - /* if this is the end, bust outta here */ - if (!*start) - break; - - /* now we're at a non-slash; walk up to next slash */ - while (*start && !isSLASH(*start)) - ++start; - - /* stop and find full name of component */ - sep = *start; - *start = '\0'; - fhand = FN_FINDFIRSTFILE(path,&fdata); - *start = sep; - if (fhand != INVALID_HANDLE_VALUE) { - STRLEN len = FN_STRLEN(fdata.cFileName); - if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) { - FN_STRCPY(tmpstart, fdata.cFileName); - tmpstart += len; - FindClose(fhand); - } - else { - FindClose(fhand); - errno = ERANGE; - return NULL; - } - } - else { - /* failed a step, just return without side effects */ - /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/ - errno = EINVAL; - return NULL; - } - } - FN_STRCPY(path,tmpbuf); - return path; -} - -#undef CHAR_T -#undef WIN32_FIND_DATA_T -#undef FN_FINDFIRSTFILE -#undef FN_STRLEN -#undef FN_STRCPY -#undef LONGPATH +#ifndef isSLASH +#define isSLASH(c) ((c) == '/' || (c) == '\\') +#define SKIP_SLASHES(s) \ + STMT_START { \ + while (*(s) && isSLASH(*(s))) \ + ++(s); \ + } STMT_END +#define COPY_NONSLASHES(d,s) \ + STMT_START { \ + while (*(s) && !isSLASH(*(s))) \ + *(d)++ = *(s)++; \ + } STMT_END +#endif + +/* Find the longname of a given path. path is destructively modified. + * It should have space for at least MAX_PATH characters. */ + +CHAR_T * +LONGPATH(CHAR_T *path) +{ + WIN32_FIND_DATA_T fdata; + HANDLE fhand; + CHAR_T tmpbuf[MAX_PATH+1]; + CHAR_T *tmpstart = tmpbuf; + CHAR_T *start = path; + CHAR_T sep; + if (!path) + return NULL; + + /* drive prefix */ + if (isALPHA(path[0]) && path[1] == ':') { + start = path + 2; + *tmpstart++ = toupper(path[0]); + *tmpstart++ = ':'; + } + /* UNC prefix */ + else if (isSLASH(path[0]) && isSLASH(path[1])) { + start = path + 2; + *tmpstart++ = path[0]; + *tmpstart++ = path[1]; + SKIP_SLASHES(start); + COPY_NONSLASHES(tmpstart,start); /* copy machine name */ + if (*start) { + *tmpstart++ = *start++; + SKIP_SLASHES(start); + COPY_NONSLASHES(tmpstart,start); /* copy share name */ + } + } + *tmpstart = '\0'; + while (*start) { + /* copy initial slash, if any */ + if (isSLASH(*start)) { + *tmpstart++ = *start++; + *tmpstart = '\0'; + SKIP_SLASHES(start); + } + + /* FindFirstFile() expands "." and "..", so we need to pass + * those through unmolested */ + if (*start == '.' + && (!start[1] || isSLASH(start[1]) + || (start[1] == '.' && (!start[2] || isSLASH(start[2]))))) + { + COPY_NONSLASHES(tmpstart,start); /* copy "." or ".." */ + *tmpstart = '\0'; + continue; + } + + /* if this is the end, bust outta here */ + if (!*start) + break; + + /* now we're at a non-slash; walk up to next slash */ + while (*start && !isSLASH(*start)) + ++start; + + /* stop and find full name of component */ + sep = *start; + *start = '\0'; + fhand = FN_FINDFIRSTFILE(path,&fdata); + *start = sep; + if (fhand != INVALID_HANDLE_VALUE) { + STRLEN len = FN_STRLEN(fdata.cFileName); + if ((STRLEN)(tmpbuf + sizeof(tmpbuf) - tmpstart) > len) { + FN_STRCPY(tmpstart, fdata.cFileName); + tmpstart += len; + FindClose(fhand); + } + else { + FindClose(fhand); + errno = ERANGE; + return NULL; + } + } + else { + /* failed a step, just return without side effects */ + /*PerlIO_printf(Perl_debug_log, "Failed to find %s\n", path);*/ + errno = EINVAL; + return NULL; + } + } + FN_STRCPY(path,tmpbuf); + return path; +} + +#undef CHAR_T +#undef WIN32_FIND_DATA_T +#undef FN_FINDFIRSTFILE +#undef FN_STRLEN +#undef FN_STRCPY +#undef LONGPATH diff --git a/cpan/Win32/t/CreateFile.t b/cpan/Win32/t/CreateFile.t index ee1bf46..63ce316 100644 --- a/cpan/Win32/t/CreateFile.t +++ b/cpan/Win32/t/CreateFile.t @@ -1,31 +1,31 @@ -use strict; -use Test; -use Win32; - -my $path = "testing-$$"; -rmdir($path) if -d $path; -unlink($path) if -f $path; - -plan tests => 15; - -ok(!-d $path); -ok(!-f $path); - -ok(Win32::CreateDirectory($path)); -ok(-d $path); - -ok(!Win32::CreateDirectory($path)); -ok(!Win32::CreateFile($path)); - -ok(rmdir($path)); -ok(!-d $path); - -ok(Win32::CreateFile($path)); -ok(-f $path); -ok(-s $path, 0); - -ok(!Win32::CreateDirectory($path)); -ok(!Win32::CreateFile($path)); - -ok(unlink($path)); -ok(!-f $path); +use strict; +use Test; +use Win32; + +my $path = "testing-$$"; +rmdir($path) if -d $path; +unlink($path) if -f $path; + +plan tests => 15; + +ok(!-d $path); +ok(!-f $path); + +ok(Win32::CreateDirectory($path)); +ok(-d $path); + +ok(!Win32::CreateDirectory($path)); +ok(!Win32::CreateFile($path)); + +ok(rmdir($path)); +ok(!-d $path); + +ok(Win32::CreateFile($path)); +ok(-f $path); +ok(-s $path, 0); + +ok(!Win32::CreateDirectory($path)); +ok(!Win32::CreateFile($path)); + +ok(unlink($path)); +ok(!-f $path); diff --git a/cpan/Win32/t/ExpandEnvironmentStrings.t b/cpan/Win32/t/ExpandEnvironmentStrings.t index b57b47c..853be4a 100644 --- a/cpan/Win32/t/ExpandEnvironmentStrings.t +++ b/cpan/Win32/t/ExpandEnvironmentStrings.t @@ -1,7 +1,7 @@ -use strict; -use Test; -use Win32; - -plan tests => 1; - -ok(Win32::ExpandEnvironmentStrings("%WINDIR%"), $ENV{WINDIR}); +use strict; +use Test; +use Win32; + +plan tests => 1; + +ok(Win32::ExpandEnvironmentStrings("%WINDIR%"), $ENV{WINDIR}); diff --git a/cpan/Win32/t/GetCurrentThreadId.t b/cpan/Win32/t/GetCurrentThreadId.t index ce98f3e..6117e3e 100644 --- a/cpan/Win32/t/GetCurrentThreadId.t +++ b/cpan/Win32/t/GetCurrentThreadId.t @@ -1,38 +1,38 @@ -use strict; -use Config qw(%Config); -use Test; -use Win32; - -my $fork_emulation = $Config{ccflags} =~ /PERL_IMPLICIT_SYS/; - -my $tests = $fork_emulation ? 4 : 2; -plan tests => $tests; - -my $pid = $$+0; # make sure we don't copy any magic to $pid - -if ($^O eq "cygwin") { - skip(!defined &Cygwin::pid_to_winpid, - Cygwin::pid_to_winpid($pid), - Win32::GetCurrentProcessId()); -} -else { - ok($pid, Win32::GetCurrentProcessId()); -} - -if ($fork_emulation) { - # This test relies on the implementation detail that the fork() emulation - # uses the negative value of the thread id as a pseudo process id. - if (my $child = fork) { - waitpid($child, 0); - exit 0; - } - ok(-$$, Win32::GetCurrentThreadId()); - - # GetCurrentProcessId() should still return the real PID - ok($pid, Win32::GetCurrentProcessId()); - ok($$ != Win32::GetCurrentProcessId()); -} -else { - # here we just want to see something. - ok(Win32::GetCurrentThreadId() > 0); -} +use strict; +use Config qw(%Config); +use Test; +use Win32; + +my $fork_emulation = $Config{ccflags} =~ /PERL_IMPLICIT_SYS/; + +my $tests = $fork_emulation ? 4 : 2; +plan tests => $tests; + +my $pid = $$+0; # make sure we don't copy any magic to $pid + +if ($^O eq "cygwin") { + skip(!defined &Cygwin::pid_to_winpid, + Cygwin::pid_to_winpid($pid), + Win32::GetCurrentProcessId()); +} +else { + ok($pid, Win32::GetCurrentProcessId()); +} + +if ($fork_emulation) { + # This test relies on the implementation detail that the fork() emulation + # uses the negative value of the thread id as a pseudo process id. + if (my $child = fork) { + waitpid($child, 0); + exit 0; + } + ok(-$$, Win32::GetCurrentThreadId()); + + # GetCurrentProcessId() should still return the real PID + ok($pid, Win32::GetCurrentProcessId()); + ok($$ != Win32::GetCurrentProcessId()); +} +else { + # here we just want to see something. + ok(Win32::GetCurrentThreadId() > 0); +} diff --git a/cpan/Win32/t/GetFileVersion.t b/cpan/Win32/t/GetFileVersion.t index b9e51f8..6e42fb7 100644 --- a/cpan/Win32/t/GetFileVersion.t +++ b/cpan/Win32/t/GetFileVersion.t @@ -1,18 +1,18 @@ -use strict; -use Test; -use Win32; - -unless (defined &Win32::BuildNumber) { - print "1..0 # Skip: Only ActivePerl seems to set the perl.exe fileversion\n"; - exit; -} - -plan tests => 2; - -my @version = Win32::GetFileVersion($^X); -my $version = $version[0] + $version[1] / 1000 + $version[2] / 1000000; - -# numify $] because it is a version object in 5.10 which will stringify with trailing 0s -ok($version, 0+$]); - -ok($version[3], int(Win32::BuildNumber())); +use strict; +use Test; +use Win32; + +unless (defined &Win32::BuildNumber) { + print "1..0 # Skip: Only ActivePerl seems to set the perl.exe fileversion\n"; + exit; +} + +plan tests => 2; + +my @version = Win32::GetFileVersion($^X); +my $version = $version[0] + $version[1] / 1000 + $version[2] / 1000000; + +# numify $] because it is a version object in 5.10 which will stringify with trailing 0s +ok($version, 0+$]); + +ok($version[3], int(Win32::BuildNumber())); diff --git a/cpan/Win32/t/GetFolderPath.t b/cpan/Win32/t/GetFolderPath.t index c010c25..ad8df99 100644 --- a/cpan/Win32/t/GetFolderPath.t +++ b/cpan/Win32/t/GetFolderPath.t @@ -1,8 +1,8 @@ -use strict; -use Test; -use Win32; - -plan tests => 1; - -# "windir" exists back to Win9X; "SystemRoot" only exists on WinNT and later. -ok(Win32::GetFolderPath(Win32::CSIDL_WINDOWS), $ENV{WINDIR}); +use strict; +use Test; +use Win32; + +plan tests => 1; + +# "windir" exists back to Win9X; "SystemRoot" only exists on WinNT and later. +ok(Win32::GetFolderPath(Win32::CSIDL_WINDOWS), $ENV{WINDIR}); diff --git a/cpan/Win32/t/GetFullPathName.t b/cpan/Win32/t/GetFullPathName.t index ec716d1..15542e5 100644 --- a/cpan/Win32/t/GetFullPathName.t +++ b/cpan/Win32/t/GetFullPathName.t @@ -1,34 +1,34 @@ -use strict; -use Test; -use Win32; - -plan tests => 16; - -my $cwd = Win32::GetCwd; -my @cwd = split/\\/, $cwd; -my $file = pop @cwd; -my $dir = join('\\', @cwd); - -ok(scalar Win32::GetFullPathName('.'), $cwd); -ok((Win32::GetFullPathName('.'))[0], "$dir\\"); -ok((Win32::GetFullPathName('.'))[1], $file); - -ok((Win32::GetFullPathName('./'))[0], "$cwd\\"); -ok((Win32::GetFullPathName('.\\'))[0], "$cwd\\"); -ok((Win32::GetFullPathName('./'))[1], ""); - -ok(scalar Win32::GetFullPathName($cwd), $cwd); -ok((Win32::GetFullPathName($cwd))[0], "$dir\\"); -ok((Win32::GetFullPathName($cwd))[1], $file); - -ok(scalar Win32::GetFullPathName(substr($cwd,2)), $cwd); -ok((Win32::GetFullPathName(substr($cwd,2)))[0], "$dir\\"); -ok((Win32::GetFullPathName(substr($cwd,2)))[1], $file); - -ok(scalar Win32::GetFullPathName('/Foo Bar/'), substr($cwd,0,2)."\\Foo Bar\\"); - -chdir($dir); -ok(scalar Win32::GetFullPathName('.'), $dir); - -ok((Win32::GetFullPathName($file))[0], "$dir\\"); -ok((Win32::GetFullPathName($file))[1], $file); +use strict; +use Test; +use Win32; + +plan tests => 16; + +my $cwd = Win32::GetCwd; +my @cwd = split/\\/, $cwd; +my $file = pop @cwd; +my $dir = join('\\', @cwd); + +ok(scalar Win32::GetFullPathName('.'), $cwd); +ok((Win32::GetFullPathName('.'))[0], "$dir\\"); +ok((Win32::GetFullPathName('.'))[1], $file); + +ok((Win32::GetFullPathName('./'))[0], "$cwd\\"); +ok((Win32::GetFullPathName('.\\'))[0], "$cwd\\"); +ok((Win32::GetFullPathName('./'))[1], ""); + +ok(scalar Win32::GetFullPathName($cwd), $cwd); +ok((Win32::GetFullPathName($cwd))[0], "$dir\\"); +ok((Win32::GetFullPathName($cwd))[1], $file); + +ok(scalar Win32::GetFullPathName(substr($cwd,2)), $cwd); +ok((Win32::GetFullPathName(substr($cwd,2)))[0], "$dir\\"); +ok((Win32::GetFullPathName(substr($cwd,2)))[1], $file); + +ok(scalar Win32::GetFullPathName('/Foo Bar/'), substr($cwd,0,2)."\\Foo Bar\\"); + +chdir($dir); +ok(scalar Win32::GetFullPathName('.'), $dir); + +ok((Win32::GetFullPathName($file))[0], "$dir\\"); +ok((Win32::GetFullPathName($file))[1], $file); diff --git a/cpan/Win32/t/GetLongPathName.t b/cpan/Win32/t/GetLongPathName.t index 9269346..8ad51db 100644 --- a/cpan/Win32/t/GetLongPathName.t +++ b/cpan/Win32/t/GetLongPathName.t @@ -1,54 +1,54 @@ -use strict; -use Test; -use Win32; - -my @paths = qw( - / - // - . - .. - c: - c:/ - c:./ - c:/. - c:/.. - c:./.. - //./ - //. - //.. - //./.. -); -push @paths, map { my $x = $_; $x =~ s,/,\\,g; $x } @paths; -push @paths, qw( - ../\ - c:.\\../\ - c:/\..// - c://.\/./\ - \\.\\../\ - //\..// - //.\/./\ -); - -my $drive = $ENV{SYSTEMDRIVE}; -if ($drive) { - for (@paths) { - s/^c:/$drive/; - } - push @paths, $ENV{SYSTEMROOT} if $ENV{SYSTEMROOT}; -} -my %expect; -@expect{@paths} = map { my $x = $_; - $x =~ s,(.[/\\])[/\\]+,$1,g; - $x =~ s,^(\w):,\U$1:,; - $x } @paths; - -plan tests => scalar(@paths); - -my $i = 1; -for (@paths) { - my $got = Win32::GetLongPathName($_); - print "# '$_' => expect '$expect{$_}' => got '$got'\n"; - print "not " unless $expect{$_} eq $got; - print "ok $i\n"; - ++$i; -} +use strict; +use Test; +use Win32; + +my @paths = qw( + / + // + . + .. + c: + c:/ + c:./ + c:/. + c:/.. + c:./.. + //./ + //. + //.. + //./.. +); +push @paths, map { my $x = $_; $x =~ s,/,\\,g; $x } @paths; +push @paths, qw( + ../\ + c:.\\../\ + c:/\..// + c://.\/./\ + \\.\\../\ + //\..// + //.\/./\ +); + +my $drive = $ENV{SYSTEMDRIVE}; +if ($drive) { + for (@paths) { + s/^c:/$drive/; + } + push @paths, $ENV{SYSTEMROOT} if $ENV{SYSTEMROOT}; +} +my %expect; +@expect{@paths} = map { my $x = $_; + $x =~ s,(.[/\\])[/\\]+,$1,g; + $x =~ s,^(\w):,\U$1:,; + $x } @paths; + +plan tests => scalar(@paths); + +my $i = 1; +for (@paths) { + my $got = Win32::GetLongPathName($_); + print "# '$_' => expect '$expect{$_}' => got '$got'\n"; + print "not " unless $expect{$_} eq $got; + print "ok $i\n"; + ++$i; +} diff --git a/cpan/Win32/t/GetOSName.t b/cpan/Win32/t/GetOSName.t index 39db36e..a7ed9d5 100644 --- a/cpan/Win32/t/GetOSName.t +++ b/cpan/Win32/t/GetOSName.t @@ -1,39 +1,39 @@ -use strict; -use Test; -use Win32; - -my @tests = ( - # $id, $major, $minor, $pt, $build, $tag - [ "WinWin32s", 0 ], - [ "Win95", 1, 4, 0 ], - [ "Win95", 1, 4, 0, 0, 67109814, "(a)" ], - [ "Win95", 1, 4, 0, 0, 67306684, "(b1)" ], - [ "Win95", 1, 4, 0, 0, 67109975, "(b2)" ], - [ "Win98", 1, 4, 10 ], - [ "Win98", 1, 4, 10, 0, 67766446, "(2nd ed)" ], - [ "WinMe", 1, 4, 90 ], - [ "WinNT3.51", 2, 3, 51 ], - [ "WinNT4", 2, 4, 0 ], - [ "Win2000", 2, 5, 0 ], - [ "WinXP/.Net", 2, 5, 1 ], - [ "Win2003", 2, 5, 2 ], - [ "WinVista", 2, 6, 0, 1 ], - [ "Win2008", 2, 6, 0, 2 ], - [ "Win7", 2, 6, 1 ], -); - -plan tests => 2*scalar(@tests) + 1; - -# Test internal implementation function -for my $test (@tests) { - my($expect, $id, $major, $minor, $pt, $build, $tag) = @$test; - my($os, $desc) = Win32::_GetOSName("", $major, $minor, $build||0, $id, $pt); - ok($os, $expect); - ok($desc, $tag||""); -} - -# Does Win32::GetOSName() return the correct value for the current OS? -my(undef, $major, $minor, $build, $id, undef, undef, undef, $pt) - = Win32::GetOSVersion(); -my($os, $desc) = Win32::_GetOSName("", $major, $minor, $build, $id, $pt); -ok(scalar Win32::GetOSName(), $os); +use strict; +use Test; +use Win32; + +my @tests = ( + # $id, $major, $minor, $pt, $build, $tag + [ "WinWin32s", 0 ], + [ "Win95", 1, 4, 0 ], + [ "Win95", 1, 4, 0, 0, 67109814, "(a)" ], + [ "Win95", 1, 4, 0, 0, 67306684, "(b1)" ], + [ "Win95", 1, 4, 0, 0, 67109975, "(b2)" ], + [ "Win98", 1, 4, 10 ], + [ "Win98", 1, 4, 10, 0, 67766446, "(2nd ed)" ], + [ "WinMe", 1, 4, 90 ], + [ "WinNT3.51", 2, 3, 51 ], + [ "WinNT4", 2, 4, 0 ], + [ "Win2000", 2, 5, 0 ], + [ "WinXP/.Net", 2, 5, 1 ], + [ "Win2003", 2, 5, 2 ], + [ "WinVista", 2, 6, 0, 1 ], + [ "Win2008", 2, 6, 0, 2 ], + [ "Win7", 2, 6, 1 ], +); + +plan tests => 2*scalar(@tests) + 1; + +# Test internal implementation function +for my $test (@tests) { + my($expect, $id, $major, $minor, $pt, $build, $tag) = @$test; + my($os, $desc) = Win32::_GetOSName("", $major, $minor, $build||0, $id, $pt); + ok($os, $expect); + ok($desc, $tag||""); +} + +# Does Win32::GetOSName() return the correct value for the current OS? +my(undef, $major, $minor, $build, $id, undef, undef, undef, $pt) + = Win32::GetOSVersion(); +my($os, $desc) = Win32::_GetOSName("", $major, $minor, $build, $id, $pt); +ok(scalar Win32::GetOSName(), $os); diff --git a/cpan/Win32/t/GetOSVersion.t b/cpan/Win32/t/GetOSVersion.t index cb3f364..0038ef7 100644 --- a/cpan/Win32/t/GetOSVersion.t +++ b/cpan/Win32/t/GetOSVersion.t @@ -1,11 +1,11 @@ -use strict; -use Test; -use Win32; - -plan tests => 1; - -my $scalar = Win32::GetOSVersion(); -my @array = Win32::GetOSVersion(); - -print "not " unless $scalar == $array[4]; -print "ok 1\n"; +use strict; +use Test; +use Win32; + +plan tests => 1; + +my $scalar = Win32::GetOSVersion(); +my @array = Win32::GetOSVersion(); + +print "not " unless $scalar == $array[4]; +print "ok 1\n"; diff --git a/cpan/Win32/t/GetShortPathName.t b/cpan/Win32/t/GetShortPathName.t index 4553854..34adf96 100644 --- a/cpan/Win32/t/GetShortPathName.t +++ b/cpan/Win32/t/GetShortPathName.t @@ -1,20 +1,20 @@ -use strict; -use Test; -use Win32; - -my $path = "Long Path $$"; -unlink($path); -END { unlink $path } - -plan tests => 5; - -Win32::CreateFile($path); -ok(-f $path); - -my $short = Win32::GetShortPathName($path); -ok($short, qr/^\S{1,8}(\.\S{1,3})?$/); -ok(-f $short); - -unlink($path); -ok(!-f $path); -ok(!defined Win32::GetShortPathName($path)); +use strict; +use Test; +use Win32; + +my $path = "Long Path $$"; +unlink($path); +END { unlink $path } + +plan tests => 5; + +Win32::CreateFile($path); +ok(-f $path); + +my $short = Win32::GetShortPathName($path); +ok($short, qr/^\S{1,8}(\.\S{1,3})?$/); +ok(-f $short); + +unlink($path); +ok(!-f $path); +ok(!defined Win32::GetShortPathName($path)); diff --git a/cpan/Win32/t/GuidGen.t b/cpan/Win32/t/GuidGen.t index 7011e2f..9ee8ede 100644 --- a/cpan/Win32/t/GuidGen.t +++ b/cpan/Win32/t/GuidGen.t @@ -1,15 +1,15 @@ -use strict; -use Test; -use Win32; - -plan tests => 3; - -my $guid1 = Win32::GuidGen(); -my $guid2 = Win32::GuidGen(); - -# {FB9586CD-273B-43BE-A20C-485A6BD4FCD6} -ok($guid1, qr/^{\w{8}(-\w{4}){3}-\w{12}}$/); -ok($guid2, qr/^{\w{8}(-\w{4}){3}-\w{12}}$/); - -# Every GUID is unique -ok($guid1 ne $guid2); +use strict; +use Test; +use Win32; + +plan tests => 3; + +my $guid1 = Win32::GuidGen(); +my $guid2 = Win32::GuidGen(); + +# {FB9586CD-273B-43BE-A20C-485A6BD4FCD6} +ok($guid1, qr/^{\w{8}(-\w{4}){3}-\w{12}}$/); +ok($guid2, qr/^{\w{8}(-\w{4}){3}-\w{12}}$/); + +# Every GUID is unique +ok($guid1 ne $guid2); diff --git a/cpan/Win32/t/Names.t b/cpan/Win32/t/Names.t index 509751d..ecab79f 100644 --- a/cpan/Win32/t/Names.t +++ b/cpan/Win32/t/Names.t @@ -1,56 +1,56 @@ -use strict; -BEGIN { - eval "use Test::More"; - return unless $@; - print "1..0 # Skip: Test requires Test::More module\n"; - exit 0; -} -use Win32; - -my $tests = 14; -$tests += 2 if Win32::IsWinNT(); - -plan tests => $tests; - -# test Win32::DomainName() -if (Win32::IsWinNT()) { - my $domain = eval { Win32::DomainName() }; - SKIP: { - skip('The Workstation service has not been started', 2) if (Win32::GetLastError() == 2138); - is( $@, '', "Win32::DomainName()" ); - like( $domain, '/^[a-zA-Z0-9!@#$%^&()_\'{}.~-]+$/', " - checking returned domain" ); - } -} - -# test Win32::GetArchName() -my $archname = eval { Win32::GetArchName() }; -is( $@, '', "Win32::GetArchName()" ); -cmp_ok( length($archname), '>=', 3, " - checking returned architecture name" ); - -# test Win32::GetChipName() -my $chipname = eval { Win32::GetChipName() }; -is( $@, '', "Win32::GetChipName()" ); -cmp_ok( length($chipname), '>=', 3, " - checking returned chip name" ); - -# test Win32::GetOSName() -# - scalar context -my $osname = eval { Win32::GetOSName() }; -is( $@, '', "Win32::GetOSName() in scalar context" ); -cmp_ok( length($osname), '>', 3, " - checking returned OS name" ); - -# - list context -my ($osname2, $desc) = eval { Win32::GetOSName() }; -is( $@, '', "Win32::GetOSName() in list context" ); -cmp_ok( length($osname2), '>', 3, " - checking returned OS name" ); -ok( defined($desc), " - checking returned description" ); -is( $osname2, $osname, " - checking that OS name is the same in both calls" ); - -# test Win32::LoginName() -my $login = eval { Win32::LoginName() }; -is( $@, '', "Win32::LoginName()" ); -cmp_ok( length($login), '>', 1, " - checking returned login name" ); - -# test Win32::NodeName() -my $nodename = eval { Win32::NodeName() }; -is( $@, '', "Win32::NodeName()" ); -cmp_ok( length($nodename), '>', 1, " - checking returned node name" ); +use strict; +BEGIN { + eval "use Test::More"; + return unless $@; + print "1..0 # Skip: Test requires Test::More module\n"; + exit 0; +} +use Win32; + +my $tests = 14; +$tests += 2 if Win32::IsWinNT(); + +plan tests => $tests; + +# test Win32::DomainName() +if (Win32::IsWinNT()) { + my $domain = eval { Win32::DomainName() }; + SKIP: { + skip('The Workstation service has not been started', 2) if (Win32::GetLastError() == 2138); + is( $@, '', "Win32::DomainName()" ); + like( $domain, '/^[a-zA-Z0-9!@#$%^&()_\'{}.~-]+$/', " - checking returned domain" ); + } +} + +# test Win32::GetArchName() +my $archname = eval { Win32::GetArchName() }; +is( $@, '', "Win32::GetArchName()" ); +cmp_ok( length($archname), '>=', 3, " - checking returned architecture name" ); + +# test Win32::GetChipName() +my $chipname = eval { Win32::GetChipName() }; +is( $@, '', "Win32::GetChipName()" ); +cmp_ok( length($chipname), '>=', 3, " - checking returned chip name" ); + +# test Win32::GetOSName() +# - scalar context +my $osname = eval { Win32::GetOSName() }; +is( $@, '', "Win32::GetOSName() in scalar context" ); +cmp_ok( length($osname), '>', 3, " - checking returned OS name" ); + +# - list context +my ($osname2, $desc) = eval { Win32::GetOSName() }; +is( $@, '', "Win32::GetOSName() in list context" ); +cmp_ok( length($osname2), '>', 3, " - checking returned OS name" ); +ok( defined($desc), " - checking returned description" ); +is( $osname2, $osname, " - checking that OS name is the same in both calls" ); + +# test Win32::LoginName() +my $login = eval { Win32::LoginName() }; +is( $@, '', "Win32::LoginName()" ); +cmp_ok( length($login), '>', 1, " - checking returned login name" ); + +# test Win32::NodeName() +my $nodename = eval { Win32::NodeName() }; +is( $@, '', "Win32::NodeName()" ); +cmp_ok( length($nodename), '>', 1, " - checking returned node name" ); diff --git a/cpan/Win32/t/Unicode.t b/cpan/Win32/t/Unicode.t index 382b13a..3570142 100644 --- a/cpan/Win32/t/Unicode.t +++ b/cpan/Win32/t/Unicode.t @@ -1,85 +1,85 @@ -use strict; -use Test; -use Cwd qw(cwd); -use Win32; - -BEGIN { - unless (defined &Win32::BuildNumber && Win32::BuildNumber() >= 820 or $] >= 5.008009) { - print "1..0 # Skip: Needs ActivePerl 820 or Perl 5.8.9 or later\n"; - exit 0; - } - if ((((Win32::FsType())[1] & 4) == 0) || (Win32::FsType() =~ /^FAT/)) { - print "1..0 # Skip: Filesystem doesn't support Unicode\n"; - exit 0; - } - unless ((Win32::GetOSVersion())[1] > 4) { - print "1..0 # Skip: Unicode support requires Windows 2000 or later\n"; - exit 0; - } -} - -my $home = Win32::GetCwd(); -my $cwd = cwd(); # may be a Cygwin path -my $dir = "Foo \x{394}\x{419} Bar \x{5E7}\x{645} Baz"; -my $file = "$dir\\xyzzy \x{394}\x{419} plugh \x{5E7}\x{645}"; - -sub cleanup { - chdir($home); - my $ansi = Win32::GetANSIPathName($file); - unlink($ansi) if -f $ansi; - $ansi = Win32::GetANSIPathName($dir); - rmdir($ansi) if -d $ansi; -} - -cleanup(); -END { cleanup() } - -plan test => 12; - -# Create Unicode directory -Win32::CreateDirectory($dir); -ok(-d Win32::GetANSIPathName($dir)); - -# Create Unicode file -Win32::CreateFile($file); -ok(-f Win32::GetANSIPathName($file)); - -# readdir() returns ANSI form of Unicode filename -ok(opendir(my $dh, Win32::GetANSIPathName($dir))); -while ($_ = readdir($dh)) { - next if /^\./; - ok($file, Win32::GetLongPathName("$dir\\$_")); -} -closedir($dh); - -# Win32::GetLongPathName() of the absolute path restores the Unicode dir name -my $full = Win32::GetFullPathName($dir); -my $long = Win32::GetLongPathName($full); - -ok($long, Win32::GetLongPathName($home)."\\$dir"); - -# We can Win32::SetCwd() into the Unicode directory -ok(Win32::SetCwd($dir)); - -my $w32dir = Win32::GetCwd(); -# cwd() also returns a usable ANSI directory name -my $subdir = cwd(); - -# change back to home directory to make sure relative paths -# in @INC continue to work -ok(chdir($home)); -ok(Win32::GetCwd(), $home); - -ok(Win32::GetLongPathName($w32dir), $long); - -# cwd() on Cygwin returns a mapped path that we need to translate -# back to a Windows path. Invoking `cygpath` on $subdir doesn't work. -if ($^O eq "cygwin") { - $subdir = Cygwin::posix_to_win_path($subdir, 1); -} -$subdir =~ s,/,\\,g; -ok(Win32::GetLongPathName($subdir), $long); - -# We can chdir() into the Unicode directory if we use the ANSI name -ok(chdir(Win32::GetANSIPathName($dir))); -ok(Win32::GetLongPathName(Win32::GetCwd()), $long); +use strict; +use Test; +use Cwd qw(cwd); +use Win32; + +BEGIN { + unless (defined &Win32::BuildNumber && Win32::BuildNumber() >= 820 or $] >= 5.008009) { + print "1..0 # Skip: Needs ActivePerl 820 or Perl 5.8.9 or later\n"; + exit 0; + } + if ((((Win32::FsType())[1] & 4) == 0) || (Win32::FsType() =~ /^FAT/)) { + print "1..0 # Skip: Filesystem doesn't support Unicode\n"; + exit 0; + } + unless ((Win32::GetOSVersion())[1] > 4) { + print "1..0 # Skip: Unicode support requires Windows 2000 or later\n"; + exit 0; + } +} + +my $home = Win32::GetCwd(); +my $cwd = cwd(); # may be a Cygwin path +my $dir = "Foo \x{394}\x{419} Bar \x{5E7}\x{645} Baz"; +my $file = "$dir\\xyzzy \x{394}\x{419} plugh \x{5E7}\x{645}"; + +sub cleanup { + chdir($home); + my $ansi = Win32::GetANSIPathName($file); + unlink($ansi) if -f $ansi; + $ansi = Win32::GetANSIPathName($dir); + rmdir($ansi) if -d $ansi; +} + +cleanup(); +END { cleanup() } + +plan test => 12; + +# Create Unicode directory +Win32::CreateDirectory($dir); +ok(-d Win32::GetANSIPathName($dir)); + +# Create Unicode file +Win32::CreateFile($file); +ok(-f Win32::GetANSIPathName($file)); + +# readdir() returns ANSI form of Unicode filename +ok(opendir(my $dh, Win32::GetANSIPathName($dir))); +while ($_ = readdir($dh)) { + next if /^\./; + ok($file, Win32::GetLongPathName("$dir\\$_")); +} +closedir($dh); + +# Win32::GetLongPathName() of the absolute path restores the Unicode dir name +my $full = Win32::GetFullPathName($dir); +my $long = Win32::GetLongPathName($full); + +ok($long, Win32::GetLongPathName($home)."\\$dir"); + +# We can Win32::SetCwd() into the Unicode directory +ok(Win32::SetCwd($dir)); + +my $w32dir = Win32::GetCwd(); +# cwd() also returns a usable ANSI directory name +my $subdir = cwd(); + +# change back to home directory to make sure relative paths +# in @INC continue to work +ok(chdir($home)); +ok(Win32::GetCwd(), $home); + +ok(Win32::GetLongPathName($w32dir), $long); + +# cwd() on Cygwin returns a mapped path that we need to translate +# back to a Windows path. Invoking `cygpath` on $subdir doesn't work. +if ($^O eq "cygwin") { + $subdir = Cygwin::posix_to_win_path($subdir, 1); +} +$subdir =~ s,/,\\,g; +ok(Win32::GetLongPathName($subdir), $long); + +# We can chdir() into the Unicode directory if we use the ANSI name +ok(chdir(Win32::GetANSIPathName($dir))); +ok(Win32::GetLongPathName(Win32::GetCwd()), $long);