diff options
| author | Jan Dubois <jand@activestate.com> | 2010-12-08 15:45:06 -0800 |
|---|---|---|
| committer | Jan Dubois <jand@activestate.com> | 2010-12-08 15:45:06 -0800 |
| commit | d0eee3a13e6c5c945069261254b8febe4d8828fb (patch) | |
| tree | a90647b9c6fde6635630be47bb4f4fe5e5fb7dc0 | |
| parent | 14105dc655a9b7fd74a9e9080d28abab9bc3b794 (diff) | |
| parent | 0e5d25bf51a3de62b6938cc50b508a0107f024bb (diff) | |
| download | perl-d0eee3a13e6c5c945069261254b8febe4d8828fb.tar.gz | |
Merge branch 'blead' of ssh://perl5.git.perl.org/gitroot/perl into blead
69 files changed, 1856 insertions, 923 deletions
@@ -877,6 +877,7 @@ cpan/ExtUtils-CBuilder/t/00-have-compiler.t ExtUtils::CBuilder tests cpan/ExtUtils-CBuilder/t/01-basic.t tests for ExtUtils::CBuilder cpan/ExtUtils-CBuilder/t/02-link.t tests for ExtUtils::CBuilder cpan/ExtUtils-CBuilder/t/03-cplusplus.t tests for ExtUtils::CBuilder +cpan/ExtUtils-CBuilder/t/04-base.t tests for ExtUtils::CBuilder cpan/ExtUtils-Constant/lib/ExtUtils/Constant/Base.pm generate XS code to import C header constants cpan/ExtUtils-Constant/lib/ExtUtils/Constant.pm generate XS code to import C header constants cpan/ExtUtils-Constant/lib/ExtUtils/Constant/ProxySubs.pm generate XS code for proxy constants @@ -4652,6 +4653,7 @@ t/op/die_except.t See if die/eval avoids $@ clobberage t/op/die_exit.t See if die and exit status interaction works t/op/die_keeperr.t See if G_KEEPERR works for destructors t/op/die.t See if die works +t/op/die_unwind.t Check die/eval early-$@ backcompat hack t/op/dor.t See if defined-or (//) works t/op/do.t See if subroutines work t/op/each_array.t See if array iterators work diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index 773258aebe..08f7e2ba93 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -527,7 +527,7 @@ use File::Glob qw(:case); 'ExtUtils::CBuilder' => { 'MAINTAINER' => 'kwilliams', - 'DISTRIBUTION' => 'DAGOLDEN/ExtUtils-CBuilder-0.2703.tar.gz', + 'DISTRIBUTION' => 'DAGOLDEN/ExtUtils-CBuilder-0.2800.tar.gz', 'FILES' => q[cpan/ExtUtils-CBuilder], 'UPSTREAM' => 'cpan', }, @@ -1556,7 +1556,7 @@ use File::Glob qw(:case); 'Win32' => { 'MAINTAINER' => 'jand', - 'DISTRIBUTION' => "JDB/Win32-0.39.tar.gz", + 'DISTRIBUTION' => "JDB/Win32-0.40.tar.gz", 'FILES' => q[cpan/Win32], 'UPSTREAM' => 'cpan', }, diff --git a/README.win32 b/README.win32 index f314b9dd92..cbd42e7678 100644 --- a/README.win32 +++ b/README.win32 @@ -382,16 +382,6 @@ You may also need to comment out the C<DELAYLOAD = ...> line in the Makefile if you're using VC++ 6.0 without the latest service pack and the linker reports an internal error. -If you have either the source or a library that contains des_fcrypt(), -enable the appropriate option in the makefile. A ready-to-use version -of fcrypt.c, based on the version originally written by Eric Young at -ftp://ftp.funet.fi/pub/crypt/mirrors/dsi/libdes/, is bundled with the -distribution and CRYPT_SRC is set to use it. -Alternatively, if you have built a library that contains des_fcrypt(), -you can set CRYPT_LIB to point to the library name. -Perl will also build without des_fcrypt(), but the crypt() builtin will -fail at run time. - If you want build some core extensions statically into perl's dll, specify them in the STATIC_EXT macro. diff --git a/cpan/ExtUtils-CBuilder/Changes b/cpan/ExtUtils-CBuilder/Changes index e3e709daf2..b2d95fe508 100644 --- a/cpan/ExtUtils-CBuilder/Changes +++ b/cpan/ExtUtils-CBuilder/Changes @@ -1,5 +1,43 @@ Revision history for Perl extension ExtUtils::CBuilder. +0.2800 - Mon Dec 6 16:05:46 EST 2010 + + - No changes from 0.27_07 + +0.27_07 - Wed Sep 29 21:48:55 EDT 2010 + + Fixed: + + - Fixed t/02-link.t on perl < 5.8 + +0.27_06 - Mon Sep 27 15:29:54 EDT 2010 + + Fixed: + + - Preserves exit status on VMS [Craig Berry] + + - Fix Win32 split_like_shell escaping [Christian Walde] + +0.27_05 - Wed Jul 28 15:29:59 EDT 2010 + + Fixed: + + - Tests no longer fail if user has set the CC environment variable + +0.27_04 - Mon Jul 26 22:41:43 EDT 2010 + + Added: + - handle c compiler and c++ compiler separately + (adds requirement for IPC::Cmd) [Jens Rehsack] + + Others: + - rely on File::Temp::tempfile and File::Spec::tmpdir to + get unique file name for checking for compiler + [Jens Rehsack] + + - Code base modernization and substantial code coverage improvments + [Jim Keenan] + 0.2703 - Tue Mar 16 17:10:55 EDT 2010 Bugs fixed: @@ -239,7 +277,7 @@ Revision history for Perl extension ExtUtils::CBuilder. - Various parts of the code were looking for the CORE/ directory in $Config{archlib}, $Config{installarchlib}, and $Config{archlibexp}. - Only the latter is correct, so we use that everywhere now. + Only the latter is correct, so we use that everywhere now. [Curt Tilmes] - For Unix-ish platforms, link_executable() will now prefer diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm index 7620daf7d9..75fb366578 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder.pm @@ -5,7 +5,7 @@ use File::Path (); use File::Basename (); use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; $VERSION = eval $VERSION; # Okay, this is the brute-force method of finding out what kind of diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm index ea3e7dedc4..83319e8821 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Base.pm @@ -7,9 +7,27 @@ use Cwd (); use Config; use Text::ParseWords; use IO::File; +use Data::Dumper;$Data::Dumper::Indent=1; +use IPC::Cmd qw(can_run); +use File::Temp qw(tempfile); use vars qw($VERSION); -$VERSION = '0.2703_01'; +$VERSION = '0.2800'; + +# More details about C/C++ compilers: +# http://developers.sun.com/sunstudio/documentation/product/compiler.jsp +# http://gcc.gnu.org/ +# http://publib.boulder.ibm.com/infocenter/comphelp/v101v121/index.jsp +# http://msdn.microsoft.com/en-us/vstudio/default.aspx + +my %cc2cxx = ( + # first line order is important to support wrappers like in pkgsrc + cc => [ 'c++', 'CC', 'aCC', 'cxx', ], # Sun Studio, HP ANSI C/C++ Compilers + gcc => [ 'g++' ], # GNU Compiler Collection + xlc => [ 'xlC' ], # IBM C/C++ Set, xlc without thread-safety + xlc_r => [ 'xlC_r' ], # IBM C/C++ Set, xlc with thread-safety + cl => [ 'cl' ], # Microsoft Visual Studio +); sub new { my $class = shift; @@ -21,7 +39,37 @@ sub new { while (my ($k,$v) = each %Config) { $self->{config}{$k} = $v unless exists $self->{config}{$k}; } - $self->{config}{cc} = $ENV{CC} if exists $ENV{CC}; + $self->{config}{cc} = $ENV{CC} if defined $ENV{CC}; + $self->{config}{ccflags} = $ENV{CFLAGS} if defined $ENV{CFLAGS}; + $self->{config}{cxx} = $ENV{CXX} if defined $ENV{CXX}; + $self->{config}{cxxflags} = $ENV{CXXFLAGS} if defined $ENV{CXXFLAGS}; + $self->{config}{ld} = $ENV{LD} if defined $ENV{LD}; + $self->{config}{ldflags} = $ENV{LDFLAGS} if defined $ENV{LDFLAGS}; + + unless ( exists $self->{config}{cxx} ) { + my ($ccpath, $ccbase, $ccsfx ) = fileparse($self->{config}{cc}, qr/\.[^.]*/); + foreach my $cxx (@{$cc2cxx{$ccbase}}) { + if( can_run( File::Spec->catfile( $ccpath, $cxx, $ccsfx ) ) ) { + $self->{config}{cxx} = File::Spec->catfile( $ccpath, $cxx, $ccsfx ); + last; + } + if( can_run( File::Spec->catfile( $cxx, $ccsfx ) ) ) { + $self->{config}{cxx} = File::Spec->catfile( $cxx, $ccsfx ); + last; + } + if( can_run( $cxx ) ) { + $self->{config}{cxx} = $cxx; + last; + } + } + unless ( exists $self->{config}{cxx} ) { + $self->{config}{cxx} = $self->{config}{cc}; + my $cflags = $self->{config}{cflags}; + $self->{config}{cxxflags} = '-x c++'; + $self->{config}{cxxflags} .= " $cflags" if defined $cflags; + } + } + return $self; } @@ -29,7 +77,7 @@ sub find_perl_interpreter { my $perl; File::Spec->file_name_is_absolute($perl = $^X) or -f ($perl = $Config::Config{perlpath}) - or ($perl = $^X); + or ($perl = $^X); # XXX how about using IPC::Cmd::can_run here? return $perl; } @@ -47,6 +95,10 @@ sub cleanup { } } +sub get_config { + return %{ $_[0]->{config} }; +} + sub object_file { my ($self, $filename) = @_; @@ -87,81 +139,80 @@ sub compile { die "Missing 'source' argument to compile()" unless defined $args{source}; my $cf = $self->{config}; # For convenience - - $args{object_file} ||= $self->object_file($args{source}); - - $args{include_dirs} = [ $args{include_dirs} ] - if exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY"; - - my @include_dirs = $self->arg_include_dirs - (@{$args{include_dirs} || []}, - $self->perl_inc()); + + my $object_file = $args{object_file} + ? $args{object_file} + : $self->object_file($args{source}); + + my $include_dirs_ref = + (exists($args{include_dirs}) && ref($args{include_dirs}) ne "ARRAY") + ? [ $args{include_dirs} ] + : $args{include_dirs}; + my @include_dirs = $self->arg_include_dirs( + @{ $include_dirs_ref || [] }, + $self->perl_inc(), + ); my @defines = $self->arg_defines( %{$args{defines} || {}} ); - my @extra_compiler_flags = $self->split_like_shell($args{extra_compiler_flags}); + my @extra_compiler_flags = + $self->split_like_shell($args{extra_compiler_flags}); my @cccdlflags = $self->split_like_shell($cf->{cccdlflags}); - my @ccflags = $self->split_like_shell($cf->{ccflags}); - push @ccflags, qw/-x c++/ if $args{'C++'}; + my @ccflags = $self->split_like_shell($args{'C++'} ? $cf->{cxxflags} : $cf->{ccflags}); my @optimize = $self->split_like_shell($cf->{optimize}); - my @flags = (@include_dirs, @defines, @cccdlflags, @extra_compiler_flags, - $self->arg_nolink, - @ccflags, @optimize, - $self->arg_object_file($args{object_file}), - ); - - my @cc = $self->split_like_shell($cf->{cc}); + my @flags = ( + @include_dirs, + @defines, + @cccdlflags, + @extra_compiler_flags, + $self->arg_nolink, + @ccflags, + @optimize, + $self->arg_object_file($object_file), + ); + my @cc = $self->split_like_shell($args{'C++'} ? $cf->{cxx} : $cf->{cc}); $self->do_system(@cc, @flags, $args{source}) - or die "error building $args{object_file} from '$args{source}'"; + or die "error building $object_file from '$args{source}'"; - return $args{object_file}; + return $object_file; } sub have_compiler { my ($self, $is_cplusplus) = @_; - return $self->{have_compiler} if defined $self->{have_compiler}; + my $have_compiler_flag = $is_cplusplus ? "have_cxx" : "have_cc"; + my $suffix = $is_cplusplus ? ".cc" : ".c"; + return $self->{$have_compiler_flag} if defined $self->{$have_compiler_flag}; my $result; my $attempts = 3; # tmpdir has issues for some people so fall back to current dir - DIR: for my $dir ( File::Spec->tmpdir, '.' ) { - - # don't clobber existing files (rare, but possible) - my $rand = int(rand(2**31)); - my $tmpfile = File::Spec->catfile($dir, "compilet-$rand.c"); - $tmpfile .= "c" if $is_cplusplus; - if ( -e $tmpfile ) { - redo DIR if $attempts--; - next DIR; - } - { - my $FH = IO::File->new("> $tmpfile") or die "Can't create $tmpfile: $!"; - if ( $is_cplusplus ) { - print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; - } - else { - print $FH "int boot_compilet() { return 1; }\n"; - } - } + # don't clobber existing files (rare, but possible) + my ( $FH, $tmpfile ) = tempfile( "compilet-XXXXX", SUFFIX => $suffix ); + binmode $FH; - my ($obj_file, @lib_files); - eval { - local $^W = 0; - local $self->{quiet} = 1; - $obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile); - @lib_files = $self->link(objects => $obj_file, module_name => 'compilet'); - }; - $result = $@ ? 0 : 1; - - foreach (grep defined, $tmpfile, $obj_file, @lib_files) { - 1 while unlink; - } - last DIR if $result; + if ( $is_cplusplus ) { + print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; + } + else { + print $FH "int boot_compilet() { return 1; }\n"; + } + + my ($obj_file, @lib_files); + eval { + local $^W = 0; + local $self->{quiet} = 1; + $obj_file = $self->compile('C++' => $is_cplusplus, source => $tmpfile); + @lib_files = $self->link(objects => $obj_file, module_name => 'compilet'); + }; + $result = $@ ? 0 : 1; + + foreach (grep defined, $tmpfile, $obj_file, @lib_files) { + 1 while unlink; } - return $self->{have_compiler} = $result; + return $self->{$have_compiler_flag} = $result; } sub have_cplusplus { @@ -190,23 +241,32 @@ sub extra_link_args_after_prelink { return } sub prelink { my ($self, %args) = @_; - - ($args{dl_file} = $args{dl_name}) =~ s/.*::// unless $args{dl_file}; - + + my ($dl_file_out, $mksymlists_args) = _prepare_mksymlists_args(\%args); + require ExtUtils::Mksymlists; - ExtUtils::Mksymlists::Mksymlists( # dl. abbrev for dynamic library - DL_VARS => $args{dl_vars} || [], - DL_FUNCS => $args{dl_funcs} || {}, - FUNCLIST => $args{dl_func_list} || [], - IMPORTS => $args{dl_imports} || {}, - NAME => $args{dl_name}, # Name of the Perl module - DLBASE => $args{dl_base}, # Basename of DLL file - FILE => $args{dl_file}, # Dir + Basename of symlist file - VERSION => (defined $args{dl_version} ? $args{dl_version} : '0.0'), - ); - + # dl. abbrev for dynamic library + ExtUtils::Mksymlists::Mksymlists( %{ $mksymlists_args } ); + # Mksymlists will create one of these files - return grep -e, map "$args{dl_file}.$_", qw(ext def opt); + return grep -e, map "$dl_file_out.$_", qw(ext def opt); +} + +sub _prepare_mksymlists_args { + my $args = shift; + ($args->{dl_file} = $args->{dl_name}) =~ s/.*::// unless $args->{dl_file}; + + my %mksymlists_args = ( + DL_VARS => $args->{dl_vars} || [], + DL_FUNCS => $args->{dl_funcs} || {}, + FUNCLIST => $args->{dl_func_list} || [], + IMPORTS => $args->{dl_imports} || {}, + NAME => $args->{dl_name}, # Name of the Perl module + DLBASE => $args->{dl_base}, # Basename of DLL file + FILE => $args->{dl_file}, # Dir + Basename of symlist file + VERSION => (defined $args->{dl_version} ? $args->{dl_version} : '0.0'), + ); + return ($args->{dl_file}, \%mksymlists_args); } sub link { @@ -230,14 +290,19 @@ sub _do_link { my @temp_files; @temp_files = - $self->prelink(%args, - dl_name => $args{module_name}) if $args{lddl} && $self->need_prelink; + $self->prelink(%args, dl_name => $args{module_name}) + if $args{lddl} && $self->need_prelink; - my @linker_flags = ($self->split_like_shell($args{extra_linker_flags}), - $self->extra_link_args_after_prelink(%args, dl_name => $args{module_name}, - prelink_res => \@temp_files)); + my @linker_flags = ( + $self->split_like_shell($args{extra_linker_flags}), + $self->extra_link_args_after_prelink( + %args, dl_name => $args{module_name}, prelink_res => \@temp_files + ) + ); - my @output = $args{lddl} ? $self->arg_share_object_file($out) : $self->arg_exec_file($out); + my @output = $args{lddl} + ? $self->arg_share_object_file($out) + : $self->arg_exec_file($out); my @shrp = $self->split_like_shell($cf->{shrpenv}); my @ld = $self->split_like_shell($cf->{ld}); @@ -262,6 +327,11 @@ sub split_like_shell { $string =~ s/^\s+|\s+$//g; return () unless length($string); + # Text::ParseWords replaces all 'escaped' characters with themselves, which completely + # breaks paths under windows. As such, we forcibly replace backwards slashes with forward + # slashes on windows. + $string =~ s@\\@/@g if $^O eq 'MSWin32'; + return Text::ParseWords::shellwords($string); } @@ -278,12 +348,12 @@ sub perl_src { # Try up to 5 levels upwards for (0..10) { if ( - -f File::Spec->catfile($dir,"config_h.SH") - && - -f File::Spec->catfile($dir,"perl.h") - && - -f File::Spec->catfile($dir,"lib","Exporter.pm") - ) { + -f File::Spec->catfile($dir,"config_h.SH") + && + -f File::Spec->catfile($dir,"perl.h") + && + -f File::Spec->catfile($dir,"lib","Exporter.pm") + ) { return Cwd::realpath( $dir ); } @@ -308,3 +378,5 @@ sub DESTROY { } 1; + +# vim: ts=2 sw=2 et: diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm index a3e9b3c812..8665ac962c 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Unix.pm @@ -4,7 +4,7 @@ use strict; use ExtUtils::CBuilder::Base; use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; @ISA = qw(ExtUtils::CBuilder::Base); sub link_executable { diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm index e31eca9937..8800f8afcf 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/VMS.pm @@ -4,7 +4,7 @@ use strict; use ExtUtils::CBuilder::Base; use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; @ISA = qw(ExtUtils::CBuilder::Base); use File::Spec::Functions qw(catfile catdir); diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm index e26d1f805b..97576c8b1e 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows.pm @@ -10,7 +10,7 @@ use ExtUtils::CBuilder::Base; use IO::File; use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; @ISA = qw(ExtUtils::CBuilder::Base); =begin comment @@ -101,7 +101,7 @@ sub compile { builddir => $srcdir, basename => $basename, source => $args{source}, - output => File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext}, + output => $args{object_file} || File::Spec->catfile($srcdir, $basename) . $cf->{obj_ext}, cc => $cf->{cc}, cflags => [ $self->split_like_shell($cf->{ccflags}), diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm index 0764f93571..6abade104b 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/BCC.pm @@ -1,7 +1,7 @@ package ExtUtils::CBuilder::Platform::Windows::BCC; use vars qw($VERSION); -$VERSION = '0.2703'; +$VERSION = '0.2800'; sub format_compiler_cmd { my ($self, %spec) = @_; diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm index 84cdd5cbcd..d5ff8f4c53 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/GCC.pm @@ -1,7 +1,7 @@ package ExtUtils::CBuilder::Platform::Windows::GCC; use vars qw($VERSION); -$VERSION = '0.2703'; +$VERSION = '0.2800'; sub format_compiler_cmd { my ($self, %spec) = @_; diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm index 72c3c00d06..d5d5e26c04 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/Windows/MSVC.pm @@ -1,7 +1,7 @@ package ExtUtils::CBuilder::Platform::Windows::MSVC; use vars qw($VERSION); -$VERSION = '0.2703'; +$VERSION = '0.2800'; sub arg_exec_file { my ($self, $file) = @_; diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm index c4848abd71..4fdcfa875e 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/aix.pm @@ -5,7 +5,7 @@ use ExtUtils::CBuilder::Platform::Unix; use File::Spec; use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm index e886682e92..e02c13d9d5 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/cygwin.pm @@ -5,7 +5,7 @@ use File::Spec; use ExtUtils::CBuilder::Platform::Unix; use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; @ISA = qw(ExtUtils::CBuilder::Platform::Unix); # TODO: If a specific exe_file name is requested, if the exe created diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm index 6253788726..19ec0132fa 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/darwin.pm @@ -4,7 +4,7 @@ use strict; use ExtUtils::CBuilder::Platform::Unix; use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub compile { diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm index 38205a901f..b613cd64d3 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/dec_osf.pm @@ -6,7 +6,7 @@ use File::Spec; use vars qw($VERSION @ISA); @ISA = qw(ExtUtils::CBuilder::Platform::Unix); -$VERSION = '0.2703'; +$VERSION = '0.2800'; sub link_executable { my $self = shift; diff --git a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm index bb590ee634..3624d5f3a2 100644 --- a/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm +++ b/cpan/ExtUtils-CBuilder/lib/ExtUtils/CBuilder/Platform/os2.pm @@ -4,7 +4,7 @@ use strict; use ExtUtils::CBuilder::Platform::Unix; use vars qw($VERSION @ISA); -$VERSION = '0.2703'; +$VERSION = '0.2800'; @ISA = qw(ExtUtils::CBuilder::Platform::Unix); sub need_prelink { 1 } diff --git a/cpan/ExtUtils-CBuilder/t/00-have-compiler.t b/cpan/ExtUtils-CBuilder/t/00-have-compiler.t index f20f891b33..581a21461b 100644 --- a/cpan/ExtUtils-CBuilder/t/00-have-compiler.t +++ b/cpan/ExtUtils-CBuilder/t/00-have-compiler.t @@ -16,7 +16,7 @@ BEGIN { } } -plan tests => 6; +plan tests => 7; require_ok "ExtUtils::CBuilder"; @@ -29,17 +29,29 @@ my $run_perl = "$perl -e1 --"; $b->{config}{cc} = $bogus_path; $b->{config}{ld} = $bogus_path; -$b->{have_compiler} = undef; +$b->{have_cc} = undef; is( $b->have_compiler, 0, "have_compiler: fake missing cc" ); -$b->{have_compiler} = undef; +$b->{have_cxx} = undef; is( $b->have_cplusplus, 0, "have_cplusplus: fake missing c++" ); # test found compiler $b->{config}{cc} = $run_perl; $b->{config}{ld} = $run_perl; -$b->{have_compiler} = undef; +$b->{config}{cxx} = $run_perl; +$b->{have_cc} = undef; is( $b->have_compiler, 1, "have_compiler: fake present cc" ); -$b->{have_compiler} = undef; +$b->{have_cxx} = undef; is( $b->have_cplusplus, 1, "have_cpp_compiler: fake present c++" ); # test missing cpp compiler + +# test one non-exported subroutine +{ + my $type = ExtUtils::CBuilder::os_type(); + if ($type) { + pass( "OS type $type located for $^O" ); + } + else { + pass( "OS type not yet listed for $^O" ); + } +} diff --git a/cpan/ExtUtils-CBuilder/t/01-basic.t b/cpan/ExtUtils-CBuilder/t/01-basic.t index c1eab9e34d..ffcd60ce9c 100644 --- a/cpan/ExtUtils-CBuilder/t/01-basic.t +++ b/cpan/ExtUtils-CBuilder/t/01-basic.t @@ -12,7 +12,7 @@ BEGIN { use ExtUtils::CBuilder; use File::Spec; -# TEST doesn't like extraneous output +# TEST does not like extraneous output my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; my ($source_file, $object_file, $lib_file); diff --git a/cpan/ExtUtils-CBuilder/t/02-link.t b/cpan/ExtUtils-CBuilder/t/02-link.t index f67ebe6f76..822b071223 100644 --- a/cpan/ExtUtils-CBuilder/t/02-link.t +++ b/cpan/ExtUtils-CBuilder/t/02-link.t @@ -12,7 +12,7 @@ BEGIN { use ExtUtils::CBuilder; use File::Spec; -# TEST doesn't like extraneous output +# TEST does not like extraneous output my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; my ($source_file, $object_file, $exe_file); @@ -33,10 +33,9 @@ ok $b, "created EU::CB object"; $source_file = File::Spec->catfile('t', 'compilet.c'); { - local *FH; - open FH, "> $source_file" or die "Can't create $source_file: $!"; - print FH "int main(void) { return 11; }\n"; - close FH; + open my $FH, "> $source_file" or die "Can't create $source_file: $!"; + print $FH "int main(void) { return 11; }\n"; + close $FH; } ok -e $source_file, "generated '$source_file'"; @@ -86,11 +85,13 @@ sub my_system { my $cmd = shift; my $ec; if ($^O eq 'VMS') { - # Preserve non-posixified status and don't bit shift the result. - use vmsish 'status'; + # Preserve non-posixified status and don't bit shift the result + # because we're running under "use vmsish"; $ec = system("mcr $cmd"); return $ec; } - $ec = system($cmd); - return $ec == -1 ? -1 : $ec >> 8; + else { + $ec = system($cmd); + return $ec == -1 ? -1 : $ec >> 8; + } } diff --git a/cpan/ExtUtils-CBuilder/t/03-cplusplus.t b/cpan/ExtUtils-CBuilder/t/03-cplusplus.t index 4e13381fff..02555df3db 100644 --- a/cpan/ExtUtils-CBuilder/t/03-cplusplus.t +++ b/cpan/ExtUtils-CBuilder/t/03-cplusplus.t @@ -12,7 +12,7 @@ BEGIN { use ExtUtils::CBuilder; use File::Spec; -# TEST doesn't like extraneous output +# TEST does not like extraneous output my $quiet = $ENV{PERL_CORE} && !$ENV{HARNESS_ACTIVE}; my ($source_file, $object_file, $lib_file); @@ -32,10 +32,9 @@ ok $b->have_cplusplus, "have_cplusplus"; $source_file = File::Spec->catfile('t', 'compilet.cc'); { - local *FH; - open FH, "> $source_file" or die "Can't create $source_file: $!"; - print FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; - close FH; + open my $FH, "> $source_file" or die "Can't create $source_file: $!"; + print $FH "class Bogus { public: int boot_compilet() { return 1; } };\n"; + close $FH; } ok -e $source_file, "source file '$source_file' created"; diff --git a/cpan/ExtUtils-CBuilder/t/04-base.t b/cpan/ExtUtils-CBuilder/t/04-base.t new file mode 100644 index 0000000000..025b53b82c --- /dev/null +++ b/cpan/ExtUtils-CBuilder/t/04-base.t @@ -0,0 +1,411 @@ +#! perl -w + +use strict; +use Test::More tests => 58; +BEGIN { + if ($^O eq 'VMS') { + # So we can get the return value of system() + require vmsish; + import vmsish; + } +} +use Config; +use Cwd; +use File::Path qw( mkpath ); +use File::Temp qw( tempdir ); +use ExtUtils::CBuilder::Base; + +# XXX protect from user CC as we mock everything here +local $ENV{CC}; + +my ( $base, $phony, $cwd ); +my ( $source_file, $object_file, $lib_file ); + +$base = ExtUtils::CBuilder::Base->new(); +ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); +isa_ok( $base, 'ExtUtils::CBuilder::Base' ); + +{ + $phony = 'foobar'; + $base = ExtUtils::CBuilder::Base->new( + config => { cc => $phony }, + ); + ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); + isa_ok( $base, 'ExtUtils::CBuilder::Base' ); + is( $base->{config}->{cc}, $phony, + "Got expected value when 'config' argument passed to new()" ); +} + +{ + $phony = 'barbaz'; + local $ENV{CC} = $phony; + $base = ExtUtils::CBuilder::Base->new(); + ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); + isa_ok( $base, 'ExtUtils::CBuilder::Base' ); + is( $base->{config}->{cc}, $phony, + "Got expected value \$ENV{CC} set" ); +} + +{ + my $path_to_perl = File::Spec->catfile( '', qw| usr bin perl | ); + local $^X = $path_to_perl; + is( + ExtUtils::CBuilder::Base::find_perl_interpreter(), + $path_to_perl, + "find_perl_interpreter() returned expected absolute path" + ); +} + +{ + my $path_to_perl = 'foobar'; + local $^X = $path_to_perl; + # %Config is read-only. We cannot assign to it and we therefore cannot + # simulate the condition that would occur were its value something other + # than an existing file. + if ( !$ENV{PERL_CORE} and $Config::Config{perlpath}) { + is( + ExtUtils::CBuilder::Base::find_perl_interpreter(), + $Config::Config{perlpath}, + "find_perl_interpreter() returned expected file" + ); + } + else { + is( + ExtUtils::CBuilder::Base::find_perl_interpreter(), + $path_to_perl, + "find_perl_interpreter() returned expected name" + ); + } +} + +{ + $cwd = cwd(); + my $tdir = tempdir(); + chdir $tdir; + $base = ExtUtils::CBuilder::Base->new(); + ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); + isa_ok( $base, 'ExtUtils::CBuilder::Base' ); + is( scalar keys %{$base->{files_to_clean}}, 0, + "No files needing cleaning yet" ); + + my $file_for_cleaning = File::Spec->catfile( $tdir, 'foobar' ); + open my $IN, '>', $file_for_cleaning + or die "Unable to open dummy file: $!"; + print $IN "\n"; + close $IN or die "Unable to close dummy file: $!"; + + $base->add_to_cleanup( $file_for_cleaning ); + is( scalar keys %{$base->{files_to_clean}}, 1, + "One file needs cleaning" ); + + $base->cleanup(); + ok( ! -f $file_for_cleaning, "File was cleaned up" ); + + chdir $cwd; +} + +# fake compiler is perl and will always succeed +$base = ExtUtils::CBuilder::Base->new( + config => { + cc => File::Spec->rel2abs($^X) . " -e1 --", + ld => File::Spec->rel2abs($^X) . " -e1 --", + } +); +ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); +isa_ok( $base, 'ExtUtils::CBuilder::Base' ); +eval { + $base->compile(foo => 'bar'); +}; +like( + $@, + qr/Missing 'source' argument to compile/, + "Got expected error message when lacking 'source' argument to compile()" +); + +$base = ExtUtils::CBuilder::Base->new( quiet => 1 ); +ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); +isa_ok( $base, 'ExtUtils::CBuilder::Base' ); + +$source_file = File::Spec->catfile('t', 'compilet.c'); +create_c_source_file($source_file); +ok(-e $source_file, "source file '$source_file' created"); + +# object filename automatically assigned +my $obj_ext = $base->{config}{obj_ext}; +is( $base->object_file($source_file), + File::Spec->catfile('t', "compilet$obj_ext"), + "object_file(): got expected automatically assigned name for object file" +); + +# object filename explicitly assigned +$object_file = File::Spec->catfile('t', 'my_special_compilet.o' ); +is( $object_file, + $base->compile( + source => $source_file, + object_file => $object_file, + ), + "compile(): returned object file with specified name" +); + +$lib_file = $base->lib_file($object_file); +ok( $lib_file, "lib_file() returned true value" ); + +my ($lib, @temps); +($lib, @temps) = $base->link( + objects => $object_file, + module_name => 'compilet', +); +$lib =~ tr/"'//d; #" +is($lib_file, $lib, "lib_file(): got expected value for $lib"); + +($lib, @temps) = $base->link( + objects => [ $object_file ], + module_name => 'compilet', +); +$lib =~ tr/"'//d; #" +is($lib_file, $lib, "lib_file(): got expected value for $lib"); + +($lib, @temps) = $base->link( + lib_file => $lib_file, + objects => [ $object_file ], + module_name => 'compilet', +); +$lib =~ tr/"'//d; #" +is($lib_file, $lib, "lib_file(): got expected value for $lib"); + +$lib = $base->link( + objects => $object_file, + module_name => 'compilet', +); +$lib =~ tr/"'//d; #" +is($lib_file, $lib, "lib_file(): got expected value for $lib"); + +{ + local $ENV{PERL_CORE} = '' unless $ENV{PERL_CORE}; + my $include_dir = $base->perl_inc(); + ok( $include_dir, "perl_inc() returned true value" ); + ok( -d $include_dir, "perl_inc() returned directory" ); +} + +# +$base = ExtUtils::CBuilder::Base->new( quiet => 1 ); +ok( $base, "ExtUtils::CBuilder::Base->new() returned true value" ); +isa_ok( $base, 'ExtUtils::CBuilder::Base' ); + +$source_file = File::Spec->catfile('t', 'compilet.c'); +create_c_source_file($source_file); +ok(-e $source_file, "source file '$source_file' created"); +$object_file = File::Spec->catfile('t', 'my_special_compilet.o' ); +is( $object_file, + $base->compile( + source => $source_file, + object_file => $object_file, + defines => { alpha => 'beta', gamma => 'delta' }, + ), + "compile() completed when 'defines' provided; returned object file with specified name" +); + +my $exe_file = $base->exe_file($object_file); +my $ext = $base->{config}{_exe}; +my $expected = File::Spec->catfile('t', qq|my_special_compilet$ext| ); +is( + $exe_file, + $expected, + "exe_file(): returned expected name of executable" +); + +my %args = (); +my @defines = $base->arg_defines( %args ); +ok( ! @defines, "Empty hash passed to arg_defines() returns empty list" ); + +%args = ( alpha => 'beta', gamma => 'delta' ); +my $defines_seen_ref = { map { $_ => 1 } $base->arg_defines( %args ) }; +is_deeply( + $defines_seen_ref, + { '-Dalpha=beta' => 1, '-Dgamma=delta' => 1 }, + "arg_defines(): got expected defines", +); + +my $include_dirs_seen_ref = + { map {$_ => 1} $base->arg_include_dirs( qw| alpha beta gamma | ) }; +is_deeply( + $include_dirs_seen_ref, + { '-Ialpha' => 1, '-Ibeta' => 1, '-Igamma' => 1 }, + "arg_include_dirs(): got expected include_dirs", +); + +is( '-c', $base->arg_nolink(), "arg_nolink(): got expected value" ); + +my $seen_ref = + { map {$_ => 1} $base->arg_object_file('alpha') }; +is_deeply( + $seen_ref, + { '-o' => 1, 'alpha' => 1 }, + "arg_object_file(): got expected option flag and value", +); + +$seen_ref = { map {$_ => 1} $base->arg_share_object_file('alpha') }; +my %exp = map {$_ => 1} $base->split_like_shell($base->{config}{lddlflags}); +$exp{'-o'} = 1; +$exp{'alpha'} = 1; + +is_deeply( + $seen_ref, + \%exp, + "arg_share_object_file(): got expected option flag and value", +); + +$seen_ref = + { map {$_ => 1} $base->arg_exec_file('alpha') }; +is_deeply( + $seen_ref, + { '-o' => 1, 'alpha' => 1 }, + "arg_exec_file(): got expected option flag and value", +); + +ok(! $base->split_like_shell(undef), + "split_like_shell(): handled undefined argument as expected" ); + +my $array_ref = [ qw| alpha beta gamma | ]; +my %split_seen = map { $_ => 1 } $base->split_like_shell($array_ref); +%exp = ( alpha => 1, beta => 1, gamma => 1 ); +is_deeply( \%split_seen, \%exp, + "split_like_shell(): handled array ref as expected" ); + +{ + $cwd = cwd(); + my $tdir = tempdir(); + my $subdir = File::Spec->catdir( + $tdir, qw| alpha beta gamma delta epsilon + zeta eta theta iota kappa lambda | + ); + mkpath($subdir, { mode => 0711 } ); + chdir $subdir + or die "Unable to change to temporary directory for testing"; + local $ENV{PERL_CORE} = 1; + my $capture = q{}; + local $SIG{__WARN__} = sub { $capture = $_[0] }; + my $expected_message = + qr/PERL_CORE is set but I can't find your perl source!/; #' + my $rv; + + $rv = $base->perl_src(); + is( $rv, q{}, "perl_src(): returned empty string as expected" ); + like( $capture, $expected_message, + "perl_src(): got expected warning" ); + $capture = q{}; + + my $config = File::Spec->catfile( $subdir, 'config_h.SH' ); + touch_file($config); + $rv = $base->perl_src(); + is( $rv, q{}, "perl_src(): returned empty string as expected" ); + like( $capture, $expected_message, + "perl_src(): got expected warning" ); + $capture = q{}; + + my $perlh = File::Spec->catfile( $subdir, 'perl.h' ); + touch_file($perlh); + $rv = $base->perl_src(); + is( $rv, q{}, "perl_src(): returned empty string as expected" ); + like( $capture, $expected_message, + "perl_src(): got expected warning" ); + $capture = q{}; + + my $libsubdir = File::Spec->catdir( $subdir, 'lib' ); + mkpath($libsubdir, { mode => 0711 } ); + my $exporter = File::Spec->catfile( $libsubdir, 'Exporter.pm' ); + touch_file($exporter); + $rv = $base->perl_src(); + ok( -d $rv, "perl_src(): returned a directory" ); + is( $rv, Cwd::realpath($subdir), "perl_src(): identified directory" ); + is( $capture, q{}, "perl_src(): no warning, as expected" ); + + chdir $cwd + or die "Unable to change from temporary directory after testing"; +} + +my ($dl_file_out, $mksymlists_args); +my $dlf = 'Kappa'; +%args = ( + dl_vars => [ qw| alpha beta gamma | ], + dl_funcs => { + 'Homer::Iliad' => [ qw(trojans greeks) ], + 'Homer::Odyssey' => [ qw(travellers family suitors) ], + }, + dl_func_list => [ qw| delta epsilon | ], + dl_imports => { zeta => 'eta', theta => 'iota' }, + dl_name => 'Tk::Canvas', + dl_base => 'Tk::Canvas.ext', + dl_file => $dlf, + dl_version => '7.7', +); +($dl_file_out, $mksymlists_args) = + ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args); +is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): Got expected name for dl_file" ); +is_deeply( $mksymlists_args, + { + DL_VARS => [ qw| alpha beta gamma | ], + DL_FUNCS => { + 'Homer::Iliad' => [ qw(trojans greeks) ], + 'Homer::Odyssey' => [ qw(travellers family suitors) ], + }, + FUNCLIST => [ qw| delta epsilon | ], + IMPORTS => { zeta => 'eta', theta => 'iota' }, + NAME => 'Tk::Canvas', + DLBASE => 'Tk::Canvas.ext', + FILE => $dlf, + VERSION => '7.7', + }, + "_prepare_mksymlists_args(): got expected arguments for Mksymlists", +); + +$dlf = 'Canvas'; +%args = ( + dl_name => 'Tk::Canvas', + dl_base => 'Tk::Canvas.ext', +); +($dl_file_out, $mksymlists_args) = + ExtUtils::CBuilder::Base::_prepare_mksymlists_args(\%args); +is( $dl_file_out, $dlf, "_prepare_mksymlists_args(): got expected name for dl_file" ); +is_deeply( $mksymlists_args, + { + DL_VARS => [], + DL_FUNCS => {}, + FUNCLIST => [], + IMPORTS => {}, + NAME => 'Tk::Canvas', + DLBASE => 'Tk::Canvas.ext', + FILE => $dlf, + VERSION => '0.0', + }, + "_prepare_mksymlists_args(): got expected arguments for Mksymlists", +); + +##### + +for ($source_file, $object_file, $lib_file) { + tr/"'//d; #" + 1 while unlink; +} + +pass("Completed all tests in $0"); + +if ($^O eq 'VMS') { + 1 while unlink 'COMPILET.LIS'; + 1 while unlink 'COMPILET.OPT'; +} + +sub create_c_source_file { + my $source_file = shift; + open my $FH, '>', $source_file or die "Can't create $source_file: $!"; + print $FH "int boot_compilet(void) { return 1; }\n"; + close $FH; +} + +sub touch_file { + my $f = shift; + open my $FH, '>', $f or die "Can't create $f: $!"; + print $FH "\n"; + close $FH; + return $f; +} diff --git a/cpan/Win32/Changes b/cpan/Win32/Changes index b707793290..7dd898662c 100644..100755 --- a/cpan/Win32/Changes +++ b/cpan/Win32/Changes @@ -1,5 +1,18 @@ Revision history for the Perl extension Win32.
+0.40 [2010-12-08]
+ - Add Win32::GetSystemMetrics function.
+ - Add Win32::GetProductInfo() function.
+ - Add Win32::GetOSDisplayName() function.
+ - Detect "Windows Server 2008 R2" as "Win2008" in Win32::GetOSName()
+ (used to return "Win7" before).
+ - Detect "Windows Home Server" as "WinHomeSvr" in Win32::GetOSName()
+ (used to return "Win2003" before).
+ - Added "R2", "Media Center", "Tablet PC", "Starter Edition" etc.
+ tags to the description returned by Win32::GetOSName() in
+ list context.
+ - Rewrote the t/GetOSName.t tests
+
0.39 [2009-01-19]
- Add support for Windows 2008 Server and Windows 7 in
Win32::GetOSName() and in the documentation for
diff --git a/cpan/Win32/Win32.pm b/cpan/Win32/Win32.pm index bc231ba6fa..cef62717d0 100644 --- a/cpan/Win32/Win32.pm +++ b/cpan/Win32/Win32.pm @@ -1,6 +1,6 @@ package Win32;
-BEGIN {
+# BEGIN {
use strict;
use vars qw|$VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK|;
@@ -8,7 +8,7 @@ BEGIN { require DynaLoader;
@ISA = qw|Exporter DynaLoader|;
- $VERSION = '0.39';
+ $VERSION = '0.40';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -79,7 +79,7 @@ BEGIN { CSIDL_RESOURCES_LOCALIZED
CSIDL_CDBURN_AREA
);
-}
+# }
# We won't bother with the constant stuff, too much of a hassle. Just hard
# code it here.
@@ -154,6 +154,106 @@ sub CSIDL_RESOURCES () { 0x0038 } # %windir%\Resources\, Fo sub CSIDL_RESOURCES_LOCALIZED () { 0x0039 } # %windir%\Resources\<LangID>, for theme and other windows specific resources.
sub CSIDL_CDBURN_AREA () { 0x003B } # <user name>\Local Settings\Application Data\Microsoft\CD Burning
+sub VER_NT_DOMAIN_CONTROLLER () { 0x0000002 } # The system is a domain controller and the operating system is Windows Server 2008, Windows Server 2003, or Windows 2000 Server.
+sub VER_NT_SERVER () { 0x0000003 } # The operating system is Windows Server 2008, Windows Server 2003, or Windows 2000 Server.
+# Note that a server that is also a domain controller is reported as VER_NT_DOMAIN_CONTROLLER, not VER_NT_SERVER.
+sub VER_NT_WORKSTATION () { 0x0000001 } # The operating system is Windows Vista, Windows XP Professional, Windows XP Home Edition, or Windows 2000 Professional.
+
+
+sub VER_SUITE_BACKOFFICE () { 0x00000004 } # Microsoft BackOffice components are installed.
+sub VER_SUITE_BLADE () { 0x00000400 } # Windows Server 2003, Web Edition is installed.
+sub VER_SUITE_COMPUTE_SERVER () { 0x00004000 } # Windows Server 2003, Compute Cluster Edition is installed.
+sub VER_SUITE_DATACENTER () { 0x00000080 } # Windows Server 2008 Datacenter, Windows Server 2003, Datacenter Edition, or Windows 2000 Datacenter Server is installed.
+sub VER_SUITE_ENTERPRISE () { 0x00000002 } # Windows Server 2008 Enterprise, Windows Server 2003, Enterprise Edition, or Windows 2000 Advanced Server is installed. Refer to the Remarks section for more information about this bit flag.
+sub VER_SUITE_EMBEDDEDNT () { 0x00000040 } # Windows XP Embedded is installed.
+sub VER_SUITE_PERSONAL () { 0x00000200 } # Windows Vista Home Premium, Windows Vista Home Basic, or Windows XP Home Edition is installed.
+sub VER_SUITE_SINGLEUSERTS () { 0x00000100 } # Remote Desktop is supported, but only one interactive session is supported. This value is set unless the system is running in application server mode.
+sub VER_SUITE_SMALLBUSINESS () { 0x00000001 } # Microsoft Small Business Server was once installed on the system, but may have been upgraded to another version of Windows. Refer to the Remarks section for more information about this bit flag.
+sub VER_SUITE_SMALLBUSINESS_RESTRICTED () { 0x00000020 } # Microsoft Small Business Server is installed with the restrictive client license in force. Refer to the Remarks section for more information about this bit flag.
+sub VER_SUITE_STORAGE_SERVER () { 0x00002000 } # Windows Storage Server 2003 R2 or Windows Storage Server 2003 is installed.
+sub VER_SUITE_TERMINAL () { 0x00000010 } # Terminal Services is installed. This value is always set.
+# If VER_SUITE_TERMINAL is set but VER_SUITE_SINGLEUSERTS is not set, the system is running in application server mode.
+sub VER_SUITE_WH_SERVER () { 0x00008000 } # Windows Home Server is installed.
+
+
+sub SM_TABLETPC () { 86 }
+sub SM_MEDIACENTER () { 87 }
+sub SM_STARTER () { 88 }
+sub SM_SERVERR2 () { 89 }
+
+sub PRODUCT_UNDEFINED () { 0x000 } # An unknown product
+sub PRODUCT_ULTIMATE () { 0x001 } # Ultimate
+sub PRODUCT_HOME_BASIC () { 0x002 } # Home Basic
+sub PRODUCT_HOME_PREMIUM () { 0x003 } # Home Premium
+sub PRODUCT_ENTERPRISE () { 0x004 } # Enterprise
+sub PRODUCT_HOME_BASIC_N () { 0x005 } # Home Basic N
+sub PRODUCT_BUSINESS () { 0x006 } # Business
+sub PRODUCT_STANDARD_SERVER () { 0x007 } # Server Standard (full installation)
+sub PRODUCT_DATACENTER_SERVER () { 0x008 } # Server Datacenter (full installation)
+sub PRODUCT_SMALLBUSINESS_SERVER () { 0x009 } # Windows Small Business Server
+sub PRODUCT_ENTERPRISE_SERVER () { 0x00A } # Server Enterprise (full installation)
+sub PRODUCT_STARTER () { 0x00B } # Starter
+sub PRODUCT_DATACENTER_SERVER_CORE () { 0x00C } # Server Datacenter (core installation)
+sub PRODUCT_STANDARD_SERVER_CORE () { 0x00D } # Server Standard (core installation)
+sub PRODUCT_ENTERPRISE_SERVER_CORE () { 0x00E } # Server Enterprise (core installation)
+sub PRODUCT_ENTERPRISE_SERVER_IA64 () { 0x00F } # Server Enterprise for Itanium-based Systems
+sub PRODUCT_BUSINESS_N () { 0x010 } # Business N
+sub PRODUCT_WEB_SERVER () { 0x011 } # Web Server (full installation)
+sub PRODUCT_CLUSTER_SERVER () { 0x012 } # HPC Edition
+sub PRODUCT_HOME_SERVER () { 0x013 } # Home Server Edition
+sub PRODUCT_STORAGE_EXPRESS_SERVER () { 0x014 } # Storage Server Express
+sub PRODUCT_STORAGE_STANDARD_SERVER () { 0x015 } # Storage Server Standard
+sub PRODUCT_STORAGE_WORKGROUP_SERVER () { 0x016 } # Storage Server Workgroup
+sub PRODUCT_STORAGE_ENTERPRISE_SERVER () { 0x017 } # Storage Server Enterprise
+sub PRODUCT_SERVER_FOR_SMALLBUSINESS () { 0x018 } # Windows Server 2008 for Windows Essential Server Solutions
+sub PRODUCT_SMALLBUSINESS_SERVER_PREMIUM () { 0x019 } # Windows Small Business Server Premium
+sub PRODUCT_HOME_PREMIUM_N () { 0x01A } # Home Premium N
+sub PRODUCT_ENTERPRISE_N () { 0x01B } # Enterprise N
+sub PRODUCT_ULTIMATE_N () { 0x01C } # Ultimate N
+sub PRODUCT_WEB_SERVER_CORE () { 0x01D } # Web Server (core installation)
+sub PRODUCT_MEDIUMBUSINESS_SERVER_MANAGEMENT () { 0x01E } # Windows Essential Business Server Management Server
+sub PRODUCT_MEDIUMBUSINESS_SERVER_SECURITY () { 0x01F } # Windows Essential Business Server Security Server
+sub PRODUCT_MEDIUMBUSINESS_SERVER_MESSAGING () { 0x020 } # Windows Essential Business Server Messaging Server
+sub PRODUCT_SERVER_FOUNDATION () { 0x021 } # Server Foundation
+
+sub PRODUCT_SERVER_FOR_SMALLBUSINESS_V () { 0x023 } # Windows Server 2008 without Hyper-V for Windows Essential Server Solutions
+sub PRODUCT_STANDARD_SERVER_V () { 0x024 } # Server Standard without Hyper-V (full installation)
+sub PRODUCT_DATACENTER_SERVER_V () { 0x025 } # Server Datacenter without Hyper-V (full installation)
+sub PRODUCT_ENTERPRISE_SERVER_V () { 0x026 } # Server Enterprise without Hyper-V (full installation)
+sub PRODUCT_DATACENTER_SERVER_CORE_V () { 0x027 } # Server Datacenter without Hyper-V (core installation)
+sub PRODUCT_STANDARD_SERVER_CORE_V () { 0x028 } # Server Standard without Hyper-V (core installation)
+sub PRODUCT_ENTERPRISE_SERVER_CORE_V () { 0x029 } # Server Enterprise without Hyper-V (core installation)
+sub PRODUCT_HYPERV () { 0x02A } # Microsoft Hyper-V Server
+
+sub PRODUCT_STARTER_N () { 0x02F } # Starter N
+sub PRODUCT_PROFESSIONAL () { 0x030 } # Professional
+sub PRODUCT_PROFESSIONAL_N () { 0x031 } # Professional N
+
+sub PRODUCT_STARTER_E () { 0x042 } # Starter E
+sub PRODUCT_HOME_BASIC_E () { 0x043 } # Home Basic E
+sub PRODUCT_HOME_PREMIUM_E () { 0x044 } # Home Premium E
+sub PRODUCT_PROFESSIONAL_E () { 0x045 } # Professional E
+sub PRODUCT_ENTERPRISE_E () { 0x046 } # Enterprise E
+sub PRODUCT_ULTIMATE_E () { 0x047 } # Ultimate E
+
+sub PRODUCT_UNLICENSED () { 0xABCDABCD } # product has not been activated and is no longer in the grace period
+
+sub PROCESSOR_ARCHITECTURE_AMD64 () { 9 } # x64 (AMD or Intel)
+sub PROCESSOR_ARCHITECTURE_IA64 () { 6 } # Intel Itanium Processor Family (IPF)
+sub PROCESSOR_ARCHITECTURE_INTEL () { 0 } # x86
+sub PROCESSOR_ARCHITECTURE_UNKNOWN () { 0xffff } # Unknown architecture.
+
+sub _GetProcessorArchitecture {
+ my $arch = {
+ 386 => PROCESSOR_ARCHITECTURE_INTEL,
+ 486 => PROCESSOR_ARCHITECTURE_INTEL,
+ 586 => PROCESSOR_ARCHITECTURE_INTEL,
+ 2200 => PROCESSOR_ARCHITECTURE_IA64,
+ 8664 => PROCESSOR_ARCHITECTURE_AMD64,
+ }->{Win32::GetChipName()};
+ return defined($arch) ? $arch : PROCESSOR_ARCHITECTURE_UNKNOWN;
+}
+
### This method is just a simple interface into GetOSVersion(). More
### specific or demanding situations should use that instead.
@@ -161,22 +261,69 @@ my ($cached_os, $cached_desc); sub GetOSName {
unless (defined $cached_os) {
- my($desc, $major, $minor, $build, $id, undef, undef, undef, $producttype)
+ my($desc, $major, $minor, $build, $id, undef, undef, $suitemask, $producttype)
= Win32::GetOSVersion();
- ($cached_os, $cached_desc) = _GetOSName($desc, $major, $minor, $build, $id, $producttype);
+ my $arch = _GetProcessorArchitecture();
+ my $productinfo = Win32::GetProductInfo(6, 0, 0, 0);
+ ($cached_os, $cached_desc) = _GetOSName($desc, $major, $minor, $build, $id,
+ $suitemask, $producttype, $productinfo, $arch);
}
return wantarray ? ($cached_os, $cached_desc) : $cached_os;
}
+sub GetOSDisplayName {
+ # Calling GetOSDisplayName() with arguments is for the test suite only!
+ my($name,$desc) = @_ ? @_ : GetOSName();
+ $name =~ s/^Win//;
+ if ($desc eq "Windows Home Server" || $desc eq "Windows XP Professional x64 Edition") {
+ ($name, $desc) = ($desc, "");
+ }
+ elsif ($desc =~ s/\s*(Windows (.*) Server( \d+)?)$//) {
+ ($name, $desc) = ("$1 $name", $desc);
+ }
+ else {
+ for ($name) {
+ s/^/Windows / unless /^Win32s$/;
+ s/\/.Net//;
+ s/NT(\d)/NT $1/;
+ if ($desc =~ s/\s*(HPC|Small Business|Web) Server//) {
+ my $name = $1;
+ $desc =~ s/^\s*//;
+ s/(200.)/$name Server $1/;
+ }
+ s/^Windows (200[38])/Windows Server $1/;
+ }
+ }
+ $name .= " $desc" if length $desc;
+ return $name;
+}
+
+sub _GetSystemMetrics {
+ my($index,$metrics) = @_;
+ return $metrics->{$index} if ref $metrics eq "HASH" && defined $metrics->{$index};
+ return 1 if ref $metrics eq "ARRAY" && grep $_ == $index, @$metrics;
+ return Win32::GetSystemMetrics($index);
+}
+
sub _GetOSName {
- my($desc, $major, $minor, $build, $id, $producttype) = @_;
+ # The $metrics argument only exists for the benefit of t/GetOSName.t
+ my($csd, $major, $minor, $build, $id, $suitemask, $producttype, $productinfo, $arch, $metrics) = @_;
- my($os,$tag);
+ my($os,@tags);
+ my $desc = "";
if ($id == 0) {
$os = "Win32s";
}
elsif ($id == 1) {
- $os = { 0 => "95", 10 => "98", 90 => "Me" }->{$minor};
+ if ($minor == 0) {
+ $os = "95";
+ }
+ elsif ($minor == 10) {
+ $os = "98";
+ }
+ elsif ($minor == 90) {
+ $os = "Me";
+ }
}
elsif ($id == 2) {
if ($major == 3) {
@@ -186,12 +333,193 @@ sub _GetOSName { $os = "NT4";
}
elsif ($major == 5) {
- $os = { 0 => "2000", 1 => "XP/.Net", 2 => "2003" }->{$minor};
+ if ($minor == 0) {
+ $os = "2000";
+ if ($producttype == VER_NT_WORKSTATION) {
+ $desc = "Professional";
+ }
+ else {
+ if ($suitemask & VER_SUITE_DATACENTER) {
+ $desc = "Datacenter Server";
+ }
+ elsif ($suitemask & VER_SUITE_ENTERPRISE) {
+ $desc = "Advanced Server";
+ }
+ elsif ($suitemask & VER_SUITE_SMALLBUSINESS_RESTRICTED) {
+ $desc = "Small Business Server";
+ }
+ else {
+ $desc = "Server";
+ }
+ }
+ # XXX ignoring "Windows 2000 Advanced Server Limited Edition" for Itanium
+ # XXX and "Windows 2000 Datacenter Server Limited Edition" for Itanium
+ }
+ elsif ($minor == 1) {
+ $os = "XP/.Net";
+ if (_GetSystemMetrics(SM_MEDIACENTER, $metrics)) {
+ $desc = "Media Center Edition";
+ }
+ elsif (_GetSystemMetrics(SM_TABLETPC, $metrics)) {
+ # Tablet PC Edition is based on XP Pro
+ $desc = "Tablet PC Edition";
+ }
+ elsif (_GetSystemMetrics(SM_STARTER, $metrics)) {
+ $desc = "Starter Edition";
+ }
+ elsif ($suitemask & VER_SUITE_PERSONAL) {
+ $desc = "Home Edition";
+ }
+ else {
+ $desc = "Professional";
+ }
+ # XXX ignoring all Windows XP Embedded and Fundamentals versions
+ }
+ elsif ($minor == 2) {
+ $os = "2003";
+
+ if (_GetSystemMetrics(SM_SERVERR2, $metrics)) {
+ # XXX R2 was released for all x86 and x64 versions,
+ # XXX but only Enterprise Edition for Itanium.
+ $desc = "R2";
+ }
+
+ if ($suitemask == VER_SUITE_STORAGE_SERVER) {
+ $desc .= " Windows Storage Server";
+ }
+ elsif ($suitemask == VER_SUITE_WH_SERVER) {
+ $desc .= " Windows Home Server";
+ }
+ elsif ($producttype == VER_NT_WORKSTATION && $arch == PROCESSOR_ARCHITECTURE_AMD64) {
+ $desc .= " Windows XP Professional x64 Edition";
+ }
+
+ # Test for the server type.
+ if ($producttype != VER_NT_WORKSTATION) {
+ if ($arch == PROCESSOR_ARCHITECTURE_IA64) {
+ if ($suitemask & VER_SUITE_DATACENTER) {
+ $desc .= " Datacenter Edition for Itanium-based Systems";
+ }
+ elsif ($suitemask & VER_SUITE_ENTERPRISE) {
+ $desc .= " Enterprise Edition for Itanium-based Systems";
+ }
+ }
+ elsif ($arch == PROCESSOR_ARCHITECTURE_AMD64) {
+ if ($suitemask & VER_SUITE_DATACENTER) {
+ $desc .= " Datacenter x64 Edition";
+ }
+ elsif ($suitemask & VER_SUITE_ENTERPRISE) {
+ $desc .= " Enterprise x64 Edition";
+ }
+ else {
+ $desc .= " Standard x64 Edition";
+ }
+ }
+ else {
+ if ($suitemask & VER_SUITE_COMPUTE_SERVER) {
+ $desc .= " Windows Compute Cluster Server";
+ }
+ elsif ($suitemask & VER_SUITE_DATACENTER) {
+ $desc .= " Datacenter Edition";
+ }
+ elsif ($suitemask & VER_SUITE_ENTERPRISE) {
+ $desc .= " Enterprise Edition";
+ }
+ elsif ($suitemask & VER_SUITE_BLADE) {
+ $desc .= " Web Edition";
+ }
+ elsif ($suitemask & VER_SUITE_SMALLBUSINESS_RESTRICTED) {
+ $desc .= " Small Business Server";
+ }
+ else {
+ if ($desc !~ /Windows (Home|Storage) Server/) {
+ $desc .= " Standard Edition";
+ }
+ }
+ }
+ }
+ }
}
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;
+ if ($minor == 0) {
+ if ($producttype == VER_NT_WORKSTATION) {
+ $os = "Vista";
+ }
+ else {
+ $os = "2008";
+ }
+ }
+ elsif ($minor == 1) {
+ if ($producttype == VER_NT_WORKSTATION) {
+ $os = "7";
+ }
+ else {
+ $os = "2008";
+ $desc = "R2";
+ }
+ }
+
+ if ($productinfo == PRODUCT_ULTIMATE) {
+ $desc .= " Ultimate";
+ }
+ elsif ($productinfo == PRODUCT_HOME_PREMIUM) {
+ $desc .= " Home Premium";
+ }
+ elsif ($productinfo == PRODUCT_HOME_BASIC) {
+ $desc .= " Home Basic";
+ }
+ elsif ($productinfo == PRODUCT_ENTERPRISE) {
+ $desc .= " Enterprise";
+ }
+ elsif ($productinfo == PRODUCT_BUSINESS) {
+ $desc .= " Business";
+ }
+ elsif ($productinfo == PRODUCT_STARTER) {
+ $desc .= " Starter";
+ }
+ elsif ($productinfo == PRODUCT_CLUSTER_SERVER) {
+ $desc .= " HPC Server";
+ }
+ elsif ($productinfo == PRODUCT_DATACENTER_SERVER) {
+ $desc .= " Datacenter";
+ }
+ elsif ($productinfo == PRODUCT_DATACENTER_SERVER_CORE) {
+ $desc .= " Datacenter Edition (core installation)";
+ }
+ elsif ($productinfo == PRODUCT_ENTERPRISE_SERVER) {
+ $desc .= " Enterprise";
+ }
+ elsif ($productinfo == PRODUCT_ENTERPRISE_SERVER_CORE) {
+ $desc .= " Enterprise Edition (core installation)";
+ }
+ elsif ($productinfo == PRODUCT_ENTERPRISE_SERVER_IA64) {
+ $desc .= " Enterprise Edition for Itanium-based Systems";
+ }
+ elsif ($productinfo == PRODUCT_SMALLBUSINESS_SERVER) {
+ $desc .= " Small Business Server";
+ }
+ elsif ($productinfo == PRODUCT_SMALLBUSINESS_SERVER_PREMIUM) {
+ $desc .= " Small Business Server Premium Edition";
+ }
+ elsif ($productinfo == PRODUCT_STANDARD_SERVER) {
+ $desc .= " Standard";
+ }
+ elsif ($productinfo == PRODUCT_STANDARD_SERVER_CORE) {
+ $desc .= " Standard Edition (core installation)";
+ }
+ elsif ($productinfo == PRODUCT_WEB_SERVER) {
+ $desc .= " Web Server";
+ }
+ elsif ($productinfo == PRODUCT_PROFESSIONAL) {
+ $desc .= " Professional";
+ }
+
+ if ($arch == PROCESSOR_ARCHITECTURE_INTEL) {
+ $desc .= " (32-bit)";
+ }
+ elsif ($arch == PROCESSOR_ARCHITECTURE_AMD64) {
+ $desc .= " (64-bit)";
+ }
}
}
@@ -200,19 +528,29 @@ sub _GetOSName { 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};
+ for ($desc) {
+ s/\s\s+/ /g;
+ s/^\s//;
+ s/\s$//;
}
- elsif ($os eq "98" && $build eq "67766446") {
- $tag = "(2nd ed)";
+
+ # XXX What about "Small Business Server"? NT, 200, 2003, 2008 editions...
+
+ if ($major >= 5) {
+ # XXX XP, Vista, 7 all have starter editions
+ #push(@tags, "Starter Edition") if _GetSystemMetrics(SM_STARTER, $metrics);
}
- if ($tag) {
- $desc = length($desc) ? "$tag $desc" : $tag;
+
+ if (@tags) {
+ unshift(@tags, $desc) if length $desc;
+ $desc = join(" ", @tags);
}
- return ("Win$os", $desc);
+ if (length $csd) {
+ $desc .= " " if length $desc;
+ $desc .= $csd;
+ }
+ return ("Win$os", $desc);
}
# "no warnings 'redefine';" doesn't work for 5.8.7 and earlier
@@ -366,8 +704,8 @@ $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.
+Returns the processor type: 386, 486 or 586 for x86 processors,
+8664 for the x64 processor and 2200 for the Itanium.
=item Win32::GetCwd()
@@ -505,6 +843,68 @@ before passing the path to a system call or another program. [CORE] Returns a string in the form of "<d>:" where <d> is the first
available drive letter.
+=item Win32::GetOSDisplayName()
+
+Returns the "marketing" name of the Windows operating system version
+being used. It returns names like these (random samples):
+
+ Windows 2000 Datacenter Server
+ Windows XP Professional
+ Windows XP Tablet PC Edition
+ Windows Home Server
+ Windows Server 2003 Enterprise Edition for Itanium-based Systems
+ Windows Vista Ultimate (32-bit)
+ Windows Small Business Server 2008 R2 (64-bit)
+
+This function should only be used to display the actual OS name to the
+user; it should not be used to determine the class of operating systems
+this system belongs to. The Win32::GetOSName(), Win32::GetOSVersion,
+Win32::GetProductInfo() and Win32::GetSystemMetrics() functions provide
+the base information to check for certain capabilities, or for families
+of OS releases.
+
+=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.
+
+The description will also include tags for other special editions,
+like "R2", "Media Center", "Tablet PC", or "Starter Edition".
+
+Currently the possible values for the OS name are
+
+ WinWin32s
+ Win95
+ Win98
+ WinMe
+ WinNT3.51
+ WinNT4
+ Win2000
+ WinXP/.Net
+ Win2003
+ WinHomeSvr
+ 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::GetOSVersion()
[CORE] Returns the list (STRING, MAJOR, MINOR, BUILD, ID), where the
@@ -517,26 +917,40 @@ 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
+ 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 Server 2003 R2 2 5 2
+ Windows Home Server 2 5 2
+
+ Windows Vista 2 6 0
+ Windows Server 2008 2 6 0
+ Windows 7 2 6 1
+ Windows Server 2008 R2 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 2003 and Windows Home Server are
+identical; the SUITEMASK field must be used to differentiate between\
+them.
+
The version numbers for Windows Vista and Windows Server 2008 are
-identical; the PRODUCTTYPE field must be used to differentiate
-between them.
+identical; the PRODUCTTYPE field must be used to differentiate between
+them.
+
+The version numbers for Windows 7 and Windows Server 2008 R2 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.
@@ -557,6 +971,9 @@ the system. Known bits are: VER_SUITE_BLADE 0x00000400
VER_SUITE_EMBEDDED_RESTRICTED 0x00000800
VER_SUITE_SECURITY_APPLIANCE 0x00001000
+ VER_SUITE_STORAGE_SERVER 0x00002000
+ VER_SUITE_COMPUTE_SERVER 0x00004000
+ VER_SUITE_WH_SERVER 0x00008000
The VER_SUITE_xxx names are listed here to crossreference the Microsoft
documentation. The Win32 module does not provide symbolic names for these
@@ -572,44 +989,6 @@ be one of the following integer values: 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
@@ -620,6 +999,13 @@ path containing spaces. Returns C<undef> when the PATHNAME does not exist. Compare with Win32::GetFullPathName() and
Win32::GetLongPathName().
+=item Win32::GetSystemMetrics(INDEX)
+
+Retrieves the specified system metric or system configuration setting.
+Please refer to the Microsoft documentation of the GetSystemMetrics()
+function for a reference of available INDEX values. All system
+metrics return integer values.
+
=item Win32::GetProcAddress(INSTANCE, PROCNAME)
Returns the address of a function inside a loaded library. The
@@ -627,6 +1013,19 @@ 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::GetProductInfo(OSMAJOR, OSMINOR, SPMAJOR, SPMINOR)
+
+Retrieves the product type for the operating system on the local
+computer, and maps the type to the product types supported by the
+specified operating system. Please refer to the Microsoft
+documentation of the GetProductInfo() function for more information
+about the parameters and return value. This function requires Windows
+Vista or later.
+
+See also the Win32::GetOSName() and Win32::GetOSDisplayName()
+functions which provide a higher level abstraction of the data
+returned by this function.
+
=item Win32::GetTickCount()
[CORE] Returns the number of milliseconds elapsed since the last
@@ -645,7 +1044,7 @@ 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)
diff --git a/cpan/Win32/Win32.xs b/cpan/Win32/Win32.xs index 1ccdcc31ab..2799290597 100644 --- a/cpan/Win32/Win32.xs +++ b/cpan/Win32/Win32.xs @@ -38,6 +38,7 @@ typedef BOOL (__stdcall *PFNAllocateAndInitializeSid)(PSID_IDENTIFIER_AUTHORITY, typedef BOOL (__stdcall *PFNEqualSid)(PSID, PSID);
typedef void* (__stdcall *PFNFreeSid)(PSID);
typedef BOOL (__stdcall *PFNIsUserAnAdmin)(void);
+typedef BOOL (WINAPI *PFNGetProductInfo)(DWORD, DWORD, DWORD, DWORD, DWORD*);
#ifndef CSIDL_MYMUSIC
# define CSIDL_MYMUSIC 0x000D
@@ -1651,6 +1652,39 @@ XS(w32_CreateFile) XSRETURN(1);
}
+XS(w32_GetSystemMetrics)
+{
+ dXSARGS;
+
+ if (items != 1)
+ Perl_croak(aTHX_ "usage: Win32::GetSystemMetrics($index)");
+
+ XSRETURN_IV(GetSystemMetrics(SvIV(ST(0))));
+}
+
+XS(w32_GetProductInfo)
+{
+ dXSARGS;
+ DWORD type;
+ HMODULE module;
+ PFNGetProductInfo pfnGetProductInfo;
+
+ if (items != 4)
+ Perl_croak(aTHX_ "usage: Win32::GetProductInfo($major,$minor,$spmajor,$spminor)");
+
+ module = GetModuleHandle("kernel32.dll");
+ GETPROC(GetProductInfo);
+ if (pfnGetProductInfo &&
+ pfnGetProductInfo((DWORD)SvIV(ST(0)), (DWORD)SvIV(ST(1)),
+ (DWORD)SvIV(ST(2)), (DWORD)SvIV(ST(3)), &type))
+ {
+ XSRETURN_IV(type);
+ }
+
+ /* PRODUCT_UNDEFINED */
+ XSRETURN_IV(0);
+}
+
MODULE = Win32 PACKAGE = Win32
PROTOTYPES: DISABLE
@@ -1712,6 +1746,8 @@ BOOT: newXS("Win32::GetCurrentThreadId", w32_GetCurrentThreadId, file);
newXS("Win32::CreateDirectory", w32_CreateDirectory, file);
newXS("Win32::CreateFile", w32_CreateFile, file);
+ newXS("Win32::GetSystemMetrics", w32_GetSystemMetrics, file);
+ newXS("Win32::GetProductInfo", w32_GetProductInfo, file);
#ifdef __CYGWIN__
newXS("Win32::SetChildShowWindow", w32_SetChildShowWindow, file);
#endif
diff --git a/cpan/Win32/t/CreateFile.t b/cpan/Win32/t/CreateFile.t index 63ce31694c..63ce31694c 100644..100755 --- a/cpan/Win32/t/CreateFile.t +++ b/cpan/Win32/t/CreateFile.t diff --git a/cpan/Win32/t/GetOSName.t b/cpan/Win32/t/GetOSName.t index a7ed9d5b23..8c29d30359 100644 --- a/cpan/Win32/t/GetOSName.t +++ b/cpan/Win32/t/GetOSName.t @@ -1,39 +1,159 @@ use strict;
-use Test;
+use Test::More;
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 ],
+# The "description" value is extracted from the $pretty field:
+#
+# "2000 [Server]" => "Server"
+# "{Home Server}" => "Windows Home Server" (prefixed with "Windows ")
+# "Anything R2" => "R2 Anything" (R2 moved to front)
+#
+# The "display name" value is the same as the $pretty field,
+# prefixed by "Windows ", with all "[]{}" characters removed.
+
+# $pretty, $os $id, $major, $minor, $sm, $pt, $metric, $tag
+
+my @intel_tests = (
+["Win32s", "Win32s", 0 ],
+
+["95", "95", 1, 4, 0 ],
+["98", "98", 1, 4, 10 ],
+["Me", "Me", 1, 4, 90 ],
+
+["NT 3.51", "NT3.51", 2, 3, 51 ],
+["NT 4", "NT4", 2, 4, 0 ],
+
+["2000 [Professional]", "2000", 2, 5, 0, 0x0000, 1, 0],
+["2000 [Server]", "2000", 2, 5, 0, 0x0000, 2, 0],
+["[Small Business Server] 2000", "2000", 2, 5, 0, 0x0020, 2, 0],
+["2000 [Advanced Server]", "2000", 2, 5, 0, 0x0002, 2, 0],
+["2000 [Datacenter Server]", "2000", 2, 5, 0, 0x0080, 2, 0],
+
+["XP [Home Edition]", "XP/.Net", 2, 5, 1, 0x0200, 1, 0],
+["XP [Professional]", "XP/.Net", 2, 5, 1, 0x0000, 1, 0],
+["XP [Tablet PC Edition]", "XP/.Net", 2, 5, 1, 0x0000, 1, 86],
+["XP [Media Center Edition]", "XP/.Net", 2, 5, 1, 0x0000, 1, 87],
+["XP [Starter Edition]", "XP/.Net", 2, 5, 1, 0x0000, 1, 88],
+
+["2003 [Standard Edition]", "2003", 2, 5, 2, 0x0000, 2, 0],
+["[Small Business Server] 2003", "2003", 2, 5, 2, 0x0020, 2, 0],
+["{Storage Server} 2003", "2003", 2, 5, 2, 0x2000, 2, 0],
+["{Home Server}", "2003", 2, 5, 2, 0x8000, 2, 0],
+
+["{Compute Cluster Server} 2003", "2003", 2, 5, 2, 0x4000, 2, 0],
+["2003 [Datacenter Edition]", "2003", 2, 5, 2, 0x0080, 2, 0],
+["2003 [Enterprise Edition]", "2003", 2, 5, 2, 0x0002, 2, 0],
+["2003 [Web Edition]", "2003", 2, 5, 2, 0x0400, 2, 0],
+
+["2003 [R2 Standard Edition]", "2003", 2, 5, 2, 0x0000, 2, 89],
+["[Small Business Server] 2003 R2", "2003", 2, 5, 2, 0x0020, 2, 89],
+["{Storage Server} 2003 R2", "2003", 2, 5, 2, 0x2000, 2, 89],
+# ??? test for more R2 versions?
+);
+
+my @amd64_tests = (
+["{XP Professional x64 Edition}", "2003", 2, 5, 2, 0x0000, 1, 0],
+["2003 [Datacenter x64 Edition]", "2003", 2, 5, 2, 0x0080, 2, 0],
+["2003 [Enterprise x64 Edition]", "2003", 2, 5, 2, 0x0002, 2, 0],
+["2003 [Standard x64 Edition]", "2003", 2, 5, 2, 0x0000, 2, 0],
);
-plan tests => 2*scalar(@tests) + 1;
+my @dual_tests = (
+["Vista", "Vista", 2, 6, 0 ],
+
+["Vista [Starter]", "Vista", 2, 6, 0, 0x0b ],
+["Vista [Home Basic]", "Vista", 2, 6, 0, 0x02 ],
+["Vista [Home Premium]", "Vista", 2, 6, 0, 0x03 ],
+["Vista [Business]", "Vista", 2, 6, 0, 0x06 ],
+["Vista [Enterprise]", "Vista", 2, 6, 0, 0x04 ],
+["Vista [Ultimate]", "Vista", 2, 6, 0, 0x01 ],
+
+#["Vista Business for Embedded Systems", "Vista", 2, 6, 0 ],
+#["Vista Ultimate for Embedded Systems", "Vista", 2, 6, 0 ],
+
+["2008 [Standard]", "2008", 2, 6, 0, 0x07, 2 ],
+["2008 [Enterprise]", "2008", 2, 6, 0, 0x04, 2 ],
+["[HPC Server] 2008", "2008", 2, 6, 0, 0x12, 2 ],
+["[Web Server] 2008", "2008", 2, 6, 0, 0x11, 2 ],
+#["[Storage Server] 2008", "2008", 2, 6, 0, ????, 2 ],
+["[Small Business Server] 2008", "2008", 2, 6, 0, 0x09, 2, 0 ],
+
+# * Windows Server 2008 Standard (x86 and x86-64)
+# * Windows Server 2008 Enterprise (x86 and x86-64)
+# * Windows HPC Server 2008 (replacing Windows Compute Cluster Server 2003)
+# * Windows Web Server 2008 (x86 and x86-64)
+# * Windows Storage Server 2008 (x86 and x86-64)
+# * Windows Small Business Server 2008 (Codenamed "Cougar") (x86-64) for small businesses
+# * Windows Essential Business Server 2008 (Codenamed "Centro") (x86-64) for medium-sized businesses [25]
+# * Windows Server 2008 for Itanium-based Systems
+# * Windows Server 2008 Foundation
+#
+# Server Core is available in the Web, Standard, Enterprise and Datacenter editions.
+
+["7", "7", 2, 6, 1 ],
+["7 [Starter]", "7", 2, 6, 1, 0x0b ],
+["7 [Home Basic]", "7", 2, 6, 1, 0x02 ],
+["7 [Home Premium]", "7", 2, 6, 1, 0x03 ],
+["7 [Professional]", "7", 2, 6, 1, 0x30 ],
+["7 [Enterprise]", "7", 2, 6, 1, 0x04 ],
+["7 [Ultimate]", "7", 2, 6, 1, 0x01 ],
+
+
+["2008 [R2]", "2008", 2, 6, 1, 0x00, 2, 89 ],
+["[Small Business Server] 2008 R2", "2008", 2, 6, 1, 0x09, 2, 89 ],
+
+);
+
+my @ia64_tests = (
+["2003 [Datacenter Edition for Itanium-based Systems]", "2003", 2, 5, 2, 0x0080, 2, 0],
+["2003 [Enterprise Edition for Itanium-based Systems]", "2003", 2, 5, 2, 0x0002, 2, 0],
+);
+
+plan tests => 3 * (@intel_tests + @amd64_tests + 2*@dual_tests + @ia64_tests);
# 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||"");
+sub check {
+ my($test, $arch) = @_;
+ my($pretty, $expect, $id, $major, $minor, $sm, $pt, $metrics, $tag) = @$test;
+ $metrics = [$metrics] if defined($metrics) && not ref $metrics;
+ $tag ||= "";
+
+ unless ($tag) {
+ ($pretty, $tag) = ("$1$2$3", "$2") if $pretty =~ /^(.*)\[(.*)\](.*)$/;
+ ($pretty, $tag) = ("$1$2$3", "Windows $2") if $pretty =~ /^(.*)\{(.*)\}(.*)$/;
+ $tag = "R2 $tag" if $tag !~ /R2/ && $pretty =~ /R2$/;
+ }
+
+ # All display names start with "Windows";
+ # and 2003/2008 start with "Windows Server"
+ unless ($pretty eq "Win32s") {
+ my $prefix = "Windows";
+ $prefix .= " Server" if $pretty =~ /^200[38]/;
+ $pretty = "$prefix $pretty";
+ }
+
+ # @dual_tests: Vista and later all come in both 32-bit and 64-bit versions
+ if ($id == 2 && $major >= 6) {
+ my $suffix = "";
+ $suffix = " (32-bit)" if $arch == Win32::PROCESSOR_ARCHITECTURE_INTEL;
+ $suffix = " (64-bit)" if $arch == Win32::PROCESSOR_ARCHITECTURE_AMD64;
+ $_ .= $suffix for $pretty, $tag;
+ $tag =~ s/^\s*//;
+ }
+
+ # We pass the same value for $suitemask and $productinfo. The former is
+ # used for Windows up to 2003, the latter is used for Vista and later.
+ my($os, $desc) = Win32::_GetOSName("", $major||0, $minor||0, 0,
+ $id, $sm||0, $pt||1, $sm||0, $arch, $metrics);
+ my $display = Win32::GetOSDisplayName($os, $desc);
+
+ note($pretty);
+ is($display, $pretty);
+ is($os, "Win$expect", "os: $os");
+ is($desc, $tag, "desc: $desc");
}
-# 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);
+check($_, Win32::PROCESSOR_ARCHITECTURE_INTEL) for @intel_tests, @dual_tests;
+check($_, Win32::PROCESSOR_ARCHITECTURE_AMD64) for @amd64_tests, @dual_tests;
+check($_, Win32::PROCESSOR_ARCHITECTURE_IA64) for @ia64_tests;
+
diff --git a/dist/Storable/Storable.xs b/dist/Storable/Storable.xs index 531855abf1..fa510b00b9 100644 --- a/dist/Storable/Storable.xs +++ b/dist/Storable/Storable.xs @@ -6386,14 +6386,17 @@ init_perinterp() # Same as pstore(), but network order is used for integers and doubles are # emitted as strings. -void +SV * pstore(f,obj) OutputStream f SV * obj ALIAS: net_pstore = 1 PPCODE: - ST(0) = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef; + RETVAL = do_store(aTHX_ f, obj, 0, ix, (SV **)0) ? &PL_sv_yes : &PL_sv_undef; + /* do_store() can reallocate the stack, so need a sequence point to ensure + that ST(0) knows about it. Hence using two statements. */ + ST(0) = RETVAL; XSRETURN(1); # mstore diff --git a/dist/Storable/t/blessed.t b/dist/Storable/t/blessed.t index 7c0494c840..b8ae067e40 100644 --- a/dist/Storable/t/blessed.t +++ b/dist/Storable/t/blessed.t @@ -18,7 +18,7 @@ sub BEGIN { sub ok; -use Storable qw(freeze thaw); +use Storable qw(freeze thaw store retrieve); %::immortals = (u => \undef, @@ -27,7 +27,7 @@ use Storable qw(freeze thaw); ); my $test = 12; -my $tests = $test + 6 + 2 * 6 * keys %::immortals; +my $tests = $test + 22 + 2 * 6 * keys %::immortals; print "1..$tests\n"; package SHORT_NAME; @@ -183,13 +183,70 @@ ok ++$test, $HAS_HOOK::thawed_count == 1; ok ++$test, $t; ok ++$test, ref $t eq 'HAS_HOOK'; -# Can't do this because the method is still cached by UNIVERSAL::can -# delete $INC{"HAS_HOOK.pm"}; -# undef &HAS_HOOK::STORABLE_thaw; -# -# warn HAS_HOOK->can('STORABLE_thaw'); -# $t = thaw $f; -# ok ++$test, $HAS_HOOK::loaded_count == 2; -# ok ++$test, $HAS_HOOK::thawed_count == 2; -# ok ++$test, $t; -# ok ++$test, ref $t eq 'HAS_HOOK'; +delete $INC{"HAS_HOOK.pm"}; +delete $HAS_HOOK::{STORABLE_thaw}; + +$t = thaw $f; +ok ++$test, $HAS_HOOK::loaded_count == 2; +ok ++$test, $HAS_HOOK::thawed_count == 2; +ok ++$test, $t; +ok ++$test, ref $t eq 'HAS_HOOK'; + +{ + package STRESS_THE_STACK; + + my $stress; + sub make { + bless []; + } + + sub no_op { + 0; + } + + sub STORABLE_freeze { + my $self = shift; + ++$freeze_count; + return no_op(1..(++$stress * 2000)) ? die "can't happen" : ''; + } + + sub STORABLE_thaw { + my $self = shift; + ++$thaw_count; + no_op(1..(++$stress * 2000)) && die "can't happen"; + return; + } +} + +$STRESS_THE_STACK::freeze_count = 0; +$STRESS_THE_STACK::thaw_count = 0; + +$f = freeze (STRESS_THE_STACK->make); + +ok ++$test, $STRESS_THE_STACK::freeze_count == 1; +ok ++$test, $STRESS_THE_STACK::thaw_count == 0; + +$t = thaw $f; +ok ++$test, $STRESS_THE_STACK::freeze_count == 1; +ok ++$test, $STRESS_THE_STACK::thaw_count == 1; +ok ++$test, $t; +ok ++$test, ref $t eq 'STRESS_THE_STACK'; + +my $file = "storable-testfile.$$"; +die "Temporary file '$file' already exists" if -e $file; + +END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }} + +$STRESS_THE_STACK::freeze_count = 0; +$STRESS_THE_STACK::thaw_count = 0; + +store (STRESS_THE_STACK->make, $file); + +ok ++$test, $STRESS_THE_STACK::freeze_count == 1; +ok ++$test, $STRESS_THE_STACK::thaw_count == 0; + +$t = retrieve ($file); +ok ++$test, $STRESS_THE_STACK::freeze_count == 1; +ok ++$test, $STRESS_THE_STACK::thaw_count == 1; +ok ++$test, $t; +ok ++$test, ref $t eq 'STRESS_THE_STACK'; @@ -3930,7 +3930,7 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg) rcop->op_targ = pad_alloc(rcop->op_type, SVs_PADTMP); /* /$x/ may cause an eval, since $x might be qr/(?{..})/ */ - PL_cv_has_eval = 1; + if (PL_hints & HINT_RE_EVAL) PL_cv_has_eval = 1; /* establish postfix order */ if (pm->op_pmflags & PMf_KEEP || !(PL_hints & HINT_RE_EVAL)) { @@ -1450,11 +1450,6 @@ Perl_pad_free(pTHX_ PADOFFSET po) if (PL_curpad[po] && PL_curpad[po] != &PL_sv_undef) { SvPADTMP_off(PL_curpad[po]); -#ifdef USE_ITHREADS - /* SV could be a shared hash key (eg bugid #19022) */ - if (!SvIsCOW(PL_curpad[po])) - SvREADONLY_off(PL_curpad[po]); /* could be a freed constant */ -#endif } if ((I32)po < PL_padix) PL_padix = po - 1; diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 899e4ed8e1..cb45fd4752 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -1,8 +1,10 @@ =encoding utf8 =for comment -This has been completed up to 7c7df81, except for: +This has been completed up to 558b442, except for: d9a4b459f94297889956ac3adc42707365f274c2 +bf5522a13a381257966e7ed6b731195a873b153e +9cef83062267e94311e1fd8744396e440642738e =head1 NAME @@ -91,6 +93,17 @@ L<perlunicode/The "Unicode Bug"> for details.) If their is a possibility that your code will process Unicode strings, you are B<strongly> encouraged to use this subpragma to avoid nasty surprises. +=head2 Exception Handling Backcompat Hack + +When an exception is thrown in an C<eval BLOCK>, C<$@> is now set before +unwinding, as well as being set after unwinding as the eval block exits. This +early setting supports code that has historically treated C<$@> during unwinding +as an indicator of whether the unwinding was due to an exception. These modules +had been broken by 5.13.1's change from setting C<$@> early to setting it late. +This double setting arrangement is a stopgap until the reason for unwinding can +be made properly introspectable. C<$@> has never been a reliable indicator of +this. + =head1 Security XXX Any security-related notices go here. In particular, any security @@ -116,6 +129,19 @@ If it is absolutely necessary to have empty attribute lists (for example, because of a code generator) then avoid the error by adding a space before the C<=>. +=head2 Run-time code block in regular expressions + +Code blocks in regular expressions (C<(?{...})> and C<(??{...})>) used not +to inherit any pragmata (strict, warnings, etc.) if the regular expression +was compiled at run time as happens in cases like these two: + + use re 'eval'; + $foo =~ $bar; # when $bar contains (?{...}) + $foo =~ /$bar(?{ $finished = 1 })/; + +This was a bug, which has now been fixed. But it has the potential to break +any code that was relying on this bug. + =head1 Deprecations XXX Any deprecated features, syntax, modules etc. should be listed here. @@ -195,6 +221,10 @@ XXX =item * +C<ExtUtils::CBuilder> has been upgraded from 0.2703 to 0.2800 + +=item * + C<if> has been upgraded from 0.06 to 0.0601. =item * @@ -1645,6 +1645,40 @@ Perl_die_unwind(pTHX_ SV *msv) I32 cxix; I32 gimme; + /* + * Historically, perl used to set ERRSV ($@) early in the die + * process and rely on it not getting clobbered during unwinding. + * That sucked, because it was liable to get clobbered, so the + * setting of ERRSV used to emit the exception from eval{} has + * been moved to much later, after unwinding (see just before + * JMPENV_JUMP below). However, some modules were relying on the + * early setting, by examining $@ during unwinding to use it as + * a flag indicating whether the current unwinding was caused by + * an exception. It was never a reliable flag for that purpose, + * being totally open to false positives even without actual + * clobberage, but was useful enough for production code to + * semantically rely on it. + * + * We'd like to have a proper introspective interface that + * explicitly describes the reason for whatever unwinding + * operations are currently in progress, so that those modules + * work reliably and $@ isn't further overloaded. But we don't + * have one yet. In its absence, as a stopgap measure, ERRSV is + * now *additionally* set here, before unwinding, to serve as the + * (unreliable) flag that it used to. + * + * This behaviour is temporary, and should be removed when a + * proper way to detect exceptional unwinding has been developed. + * As of 2010-12, the authors of modules relying on the hack + * are aware of the issue, because the modules failed on + * perls 5.13.{1..7} which had late setting of $@ without this + * early-setting hack. + */ + if (!(in_eval & EVAL_KEEPERR)) { + SvTEMP_off(exceptsv); + sv_setsv(ERRSV, exceptsv); + } + while ((cxix = dopoptoeval(cxstack_ix)) < 0 && PL_curstackinfo->si_prev) { @@ -3058,8 +3092,27 @@ Perl_sv_compile_2op_is_broken(pTHX_ SV *sv, OP **startop, const char *code, /* we get here either during compilation, or via pp_regcomp at runtime */ runtime = IN_PERL_RUNTIME; if (runtime) + { runcv = find_runcv(NULL); + /* At run time, we have to fetch the hints from PL_curcop. */ + PL_hints = PL_curcop->cop_hints; + if (PL_hints & HINT_LOCALIZE_HH) { + /* SAVEHINTS created a new HV in PL_hintgv, which we + need to GC */ + SvREFCNT_dec(GvHV(PL_hintgv)); + GvHV(PL_hintgv) = + refcounted_he_chain_2hv(PL_curcop->cop_hints_hash, 0); + hv_magic(GvHV(PL_hintgv), NULL, PERL_MAGIC_hints); + } + SAVECOMPILEWARNINGS(); + PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings); + cophh_free(CopHINTHASH_get(&PL_compiling)); + /* XXX Does this need to avoid copying a label? */ + PL_compiling.cop_hints_hash + = cophh_copy(PL_curcop->cop_hints_hash); + } + PL_op = &dummy; PL_op->op_type = OP_ENTEREVAL; PL_op->op_flags = 0; /* Avoid uninit warning. */ @@ -7445,11 +7445,19 @@ tryagain: *flagp |= HASWIDTH|SIMPLE; goto finish_meta_pat; case 'd': - ret = reg_node(pRExC_state, DIGIT); + if (LOC) { + ret = reg_node(pRExC_state, (U8)(DIGITL)); + } else { + ret = reg_node(pRExC_state, (U8)(DIGIT)); + } *flagp |= HASWIDTH|SIMPLE; goto finish_meta_pat; case 'D': - ret = reg_node(pRExC_state, NDIGIT); + if (LOC) { + ret = reg_node(pRExC_state, (U8)(NDIGITL)); + } else { + ret = reg_node(pRExC_state, (U8)(NDIGIT)); + } *flagp |= HASWIDTH|SIMPLE; goto finish_meta_pat; case 'R': @@ -9607,7 +9615,7 @@ Perl_regprop(pTHX_ const regexp *prog, SV *sv, const regnode *o) else if (k == REF || k == OPEN || k == CLOSE || k == GROUPP || OP(o)==ACCEPT) { Perl_sv_catpvf(aTHX_ sv, "%d", (int)ARG(o)); /* Parenth number */ if ( RXp_PAREN_NAMES(prog) ) { - if ( k != REF || (OP(o) != NREF && OP(o) != NREFF && OP(o) != NREFFL && OP(o) != NREFFU)) { + if ( k != REF || (OP(o) < NREF)) { AV *list= MUTABLE_AV(progi->data->data[progi->name_list_idx]); SV **name= av_fetch(list, ARG(o), 0 ); if (name) diff --git a/regcomp.sym b/regcomp.sym index 4e787a7bf3..707da08c77 100644 --- a/regcomp.sym +++ b/regcomp.sym @@ -16,12 +16,12 @@ -#* Exit points (0,1) +#* Exit points END END, no ; End of program. SUCCEED END, no ; Return from a subroutine, basically. -#* Anchors: (2..13) +#* Anchors: BOL BOL, no ; Match "" at beginning of line. MBOL BOL, no ; Same, assuming multiline. @@ -36,7 +36,7 @@ NBOUND NBOUND, no ; Match "" at any word non-boundary NBOUNDL NBOUND, no ; Match "" at any word non-boundary GPOS GPOS, no ; Matches where last m//g left off. -#* [Special] alternatives: (14..30) +#* [Special] alternatives: REG_ANY REG_ANY, no 0 S ; Match any one character (except newline). SANY REG_ANY, no 0 S ; Match any one character. @@ -51,12 +51,12 @@ SPACEL SPACE, no 0 S ; Match any whitespace char in locale NSPACE NSPACE, no 0 S ; Match any non-whitespace character NSPACEL NSPACE, no 0 S ; Match any non-whitespace char in locale DIGIT DIGIT, no 0 S ; Match any numeric character -DIGITL DIGIT, no ; Match any numeric character in locale +DIGITL DIGIT, no 0 S ; Match any numeric character in locale NDIGIT NDIGIT, no 0 S ; Match any non-numeric character -NDIGITL NDIGIT, no ; Match any non-numeric character in locale +NDIGITL NDIGIT, no 0 S ; Match any non-numeric character in locale CLUMP CLUMP, no 0 V ; Match any extended grapheme cluster sequence -#* Alternation (31) +#* Alternation # BRANCH The set of branches constituting a single choice are hooked # together with their "next" pointers, since precedence prevents @@ -68,26 +68,27 @@ CLUMP CLUMP, no 0 V ; Match any extended grapheme cluster sequence # BRANCH BRANCH, node 0 V ; Match this alternative, or the next... -#*Back pointer (32) +#*Back pointer # BACK Normal "next" pointers all implicitly point forward; BACK # exists to make loop structures possible. # not used BACK BACK, no 0 V ; Match "", "next" ptr points backward. -#*Literals (33..35) +#*Literals EXACT EXACT, str ; Match this string (preceded by length). EXACTF EXACT, str ; Match this string, folded, native charset semantics for non-utf8 (prec. by length). EXACTFL EXACT, str ; Match this string, folded in locale (w/len). +EXACTFU EXACT, str ; Match this string, folded, Unicode semantics for non-utf8 (prec. by length). -#*Do nothing types (36..37) +#*Do nothing types NOTHING NOTHING, no ; Match empty string. # A variant of above which delimits a group, thus stops optimizations TAIL NOTHING, no ; Match empty string. Can jump here from outside. -#*Loops (38..44) +#*Loops # STAR,PLUS '?', and complex '*' and '+', are implemented as circular # BRANCH structures using BACK. Simple cases (one character @@ -105,7 +106,7 @@ CURLYX CURLY, sv 2 V ; Match this complex thing {n,m} times. # This terminator creates a loop structure for CURLYX WHILEM WHILEM, no 0 V ; Do curly processing and see if rest matches. -#*Buffer related (45..49) +#*Buffer related # OPEN,CLOSE,GROUPP ...are numbered at compile time. OPEN OPEN, num 1 ; Mark this point in input as start of #n. @@ -114,7 +115,16 @@ CLOSE CLOSE, num 1 ; Analogous to OPEN. REF REF, num 1 V ; Match some already matched string REFF REF, num 1 V ; Match already matched string, folded using native charset semantics for non-utf8 REFFL REF, num 1 V ; Match already matched string, folded in loc. +# REFFU and NREFFU could have been implemented using the FLAGS field of the +# regnode, but by having a separate node type, we can use the existing switch +# statement to avoid some tests +REFFU REF, num 1 V ; Match already matched string, folded using unicode semantics for non-utf8 +#*Named references. Code in regcomp.c assumes that these all are after the numbered references +NREF REF, no-sv 1 V ; Match some already matched string +NREFF REF, no-sv 1 V ; Match already matched string, folded using native charset semantics for non-utf8 +NREFFL REF, no-sv 1 V ; Match already matched string, folded in loc. +NREFFU REF, num 1 V ; Match already matched string, folded using unicode semantics for non-utf8 IFMATCH BRANCHJ, off 1 . 2 ; Succeeds if the following matches. UNLESSM BRANCHJ, off 1 . 2 ; Fails if the following matches. @@ -122,24 +132,24 @@ SUSPEND BRANCHJ, off 1 V 1 ; "Independent" sub-RE. IFTHEN BRANCHJ, off 1 V 1 ; Switch, should be preceeded by switcher . GROUPP GROUPP, num 1 ; Whether the group matched. -#*Support for long RE (55..56) +#*Support for long RE LONGJMP LONGJMP, off 1 . 1 ; Jump far away. BRANCHJ BRANCHJ, off 1 V 1 ; BRANCH with long offset. -#*The heavy worker (57) +#*The heavy worker EVAL EVAL, evl 1 ; Execute some Perl code. -#*Modifiers (58..59) +#*Modifiers MINMOD MINMOD, no ; Next operator is not greedy. LOGICAL LOGICAL, no ; Next opcode should set the flag only. -# This is not used yet (60) +# This is not used yet RENUM BRANCHJ, off 1 . 1 ; Group with independently numbered parens. -#*Trie Related (61..62) +#*Trie Related # Behave the same as A|LIST|OF|WORDS would. The '..C' variants have # inline charclass data (ascii only), the 'C' store it in the structure. @@ -152,17 +162,11 @@ TRIEC TRIE,trie charclass ; Same as TRIE, but with embedded charclass da AHOCORASICK TRIE, trie 1 ; Aho Corasick stclass. flags==type AHOCORASICKC TRIE,trie charclass ; Same as AHOCORASICK, but with embedded charclass data -#*Regex Subroutines (65..66) +#*Regex Subroutines GOSUB GOSUB, num/ofs 2L ; recurse to paren arg1 at (signed) ofs arg2 GOSTART GOSTART, no ; recurse to start of pattern -#*Named references (67..69) -NREF REF, no-sv 1 V ; Match some already matched string -NREFF REF, no-sv 1 V ; Match already matched string, folded using native charset semantics for non-utf8 -NREFFL REF, no-sv 1 V ; Match already matched string, folded in loc. - - -#*Special conditionals (70..72) +#*Special conditionals NGROUPP NGROUPP, no-sv 1 ; Whether the group matched. INSUBP INSUBP, num 1 ; Whether we are in a specific recurse. DEFINEP DEFINEP, none 1 ; Never execute directly. @@ -192,16 +196,9 @@ HORIZWS HORIZWS, none 0 S ; horizontal whitespace (Perl 6) NHORIZWS NHORIZWS, none 0 S ; not horizontal whitespace (Perl 6) FOLDCHAR FOLDCHAR, codepoint 1 ; codepoint with tricky case folding properties. -EXACTFU EXACT, str ; Match this string, folded, Unicode semantics for non-utf8 (prec. by length). - -# These could have been implemented using the FLAGS field of the regnode, but -# by having a separate node type, we can use the existing switch statement to -# avoid some tests -REFFU REF, num 1 V ; Match already matched string, folded using unicode semantics for non-utf8 -NREFFU REF, num 1 V ; Match already matched string, folded using unicode semantics for non-utf8 -# NEW STUFF ABOVE THIS LINE +# NEW STUFF SOMEWHERE ABOVE THIS LINE ################################################################################ @@ -1645,7 +1645,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, ); case SPACEL: REXEC_FBC_CSCAN_TAINT( - *s == ' ' || isSPACE_LC_utf8((U8*)s), + isSPACE_LC_utf8((U8*)s), isSPACE_LC(*s) ); case NSPACE: @@ -1656,7 +1656,7 @@ S_find_byclass(pTHX_ regexp * prog, const regnode *c, char *s, ); case NSPACEL: REXEC_FBC_CSCAN_TAINT( - !(*s == ' ' || isSPACE_LC_utf8((U8*)s)), + !isSPACE_LC_utf8((U8*)s), !isSPACE_LC(*s) ); case DIGIT: @@ -6036,7 +6036,7 @@ S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth) if (utf8_target) { loceol = PL_regeol; while (hardcount < max && scan < loceol && - (*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { + isSPACE_LC_utf8((U8*)scan)) { scan += UTF8SKIP(scan); hardcount++; } @@ -6071,7 +6071,7 @@ S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth) if (utf8_target) { loceol = PL_regeol; while (hardcount < max && scan < loceol && - !(*scan == ' ' || isSPACE_LC_utf8((U8*)scan))) { + !isSPACE_LC_utf8((U8*)scan)) { scan += UTF8SKIP(scan); hardcount++; } @@ -6094,6 +6094,20 @@ S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth) scan++; } break; + case DIGITL: + PL_reg_flags |= RF_tainted; + if (utf8_target) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + isDIGIT_LC_utf8((U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && isDIGIT_LC(*scan)) + scan++; + } + break; case NDIGIT: if (utf8_target) { loceol = PL_regeol; @@ -6107,6 +6121,20 @@ S_regrepeat(pTHX_ const regexp *prog, const regnode *p, I32 max, int depth) while (scan < loceol && !isDIGIT(*scan)) scan++; } + case NDIGITL: + PL_reg_flags |= RF_tainted; + if (utf8_target) { + loceol = PL_regeol; + while (hardcount < max && scan < loceol && + !isDIGIT_LC_utf8((U8*)scan)) { + scan += UTF8SKIP(scan); + hardcount++; + } + } else { + while (scan < loceol && !isDIGIT_LC(*scan)) + scan++; + } + break; case LNBREAK: if (utf8_target) { loceol = PL_regeol; @@ -190,20 +190,17 @@ equivalent to the following snippet: if (SvMAGICAL(sv)) mg_get(sv); - if (SvROK(sv) && - (tmpsv = (SV*)SvRV(sv)) && - SvTYPE(tmpsv) == SVt_PVMG && - (tmpmg = mg_find(tmpsv, PERL_MAGIC_qr))) - { - return (REGEXP *)tmpmg->mg_obj; - } + if (SvROK(sv)) + sv = MUTABLE_SV(SvRV(sv)); + if (SvTYPE(sv) == SVt_REGEXP) + return (REGEXP*) sv; NULL will be returned if a REGEXP* is not found. =for apidoc Am|bool|SvRXOK|SV* sv -Returns a boolean indicating whether the SV contains qr magic -(PERL_MAGIC_qr). +Returns a boolean indicating whether the SV (or the one it references) +is a REGEXP. If you want to do something with the REGEXP* later use SvRX instead and check for NULL. diff --git a/regnodes.h b/regnodes.h index 09ab661561..35a4cc188c 100644 --- a/regnodes.h +++ b/regnodes.h @@ -45,62 +45,62 @@ #define EXACT 33 /* 0x21 Match this string (preceded by length). */ #define EXACTF 34 /* 0x22 Match this string, folded, native charset semantics for non-utf8 (prec. by length). */ #define EXACTFL 35 /* 0x23 Match this string, folded in locale (w/len). */ -#define NOTHING 36 /* 0x24 Match empty string. */ -#define TAIL 37 /* 0x25 Match empty string. Can jump here from outside. */ -#define STAR 38 /* 0x26 Match this (simple) thing 0 or more times. */ -#define PLUS 39 /* 0x27 Match this (simple) thing 1 or more times. */ -#define CURLY 40 /* 0x28 Match this simple thing {n,m} times. */ -#define CURLYN 41 /* 0x29 Capture next-after-this simple thing */ -#define CURLYM 42 /* 0x2a Capture this medium-complex thing {n,m} times. */ -#define CURLYX 43 /* 0x2b Match this complex thing {n,m} times. */ -#define WHILEM 44 /* 0x2c Do curly processing and see if rest matches. */ -#define OPEN 45 /* 0x2d Mark this point in input as start of */ -#define CLOSE 46 /* 0x2e Analogous to OPEN. */ -#define REF 47 /* 0x2f Match some already matched string */ -#define REFF 48 /* 0x30 Match already matched string, folded using native charset semantics for non-utf8 */ -#define REFFL 49 /* 0x31 Match already matched string, folded in loc. */ -#define IFMATCH 50 /* 0x32 Succeeds if the following matches. */ -#define UNLESSM 51 /* 0x33 Fails if the following matches. */ -#define SUSPEND 52 /* 0x34 "Independent" sub-RE. */ -#define IFTHEN 53 /* 0x35 Switch, should be preceeded by switcher . */ -#define GROUPP 54 /* 0x36 Whether the group matched. */ -#define LONGJMP 55 /* 0x37 Jump far away. */ -#define BRANCHJ 56 /* 0x38 BRANCH with long offset. */ -#define EVAL 57 /* 0x39 Execute some Perl code. */ -#define MINMOD 58 /* 0x3a Next operator is not greedy. */ -#define LOGICAL 59 /* 0x3b Next opcode should set the flag only. */ -#define RENUM 60 /* 0x3c Group with independently numbered parens. */ -#define TRIE 61 /* 0x3d Match many EXACT(F[LU]?)? at once. flags==type */ -#define TRIEC 62 /* 0x3e Same as TRIE, but with embedded charclass data */ -#define AHOCORASICK 63 /* 0x3f Aho Corasick stclass. flags==type */ -#define AHOCORASICKC 64 /* 0x40 Same as AHOCORASICK, but with embedded charclass data */ -#define GOSUB 65 /* 0x41 recurse to paren arg1 at (signed) ofs arg2 */ -#define GOSTART 66 /* 0x42 recurse to start of pattern */ -#define NREF 67 /* 0x43 Match some already matched string */ -#define NREFF 68 /* 0x44 Match already matched string, folded using native charset semantics for non-utf8 */ -#define NREFFL 69 /* 0x45 Match already matched string, folded in loc. */ -#define NGROUPP 70 /* 0x46 Whether the group matched. */ -#define INSUBP 71 /* 0x47 Whether we are in a specific recurse. */ -#define DEFINEP 72 /* 0x48 Never execute directly. */ -#define ENDLIKE 73 /* 0x49 Used only for the type field of verbs */ -#define OPFAIL 74 /* 0x4a Same as (?!) */ -#define ACCEPT 75 /* 0x4b Accepts the current matched string. */ -#define VERB 76 /* 0x4c Used only for the type field of verbs */ -#define PRUNE 77 /* 0x4d Pattern fails at this startpoint if no-backtracking through this */ -#define MARKPOINT 78 /* 0x4e Push the current location for rollback by cut. */ -#define SKIP 79 /* 0x4f On failure skip forward (to the mark) before retrying */ -#define COMMIT 80 /* 0x50 Pattern fails outright if backtracking through this */ -#define CUTGROUP 81 /* 0x51 On failure go to the next alternation in the group */ -#define KEEPS 82 /* 0x52 $& begins here. */ -#define LNBREAK 83 /* 0x53 generic newline pattern */ -#define VERTWS 84 /* 0x54 vertical whitespace (Perl 6) */ -#define NVERTWS 85 /* 0x55 not vertical whitespace (Perl 6) */ -#define HORIZWS 86 /* 0x56 horizontal whitespace (Perl 6) */ -#define NHORIZWS 87 /* 0x57 not horizontal whitespace (Perl 6) */ -#define FOLDCHAR 88 /* 0x58 codepoint with tricky case folding properties. */ -#define EXACTFU 89 /* 0x59 Match this string, folded, Unicode semantics for non-utf8 (prec. by length). */ -#define REFFU 90 /* 0x5a Match already matched string, folded using unicode semantics for non-utf8 */ -#define NREFFU 91 /* 0x5b Match already matched string, folded using unicode semantics for non-utf8 */ +#define EXACTFU 36 /* 0x24 Match this string, folded, Unicode semantics for non-utf8 (prec. by length). */ +#define NOTHING 37 /* 0x25 Match empty string. */ +#define TAIL 38 /* 0x26 Match empty string. Can jump here from outside. */ +#define STAR 39 /* 0x27 Match this (simple) thing 0 or more times. */ +#define PLUS 40 /* 0x28 Match this (simple) thing 1 or more times. */ +#define CURLY 41 /* 0x29 Match this simple thing {n,m} times. */ +#define CURLYN 42 /* 0x2a Capture next-after-this simple thing */ +#define CURLYM 43 /* 0x2b Capture this medium-complex thing {n,m} times. */ +#define CURLYX 44 /* 0x2c Match this complex thing {n,m} times. */ +#define WHILEM 45 /* 0x2d Do curly processing and see if rest matches. */ +#define OPEN 46 /* 0x2e Mark this point in input as start of */ +#define CLOSE 47 /* 0x2f Analogous to OPEN. */ +#define REF 48 /* 0x30 Match some already matched string */ +#define REFF 49 /* 0x31 Match already matched string, folded using native charset semantics for non-utf8 */ +#define REFFL 50 /* 0x32 Match already matched string, folded in loc. */ +#define REFFU 51 /* 0x33 Match already matched string, folded using unicode semantics for non-utf8 */ +#define NREF 52 /* 0x34 Match some already matched string */ +#define NREFF 53 /* 0x35 Match already matched string, folded using native charset semantics for non-utf8 */ +#define NREFFL 54 /* 0x36 Match already matched string, folded in loc. */ +#define NREFFU 55 /* 0x37 Match already matched string, folded using unicode semantics for non-utf8 */ +#define IFMATCH 56 /* 0x38 Succeeds if the following matches. */ +#define UNLESSM 57 /* 0x39 Fails if the following matches. */ +#define SUSPEND 58 /* 0x3a "Independent" sub-RE. */ +#define IFTHEN 59 /* 0x3b Switch, should be preceeded by switcher . */ +#define GROUPP 60 /* 0x3c Whether the group matched. */ +#define LONGJMP 61 /* 0x3d Jump far away. */ +#define BRANCHJ 62 /* 0x3e BRANCH with long offset. */ +#define EVAL 63 /* 0x3f Execute some Perl code. */ +#define MINMOD 64 /* 0x40 Next operator is not greedy. */ +#define LOGICAL 65 /* 0x41 Next opcode should set the flag only. */ +#define RENUM 66 /* 0x42 Group with independently numbered parens. */ +#define TRIE 67 /* 0x43 Match many EXACT(F[LU]?)? at once. flags==type */ +#define TRIEC 68 /* 0x44 Same as TRIE, but with embedded charclass data */ +#define AHOCORASICK 69 /* 0x45 Aho Corasick stclass. flags==type */ +#define AHOCORASICKC 70 /* 0x46 Same as AHOCORASICK, but with embedded charclass data */ +#define GOSUB 71 /* 0x47 recurse to paren arg1 at (signed) ofs arg2 */ +#define GOSTART 72 /* 0x48 recurse to start of pattern */ +#define NGROUPP 73 /* 0x49 Whether the group matched. */ +#define INSUBP 74 /* 0x4a Whether we are in a specific recurse. */ +#define DEFINEP 75 /* 0x4b Never execute directly. */ +#define ENDLIKE 76 /* 0x4c Used only for the type field of verbs */ +#define OPFAIL 77 /* 0x4d Same as (?!) */ +#define ACCEPT 78 /* 0x4e Accepts the current matched string. */ +#define VERB 79 /* 0x4f Used only for the type field of verbs */ +#define PRUNE 80 /* 0x50 Pattern fails at this startpoint if no-backtracking through this */ +#define MARKPOINT 81 /* 0x51 Push the current location for rollback by cut. */ +#define SKIP 82 /* 0x52 On failure skip forward (to the mark) before retrying */ +#define COMMIT 83 /* 0x53 Pattern fails outright if backtracking through this */ +#define CUTGROUP 84 /* 0x54 On failure go to the next alternation in the group */ +#define KEEPS 85 /* 0x55 $& begins here. */ +#define LNBREAK 86 /* 0x56 generic newline pattern */ +#define VERTWS 87 /* 0x57 vertical whitespace (Perl 6) */ +#define NVERTWS 88 /* 0x58 not vertical whitespace (Perl 6) */ +#define HORIZWS 89 /* 0x59 horizontal whitespace (Perl 6) */ +#define NHORIZWS 90 /* 0x5a not horizontal whitespace (Perl 6) */ +#define FOLDCHAR 91 /* 0x5b codepoint with tricky case folding properties. */ #define OPTIMIZED 92 /* 0x5c Placeholder for dump. */ #define PSEUDO 93 /* 0x5d Pseudo opcode for internal use. */ /* ------------ States ------------- */ @@ -187,6 +187,7 @@ EXTCONST U8 PL_regkind[] = { EXACT, /* EXACT */ EXACT, /* EXACTF */ EXACT, /* EXACTFL */ + EXACT, /* EXACTFU */ NOTHING, /* NOTHING */ NOTHING, /* TAIL */ STAR, /* STAR */ @@ -201,6 +202,11 @@ EXTCONST U8 PL_regkind[] = { REF, /* REF */ REF, /* REFF */ REF, /* REFFL */ + REF, /* REFFU */ + REF, /* NREF */ + REF, /* NREFF */ + REF, /* NREFFL */ + REF, /* NREFFU */ BRANCHJ, /* IFMATCH */ BRANCHJ, /* UNLESSM */ BRANCHJ, /* SUSPEND */ @@ -218,9 +224,6 @@ EXTCONST U8 PL_regkind[] = { TRIE, /* AHOCORASICKC */ GOSUB, /* GOSUB */ GOSTART, /* GOSTART */ - REF, /* NREF */ - REF, /* NREFF */ - REF, /* NREFFL */ NGROUPP, /* NGROUPP */ INSUBP, /* INSUBP */ DEFINEP, /* DEFINEP */ @@ -240,9 +243,6 @@ EXTCONST U8 PL_regkind[] = { HORIZWS, /* HORIZWS */ NHORIZWS, /* NHORIZWS */ FOLDCHAR, /* FOLDCHAR */ - EXACT, /* EXACTFU */ - REF, /* REFFU */ - REF, /* NREFFU */ NOTHING, /* OPTIMIZED */ PSEUDO, /* PSEUDO */ /* ------------ States ------------- */ @@ -329,6 +329,7 @@ static const U8 regarglen[] = { 0, /* EXACT */ 0, /* EXACTF */ 0, /* EXACTFL */ + 0, /* EXACTFU */ 0, /* NOTHING */ 0, /* TAIL */ 0, /* STAR */ @@ -343,6 +344,11 @@ static const U8 regarglen[] = { EXTRA_SIZE(struct regnode_1), /* REF */ EXTRA_SIZE(struct regnode_1), /* REFF */ EXTRA_SIZE(struct regnode_1), /* REFFL */ + EXTRA_SIZE(struct regnode_1), /* REFFU */ + EXTRA_SIZE(struct regnode_1), /* NREF */ + EXTRA_SIZE(struct regnode_1), /* NREFF */ + EXTRA_SIZE(struct regnode_1), /* NREFFL */ + EXTRA_SIZE(struct regnode_1), /* NREFFU */ EXTRA_SIZE(struct regnode_1), /* IFMATCH */ EXTRA_SIZE(struct regnode_1), /* UNLESSM */ EXTRA_SIZE(struct regnode_1), /* SUSPEND */ @@ -360,9 +366,6 @@ static const U8 regarglen[] = { EXTRA_SIZE(struct regnode_charclass), /* AHOCORASICKC */ EXTRA_SIZE(struct regnode_2L), /* GOSUB */ 0, /* GOSTART */ - EXTRA_SIZE(struct regnode_1), /* NREF */ - EXTRA_SIZE(struct regnode_1), /* NREFF */ - EXTRA_SIZE(struct regnode_1), /* NREFFL */ EXTRA_SIZE(struct regnode_1), /* NGROUPP */ EXTRA_SIZE(struct regnode_1), /* INSUBP */ EXTRA_SIZE(struct regnode_1), /* DEFINEP */ @@ -382,9 +385,6 @@ static const U8 regarglen[] = { 0, /* HORIZWS */ 0, /* NHORIZWS */ EXTRA_SIZE(struct regnode_1), /* FOLDCHAR */ - 0, /* EXACTFU */ - EXTRA_SIZE(struct regnode_1), /* REFFU */ - EXTRA_SIZE(struct regnode_1), /* NREFFU */ 0, /* OPTIMIZED */ 0, /* PSEUDO */ }; @@ -428,6 +428,7 @@ static const char reg_off_by_arg[] = { 0, /* EXACT */ 0, /* EXACTF */ 0, /* EXACTFL */ + 0, /* EXACTFU */ 0, /* NOTHING */ 0, /* TAIL */ 0, /* STAR */ @@ -442,6 +443,11 @@ static const char reg_off_by_arg[] = { 0, /* REF */ 0, /* REFF */ 0, /* REFFL */ + 0, /* REFFU */ + 0, /* NREF */ + 0, /* NREFF */ + 0, /* NREFFL */ + 0, /* NREFFU */ 2, /* IFMATCH */ 2, /* UNLESSM */ 1, /* SUSPEND */ @@ -459,9 +465,6 @@ static const char reg_off_by_arg[] = { 0, /* AHOCORASICKC */ 0, /* GOSUB */ 0, /* GOSTART */ - 0, /* NREF */ - 0, /* NREFF */ - 0, /* NREFFL */ 0, /* NGROUPP */ 0, /* INSUBP */ 0, /* DEFINEP */ @@ -481,9 +484,6 @@ static const char reg_off_by_arg[] = { 0, /* HORIZWS */ 0, /* NHORIZWS */ 0, /* FOLDCHAR */ - 0, /* EXACTFU */ - 0, /* REFFU */ - 0, /* NREFFU */ 0, /* OPTIMIZED */ 0, /* PSEUDO */ }; @@ -532,62 +532,62 @@ EXTCONST char * const PL_reg_name[] = { "EXACT", /* 0x21 */ "EXACTF", /* 0x22 */ "EXACTFL", /* 0x23 */ - "NOTHING", /* 0x24 */ - "TAIL", /* 0x25 */ - "STAR", /* 0x26 */ - "PLUS", /* 0x27 */ - "CURLY", /* 0x28 */ - "CURLYN", /* 0x29 */ - "CURLYM", /* 0x2a */ - "CURLYX", /* 0x2b */ - "WHILEM", /* 0x2c */ - "OPEN", /* 0x2d */ - "CLOSE", /* 0x2e */ - "REF", /* 0x2f */ - "REFF", /* 0x30 */ - "REFFL", /* 0x31 */ - "IFMATCH", /* 0x32 */ - "UNLESSM", /* 0x33 */ - "SUSPEND", /* 0x34 */ - "IFTHEN", /* 0x35 */ - "GROUPP", /* 0x36 */ - "LONGJMP", /* 0x37 */ - "BRANCHJ", /* 0x38 */ - "EVAL", /* 0x39 */ - "MINMOD", /* 0x3a */ - "LOGICAL", /* 0x3b */ - "RENUM", /* 0x3c */ - "TRIE", /* 0x3d */ - "TRIEC", /* 0x3e */ - "AHOCORASICK", /* 0x3f */ - "AHOCORASICKC", /* 0x40 */ - "GOSUB", /* 0x41 */ - "GOSTART", /* 0x42 */ - "NREF", /* 0x43 */ - "NREFF", /* 0x44 */ - "NREFFL", /* 0x45 */ - "NGROUPP", /* 0x46 */ - "INSUBP", /* 0x47 */ - "DEFINEP", /* 0x48 */ - "ENDLIKE", /* 0x49 */ - "OPFAIL", /* 0x4a */ - "ACCEPT", /* 0x4b */ - "VERB", /* 0x4c */ - "PRUNE", /* 0x4d */ - "MARKPOINT", /* 0x4e */ - "SKIP", /* 0x4f */ - "COMMIT", /* 0x50 */ - "CUTGROUP", /* 0x51 */ - "KEEPS", /* 0x52 */ - "LNBREAK", /* 0x53 */ - "VERTWS", /* 0x54 */ - "NVERTWS", /* 0x55 */ - "HORIZWS", /* 0x56 */ - "NHORIZWS", /* 0x57 */ - "FOLDCHAR", /* 0x58 */ - "EXACTFU", /* 0x59 */ - "REFFU", /* 0x5a */ - "NREFFU", /* 0x5b */ + "EXACTFU", /* 0x24 */ + "NOTHING", /* 0x25 */ + "TAIL", /* 0x26 */ + "STAR", /* 0x27 */ + "PLUS", /* 0x28 */ + "CURLY", /* 0x29 */ + "CURLYN", /* 0x2a */ + "CURLYM", /* 0x2b */ + "CURLYX", /* 0x2c */ + "WHILEM", /* 0x2d */ + "OPEN", /* 0x2e */ + "CLOSE", /* 0x2f */ + "REF", /* 0x30 */ + "REFF", /* 0x31 */ + "REFFL", /* 0x32 */ + "REFFU", /* 0x33 */ + "NREF", /* 0x34 */ + "NREFF", /* 0x35 */ + "NREFFL", /* 0x36 */ + "NREFFU", /* 0x37 */ + "IFMATCH", /* 0x38 */ + "UNLESSM", /* 0x39 */ + "SUSPEND", /* 0x3a */ + "IFTHEN", /* 0x3b */ + "GROUPP", /* 0x3c */ + "LONGJMP", /* 0x3d */ + "BRANCHJ", /* 0x3e */ + "EVAL", /* 0x3f */ + "MINMOD", /* 0x40 */ + "LOGICAL", /* 0x41 */ + "RENUM", /* 0x42 */ + "TRIE", /* 0x43 */ + "TRIEC", /* 0x44 */ + "AHOCORASICK", /* 0x45 */ + "AHOCORASICKC", /* 0x46 */ + "GOSUB", /* 0x47 */ + "GOSTART", /* 0x48 */ + "NGROUPP", /* 0x49 */ + "INSUBP", /* 0x4a */ + "DEFINEP", /* 0x4b */ + "ENDLIKE", /* 0x4c */ + "OPFAIL", /* 0x4d */ + "ACCEPT", /* 0x4e */ + "VERB", /* 0x4f */ + "PRUNE", /* 0x50 */ + "MARKPOINT", /* 0x51 */ + "SKIP", /* 0x52 */ + "COMMIT", /* 0x53 */ + "CUTGROUP", /* 0x54 */ + "KEEPS", /* 0x55 */ + "LNBREAK", /* 0x56 */ + "VERTWS", /* 0x57 */ + "NVERTWS", /* 0x58 */ + "HORIZWS", /* 0x59 */ + "NHORIZWS", /* 0x5a */ + "FOLDCHAR", /* 0x5b */ "OPTIMIZED", /* 0x5c */ "PSEUDO", /* 0x5d */ /* ------------ States ------------- */ @@ -684,8 +684,8 @@ EXTCONST U8 PL_varies[] __attribute__deprecated__; #else EXTCONST U8 PL_varies[] __attribute__deprecated__ = { CLUMP, BRANCH, BACK, STAR, PLUS, CURLY, CURLYN, CURLYM, CURLYX, WHILEM, - REF, REFF, REFFL, SUSPEND, IFTHEN, BRANCHJ, NREF, NREFF, NREFFL, REFFU, - NREFFU, + REF, REFF, REFFL, REFFU, NREF, NREFF, NREFFL, NREFFU, SUSPEND, IFTHEN, + BRANCHJ, 0 }; #endif /* DOINIT */ @@ -694,7 +694,7 @@ EXTCONST U8 PL_varies[] __attribute__deprecated__ = { EXTCONST U8 PL_varies_bitmask[]; #else EXTCONST U8 PL_varies_bitmask[] = { - 0x00, 0x00, 0x00, 0xC0, 0xC1, 0x9F, 0x33, 0x01, 0x38, 0x00, 0x00, 0x0C + 0x00, 0x00, 0x00, 0xC0, 0x81, 0x3F, 0xFF, 0x4C, 0x00, 0x00, 0x00, 0x00 }; #endif /* DOINIT */ @@ -707,8 +707,8 @@ EXTCONST U8 PL_simple[] __attribute__deprecated__; #else EXTCONST U8 PL_simple[] __attribute__deprecated__ = { REG_ANY, SANY, CANY, ANYOF, ALNUM, ALNUML, NALNUM, NALNUML, SPACE, - SPACEL, NSPACE, NSPACEL, DIGIT, NDIGIT, VERTWS, NVERTWS, HORIZWS, - NHORIZWS, + SPACEL, NSPACE, NSPACEL, DIGIT, DIGITL, NDIGIT, NDIGITL, VERTWS, + NVERTWS, HORIZWS, NHORIZWS, 0 }; #endif /* DOINIT */ @@ -717,7 +717,7 @@ EXTCONST U8 PL_simple[] __attribute__deprecated__ = { EXTCONST U8 PL_simple_bitmask[]; #else EXTCONST U8 PL_simple_bitmask[] = { - 0x00, 0xC0, 0xFF, 0x17, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0xF0, 0x00 + 0x00, 0xC0, 0xFF, 0x3F, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x80, 0x07 }; #endif /* DOINIT */ diff --git a/t/io/argv.t b/t/io/argv.t index d6c895d6cc..8356938d4b 100644 --- a/t/io/argv.t +++ b/t/io/argv.t @@ -137,6 +137,6 @@ unlink "Io_argv3.tmp"; **PROG** END { - 1 while unlink 'Io_argv1.tmp', 'Io_argv1.tmp_bak', + unlink_all 'Io_argv1.tmp', 'Io_argv1.tmp_bak', 'Io_argv2.tmp', 'Io_argv2.tmp_bak', 'Io_argv3.tmp'; } @@ -424,7 +424,7 @@ SKIP: { # this works on win32 only, because fs isn't casesensitive ok(-e 'X', "rename working"); - 1 while unlink 'X'; + unlink_all 'X'; chdir $wd || die "Can't cd back to $wd"; } diff --git a/t/io/nargv.t b/t/io/nargv.t index c5b84fc1e3..41417cdf1e 100644 --- a/t/io/nargv.t +++ b/t/io/nargv.t @@ -71,4 +71,4 @@ sub mkfiles { return wantarray ? @results : @results[-1]; } -END { unlink map { ($_, "$_.bak") } mkfiles(1..5) } +END { unlink_all map { ($_, "$_.bak") } mkfiles(1..5) } diff --git a/t/io/perlio.t b/t/io/perlio.t index b9f00a7f70..8b1cff3995 100644 --- a/t/io/perlio.t +++ b/t/io/perlio.t @@ -105,14 +105,14 @@ ok(close($utffh)); my $filename = find_filename($x, $perlio_tmp_file_glob); is($filename, undef, "No tmp files leaked"); - unlink $filename if defined $filename; + unlink_all $filename if defined $filename; mkdir $ENV{TMPDIR}; ok(open(my $x,"+<",undef), 'TMPDIR honored by magic temp file via 3 arg open with undef - works if TMPDIR points to an existent dir'); $filename = find_filename($x, $perlio_tmp_file_glob); is($filename, undef, "No tmp files leaked"); - unlink $filename if defined $filename; + unlink_all $filename if defined $filename; } } @@ -198,9 +198,9 @@ close ($no_perlio); END { - 1 while unlink $txt; - 1 while unlink $bin; - 1 while unlink $utf; + unlink_all $txt; + unlink_all $bin; + unlink_all $utf; rmdir $nonexistent; } diff --git a/t/lib/deprecate.t b/t/lib/deprecate.t index 92bb673c43..9e59469d46 100644 --- a/t/lib/deprecate.t +++ b/t/lib/deprecate.t @@ -57,7 +57,7 @@ for my $lib (sort keys %tests) { } delete $INC{$module}; - unlink $pm; + unlink_all $pm; } my $sub_dir = 'Optionally'; @@ -83,7 +83,7 @@ for my $lib (sort keys %tests) { } delete $INC{"$sub_dir/$module"}; - unlink $pm; + unlink_all $pm; } END { File::Path::remove_tree('lib') } diff --git a/t/op/die_unwind.t b/t/op/die_unwind.t new file mode 100644 index 0000000000..36772c4478 --- /dev/null +++ b/t/op/die_unwind.t @@ -0,0 +1,74 @@ +#!./perl + +# +# This test checks for $@ being set early during an exceptional +# unwinding, and that this early setting doesn't affect the late +# setting used to emit the exception from eval{}. The early setting is +# a backward-compatibility hack to satisfy modules that were relying on +# the historical early setting in order to detect exceptional unwinding. +# This hack should be removed when a proper way to detect exceptional +# unwinding has been developed. +# + +print "1..12\n"; +my $test_num = 0; +sub ok { + print $_[0] ? "" : "not ", "ok ", ++$test_num, "\n"; +} + +{ + package End; + sub DESTROY { $_[0]->() } + sub main::end(&) { + my($cleanup) = @_; + return bless(sub { $cleanup->() }, "End"); + } +} + +my($uerr, $val, $err); + +$@ = ""; +$val = eval { + my $c = end { $uerr = $@; $@ = "t2\n"; }; + 1; +}; $err = $@; +ok $uerr eq ""; +ok $val == 1; +ok $err eq ""; + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + my $c = end { $uerr = $@; $@ = "t2\n"; }; + 1; +}; $err = $@; +ok $uerr eq "t1\n"; +ok $val == 1; +ok $err eq ""; + +$@ = ""; +$val = eval { + my $c = end { $uerr = $@; $@ = "t2\n"; }; + do { + die "t3\n"; + }; + 1; +}; $err = $@; +ok $uerr eq "t3\n"; +ok !defined($val); +ok $err eq "t3\n"; + +$@ = "t0\n"; +$val = eval { + $@ = "t1\n"; + my $c = end { $uerr = $@; $@ = "t2\n"; }; + do { + die "t3\n"; + }; + 1; +}; $err = $@; +ok $uerr eq "t3\n"; +ok !defined($val); +ok $err eq "t3\n"; + +1; diff --git a/t/op/eval.t b/t/op/eval.t index 0a5fadc1e0..a1c1c1a94c 100644 --- a/t/op/eval.t +++ b/t/op/eval.t @@ -6,7 +6,7 @@ BEGIN { require './test.pl'; } -print "1..107\n"; +print "1..108\n"; eval 'print "ok 1\n";'; @@ -611,3 +611,9 @@ eval $ov; print "ok\n"; EOP +for my $k (!0) { + eval 'my $do_something_with = $k'; + eval { $k = 'mon' }; + is "a" =~ /a/, "1", + "string eval leaves readonly lexicals readonly [perl #19135]"; +} diff --git a/t/op/filetest.t b/t/op/filetest.t index 4659c706db..f56264684f 100644 --- a/t/op/filetest.t +++ b/t/op/filetest.t @@ -87,7 +87,7 @@ ok( -f $tempfile ); is( -s $tempfile, 0 ); is( -f -s $tempfile, 0 ); is( -s -f $tempfile, 0 ); -unlink $tempfile; +unlink_all $tempfile; # test that _ is a bareword after filetest operators diff --git a/t/op/goto.t b/t/op/goto.t index 12bade9b13..4de47efa5a 100644 --- a/t/op/goto.t +++ b/t/op/goto.t @@ -231,7 +231,7 @@ close $f; $r = runperl(prog => 'use Op_goto01; print qq[DONE\n]'); is($r, "OK\nDONE\n", "goto within use-d file"); -unlink "Op_goto01.pm"; +unlink_all "Op_goto01.pm"; # test for [perl #24108] $ok = 1; diff --git a/t/op/magic.t b/t/op/magic.t index f5f620573f..4c7f70c76b 100644 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -42,7 +42,7 @@ if ($Is_MSWin32) { like `set FOO`, qr/^(?:FOO=)?hi there$/; } elsif ($Is_VMS) { is `write sys\$output f\$trnlnm("FOO")`, "hi there\n"; } else { is `echo \$FOO`, "hi there\n"; } -unlink 'ajslkdfpqjsjfk'; +unlink_all 'ajslkdfpqjsjfk'; $! = 0; open(FOO,'ajslkdfpqjsjfk'); isnt($!, 0); @@ -264,6 +264,9 @@ EOF is $_, $s1; } ok unlink($script) or diag $!; + # CHECK + # Could this be replaced with: + # unlink_all($script); } # $], $^O, $^T diff --git a/t/op/stat.t b/t/op/stat.t index bc05112f2f..8d1b9f25c9 100644 --- a/t/op/stat.t +++ b/t/op/stat.t @@ -46,7 +46,7 @@ my $tmpfile = tempfile(); my $tmpfile_link = tempfile(); chmod 0666, $tmpfile; -1 while unlink $tmpfile; +unlink_all $tmpfile; open(FOO, ">$tmpfile") || DIE("Can't open temp test file: $!"); close FOO; @@ -551,5 +551,5 @@ SKIP: { END { chmod 0666, $tmpfile; - 1 while unlink $tmpfile; + unlink_all $tmpfile; } diff --git a/t/op/sysio.t b/t/op/sysio.t index d0f71ae492..ba739f2ff9 100644 --- a/t/op/sysio.t +++ b/t/op/sysio.t @@ -209,7 +209,7 @@ ok(not defined sysseek(I, -1, 1)); close(I); -unlink $outfile; +unlink_all $outfile; # Check that utf8 IO doesn't upgrade the scalar open(I, ">$outfile") || die "sysio.t: cannot write $outfile: $!"; @@ -232,7 +232,7 @@ eval {syswrite I, 2;}; is($@, ''); close(I); -unlink $outfile; +unlink_all $outfile; chdir('..'); diff --git a/t/op/write.t b/t/op/write.t index 4038f4328e..b5c2210309 100644 --- a/t/op/write.t +++ b/t/op/write.t @@ -95,7 +95,7 @@ now @<<the@>>>> for all@|||||men to come @<<<< . open(OUT, '>Op_write.tmp') || die "Can't create Op_write.tmp"; -END { 1 while unlink 'Op_write.tmp' } +END { unlink_all 'Op_write.tmp' } $fox = 'foxiness'; $good = 'good'; @@ -115,7 +115,7 @@ the course of huma... now is the time for all good men to come to\n"; -is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; }; +is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; $fox = 'wolfishness'; my $fox = 'foxiness'; # Test a lexical variable. @@ -154,7 +154,7 @@ becomes necessary now is the time for all good men to come to\n"; -is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp'; }; +is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; eval <<'EOFORMAT'; format OUT2 = @@ -195,7 +195,7 @@ becomes necessary now is the time for all good men to come to\n"; -is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; +is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; # formline tests @@ -248,7 +248,7 @@ close OUT3 or die "Could not close: $!"; $right = "fit\n"; -is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; +is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; # test lexicals and globals @@ -276,7 +276,7 @@ format OUT4 = open OUT4, ">Op_write.tmp" or die "Can't create Op_write.tmp"; write (OUT4); close OUT4 or die "Could not close: $!"; -is cat('Op_write.tmp'), "1\n" and do { 1 while unlink "Op_write.tmp" }; +is cat('Op_write.tmp'), "1\n" and unlink_all "Op_write.tmp"; eval <<'EOFORMAT'; format OUT10 = @@ -293,7 +293,7 @@ write(OUT10); close OUT10 or die "Could not close: $!"; $right = " 12.95 00012.95\n"; -is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; +is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; eval <<'EOFORMAT'; format OUT11 = @@ -316,7 +316,7 @@ $right = "00012.95 1 0# 10 #\n"; -is cat('Op_write.tmp'), $right and do { 1 while unlink 'Op_write.tmp' }; +is cat('Op_write.tmp'), $right and unlink_all 'Op_write.tmp'; { my $test = curr_test(); @@ -121,7 +121,7 @@ EOTEST close $fh; my $out = runperl(stderr => 1, progfile => $prog); - unlink $prog; + unlink_all $prog; my $expected = <<'EOOUT'; ok 1 - weak copy equals original diff --git a/t/re/reg_eval_scope.t b/t/re/reg_eval_scope.t index 8c8be6a6c6..bd9ef84575 100644 --- a/t/re/reg_eval_scope.t +++ b/t/re/reg_eval_scope.t @@ -104,13 +104,14 @@ off; "ba" =~ /${\'(?{ $::pack = __PACKAGE__ })a'}/; } is $pack, 'bar', '/$text/ containing (?{}) inherits package'; -on; { use re 'eval', "/m"; "ba" =~ /${\'(?{ $::re = qr -- })a'}/; } is $re, '(?^m:)', '/$text/ containing (?{}) inherits pragmata'; +on; + fresh_perl_is <<'CODE', 'ok', { stderr => 1 }, '(?{die})'; eval { "a" =~ /(?{die})a/ }; print "ok" CODE diff --git a/t/run/switches.t b/t/run/switches.t index ada6eafad8..f636cea43e 100644 --- a/t/run/switches.t +++ b/t/run/switches.t @@ -22,7 +22,7 @@ $TODO = "runperl() unable to emulate echo -n due to pipe bug" if $^O eq 'VMS'; my $r; my @tmpfiles = (); -END { unlink @tmpfiles } +END { unlink_all @tmpfiles } # Tests for -0 @@ -304,7 +304,7 @@ foreach my $switch (split //, "ABbGgHJjKkLNOoPQqRrYyZz123456789_") { local $TODO = ''; # these ones should work on VMS - sub do_i_unlink { 1 while unlink("file", "file.bak") } + sub do_i_unlink { unlink_all("file", "file.bak") } open(FILE, ">file") or die "$0: Failed to create 'file': $!"; print FILE <<__EOF__; @@ -630,10 +630,16 @@ sub which_perl { } sub unlink_all { + my $count = 0; foreach my $file (@_) { 1 while unlink $file; - _print_stderr "# Couldn't unlink '$file': $!\n" if -f $file; + if( -f $file ){ + _print_stderr "# Couldn't unlink '$file': $!\n"; + }else{ + ++$count; + } } + $count; } my %tmpfiles; diff --git a/t/uni/fold.t b/t/uni/fold.t index f6f467cc9c..0f71c803b6 100644 --- a/t/uni/fold.t +++ b/t/uni/fold.t @@ -38,12 +38,13 @@ if (open(CF, $CF)) { my $b = pack("U0U*", map { hex } split " ", $mapping); my $t0 = ":$a:" =~ /:$a:/ ? 1 : 0; my $t1 = ":$a:" =~ /:$a:/i ? 1 : 0; - my $t2 = ":$a:" =~ /:[$a]:/ ? 1 : 0; - my $t3 = ":$a:" =~ /:[$a]:/i ? 1 : 0; + my $t2 = ":$a:" =~ /:[_$a]:/ ? 1 : 0; # Two chars in [] so doesn't get + # optimized to a non-charclass + my $t3 = ":$a:" =~ /:[_$a]:/i ? 1 : 0; my $t4 = ":$a:" =~ /:$b:/i ? 1 : 0; - my $t5 = ":$a:" =~ /:[$b]:/i ? 1 : 0; + my $t5 = ":$a:" =~ /:[_$b]:/i ? 1 : 0; my $t6 = ":$b:" =~ /:$a:/i ? 1 : 0; - my $t7 = ":$b:" =~ /:[$a]:/i ? 1 : 0; + my $t7 = ":$b:" =~ /:[_$a]:/i ? 1 : 0; print $t0 && $t1 && $t2 && $t3 && $t4 && $t5 && $t6 && $t7 ? "ok $i \# - $code - $name - $mapping - $status\n" : "not ok $i \# - $code - $name - $mapping - $status - $t0 $t1 $t2 $t3 $t4 $t5 $t6 $t7\n"; diff --git a/t/uni/write.t b/t/uni/write.t index 0d5cedcee0..136be677f7 100644 --- a/t/uni/write.t +++ b/t/uni/write.t @@ -101,4 +101,4 @@ $ulite1 $bmulti$blite2 EOEXPECT -1 while unlink 'Uni_write.tmp'; +unlink_all 'Uni_write.tmp'; @@ -3024,9 +3024,9 @@ S_scan_const(pTHX_ char *start) * no-op except on utfebcdic variant characters. Every * character generated by this that would normally need to be * enclosed by this macro is invariant, so the macro is not - * needed, and would complicate use of copy(). There are other - * parts of this file where the macro is used inconsistently, - * but are saved by it being a no-op */ + * needed, and would complicate use of copy(). XXX There are + * other parts of this file where the macro is used + * inconsistently, but are saved by it being a no-op */ /* The structure of this section of code (besides checking for * errors and upgrading to utf8) is: @@ -3298,7 +3298,7 @@ S_scan_const(pTHX_ char *start) if (UTF8_IS_INVARIANT(*i)) { if (! isALPHAU(*i)) problematic = TRUE; } else if (UTF8_IS_DOWNGRADEABLE_START(*i)) { - if (! isALPHAU(UNI_TO_NATIVE(UTF8_ACCUMULATE(*i, + if (! isALPHAU(UNI_TO_NATIVE(TWO_BYTE_UTF8_TO_UNI(*i, *(i+1))))) { problematic = TRUE; @@ -3314,7 +3314,7 @@ S_scan_const(pTHX_ char *start) continue; } else if (isCHARNAME_CONT( UNI_TO_NATIVE( - UTF8_ACCUMULATE(*i, *(i+1))))) + TWO_BYTE_UTF8_TO_UNI(*i, *(i+1))))) { continue; } diff --git a/win32/Makefile b/win32/Makefile index 248c6852c0..dbae5f2001 100644 --- a/win32/Makefile +++ b/win32/Makefile @@ -133,20 +133,6 @@ CCTYPE = MSVC60 #USE_SETARGV = define # -# if you want to have the crypt() builtin function implemented, leave this or -# CRYPT_LIB uncommented. The fcrypt.c file named here contains a suitable -# version of des_fcrypt(). -# -CRYPT_SRC = fcrypt.c - -# -# if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a -# library, uncomment this, and make sure the library exists (see README.win32) -# Specify the full pathname of the library. -# -#CRYPT_LIB = fcrypt.lib - -# # set this if you wish to use perl's malloc # WARNING: Turning this on/off WILL break binary compatibility with extensions # you may have compiled with/without it. Be prepared to recompile all @@ -198,16 +184,6 @@ CCLIBDIR = $(CCHOME)\lib BUILDOPT = $(BUILDOPTEXTRA) # -# Adding -DPERL_HASH_SEED_EXPLICIT will disable randomization of Perl's -# internal hash function unless the PERL_HASH_SEED environment variable is set. -# Alternatively, adding -DNO_HASH_SEED will completely disable the -# randomization feature. -# The latter is required to maintain binary compatibility with Perl 5.8.0. -# -#BUILDOPT = $(BUILDOPT) -DPERL_HASH_SEED_EXPLICIT -#BUILDOPT = $(BUILDOPT) -DNO_HASH_SEED - -# # This should normally be disabled. Enabling it will disable the File::Glob # implementation of CORE::glob. # @@ -237,13 +213,6 @@ EXTRALIBDIRS = ##################### CHANGE THESE ONLY IF YOU MUST ##################### -!IF "$(CRYPT_SRC)$(CRYPT_LIB)" == "" -D_CRYPT = undef -!ELSE -D_CRYPT = define -CRYPT_FLAG = -DHAVE_DES_FCRYPT -!ENDIF - !IF "$(USE_IMP_SYS)" == "define" PERL_MALLOC = undef DEBUG_MSTATS = undef @@ -414,7 +383,7 @@ RSC = rc INCLUDES = -I$(COREDIR) -I.\include -I. -I.. #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX -DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) +DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -TP -EHsc @@ -473,14 +442,7 @@ BUILDOPT = $(BUILDOPT) -D_USE_32BIT_TIME_T ! ENDIF !ENDIF -# Use the MSVCRT read() fix only when using VC++ 6.x or earlier. Later -# versions use MSVCR70.dll, MSVCR71.dll, etc, which do not require the -# fix. -!IF "$(CCTYPE)" == "MSVC60" -BUILDOPT = $(BUILDOPT) -DPERL_MSVCRT_READFIX -!ENDIF - -LIBBASEFILES = $(CRYPT_LIB) \ +LIBBASEFILES = \ oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ @@ -695,7 +657,8 @@ EXTRACORE_SRC = $(EXTRACORE_SRC) ..\perlio.c WIN32_SRC = \ .\win32.c \ .\win32sck.c \ - .\win32thread.c + .\win32thread.c \ + .\fcrypt.c # We need this for miniperl build unless we override canned # config.h #define building mini\* @@ -703,9 +666,6 @@ WIN32_SRC = \ WIN32_SRC = $(WIN32_SRC) .\win32io.c #!ENDIF -!IF "$(CRYPT_SRC)" != "" -WIN32_SRC = $(WIN32_SRC) .\$(CRYPT_SRC) -!ENDIF X2P_SRC = \ ..\x2p\a2p.c \ @@ -805,7 +765,6 @@ CFG_VARS = \ "ld=$(LINK32)" \ "ccflags=$(EXTRACFLAGS) $(OPTIMIZE:"=\") $(DEFINES) $(BUILDOPT)" \ "cf_email=$(EMAIL)" \ - "d_crypt=$(D_CRYPT)" \ "d_mymalloc=$(PERL_MALLOC)" \ "libs=$(LIBFILES)" \ "incpath=$(CCINCDIR:"=\")" \ diff --git a/win32/config.bc b/win32/config.bc index 8a2e7468da..eb5f72c33b 100644 --- a/win32/config.bc +++ b/win32/config.bc @@ -129,7 +129,7 @@ d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' -d_crypt='undef' +d_crypt='define' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' diff --git a/win32/config.gc b/win32/config.gc index 5c90397bbe..5f41d1a3df 100644 --- a/win32/config.gc +++ b/win32/config.gc @@ -129,7 +129,7 @@ d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' -d_crypt='undef' +d_crypt='define' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' diff --git a/win32/config.gc64 b/win32/config.gc64 index 36f21ce258..b2932e0c9d 100644 --- a/win32/config.gc64 +++ b/win32/config.gc64 @@ -129,7 +129,7 @@ d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' -d_crypt='undef' +d_crypt='define' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' diff --git a/win32/config.gc64nox b/win32/config.gc64nox index b9cd1cc4de..ac075ba97c 100644 --- a/win32/config.gc64nox +++ b/win32/config.gc64nox @@ -129,7 +129,7 @@ d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' -d_crypt='undef' +d_crypt='define' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' diff --git a/win32/config.vc b/win32/config.vc index 937ab828e2..444c81d327 100644 --- a/win32/config.vc +++ b/win32/config.vc @@ -129,7 +129,7 @@ d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' -d_crypt='undef' +d_crypt='define' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' diff --git a/win32/config.vc64 b/win32/config.vc64 index 68a8ea79c9..e0cd5859db 100644 --- a/win32/config.vc64 +++ b/win32/config.vc64 @@ -129,7 +129,7 @@ d_cmsghdr_s='undef' d_const='define' d_copysignl='undef' d_cplusplus='undef' -d_crypt='undef' +d_crypt='define' d_crypt_r='undef' d_csh='undef' d_ctermid='undef' diff --git a/win32/makefile.mk b/win32/makefile.mk index fe845c255c..9c0177909b 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -151,20 +151,6 @@ CCTYPE *= GCC #USE_SETARGV *= define # -# if you want to have the crypt() builtin function implemented, leave this or -# CRYPT_LIB uncommented. The fcrypt.c file named here contains a suitable -# version of des_fcrypt(). -# -CRYPT_SRC *= fcrypt.c - -# -# if you didn't set CRYPT_SRC and if you have des_fcrypt() available in a -# library, uncomment this, and make sure the library exists (see README.win32) -# Specify the full pathname of the library. -# -#CRYPT_LIB *= fcrypt.lib - -# # set this if you wish to use perl's malloc # WARNING: Turning this on/off WILL break binary compatibility with extensions # you may have compiled with/without it. Be prepared to recompile all @@ -254,16 +240,6 @@ CCLIBDIR *= $(CCHOME)\lib BUILDOPT *= $(BUILDOPTEXTRA) # -# Adding -DPERL_HASH_SEED_EXPLICIT will disable randomization of Perl's -# internal hash function unless the PERL_HASH_SEED environment variable is set. -# Alternatively, adding -DNO_HASH_SEED will completely disable the -# randomization feature. -# The latter is required to maintain binary compatibility with Perl 5.8.0. -# -#BUILDOPT += -DPERL_HASH_SEED_EXPLICIT -#BUILDOPT += -DNO_HASH_SEED - -# # This should normally be disabled. Enabling it will disable the File::Glob # implementation of CORE::glob. # @@ -299,13 +275,6 @@ EXTRALIBDIRS *= ##################### CHANGE THESE ONLY IF YOU MUST ##################### -.IF "$(CRYPT_SRC)$(CRYPT_LIB)" == "" -D_CRYPT = undef -.ELSE -D_CRYPT = define -CRYPT_FLAG = -DHAVE_DES_FCRYPT -.ENDIF - PERL_MALLOC *= undef DEBUG_MSTATS *= undef @@ -458,7 +427,7 @@ RSC = brcc32 # INCLUDES = -I$(COREDIR) -I.\include -I. -I.. -I"$(CCINCDIR)" #PCHFLAGS = -H -Hc -H=c:\temp\bcmoduls.pch -DEFINES = -DWIN32 $(CRYPT_FLAG) +DEFINES = -DWIN32 LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -P @@ -466,7 +435,7 @@ CXX_FLAG = -P LIBC = cw32mti.lib # same libs as MSVC, except Borland doesn't have oldnames.lib -LIBFILES = $(CRYPT_LIB) \ +LIBFILES = \ kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ @@ -520,7 +489,7 @@ a = .a # INCLUDES = -I.\include -I. -I.. -I$(COREDIR) -DEFINES = -DWIN32 $(CRYPT_FLAG) +DEFINES = -DWIN32 .IF "$(WIN64)" == "define" DEFINES += -DWIN64 -DCONSERVATIVE .ENDIF @@ -534,7 +503,7 @@ LIBC = #LIBC = -lmsvcrt # same libs as MSVC -LIBFILES = $(CRYPT_LIB) $(LIBC) \ +LIBFILES = $(LIBC) \ -lmoldname -lkernel32 -luser32 -lgdi32 \ -lwinspool -lcomdlg32 -ladvapi32 -lshell32 -lole32 \ -loleaut32 -lnetapi32 -luuid -lws2_32 -lmpr \ @@ -555,9 +524,7 @@ OBJOUT_FLAG = -o EXEOUT_FLAG = -o LIBOUT_FLAG = -# NOTE: we assume that GCC uses MSVCRT.DLL -# See comments about PERL_MSVCRT_READFIX in the "cl" compiler section below. -BUILDOPT += -fno-strict-aliasing -mms-bitfields -DPERL_MSVCRT_READFIX +BUILDOPT += -fno-strict-aliasing -mms-bitfields .ELSE @@ -572,7 +539,7 @@ RSC = rc INCLUDES = -I$(COREDIR) -I.\include -I. -I.. #PCHFLAGS = -Fpc:\temp\vcmoduls.pch -YX -DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT $(CRYPT_FLAG) +DEFINES = -DWIN32 -D_CONSOLE -DNO_STRICT LOCDEFS = -DPERLDLL -DPERL_CORE SUBSYS = console CXX_FLAG = -TP -EHsc @@ -631,14 +598,7 @@ BUILDOPT += -D_USE_32BIT_TIME_T .ENDIF .ENDIF -# Use the MSVCRT read() fix only when using VC++ 6.x or earlier. Later -# versions use MSVCR70.dll, MSVCR71.dll, etc, which do not require the -# fix. -.IF "$(CCTYPE)" == "MSVC60" -BUILDOPT += -DPERL_MSVCRT_READFIX -.ENDIF - -LIBBASEFILES = $(CRYPT_LIB) \ +LIBBASEFILES = \ oldnames.lib kernel32.lib user32.lib gdi32.lib winspool.lib \ comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib \ netapi32.lib uuid.lib ws2_32.lib mpr.lib winmm.lib \ @@ -909,7 +869,8 @@ EXTRACORE_SRC += ..\perlio.c WIN32_SRC = \ .\win32.c \ .\win32sck.c \ - .\win32thread.c + .\win32thread.c \ + .\fcrypt.c # We need this for miniperl build unless we override canned # config.h #define building mini\* @@ -917,10 +878,6 @@ WIN32_SRC = \ WIN32_SRC += .\win32io.c #.ENDIF -.IF "$(CRYPT_SRC)" != "" -WIN32_SRC += .\$(CRYPT_SRC) -.ENDIF - X2P_SRC = \ ..\x2p\a2p.c \ ..\x2p\hash.c \ @@ -1021,7 +978,6 @@ CFG_VARS = \ ld=$(LINK32) ~ \ ccflags=$(EXTRACFLAGS) $(OPTIMIZE) $(DEFINES) $(BUILDOPT) ~ \ cf_email=$(EMAIL) ~ \ - d_crypt=$(D_CRYPT) ~ \ d_mymalloc=$(PERL_MALLOC) ~ \ libs=$(LIBFILES:f) ~ \ incpath=$(CCINCDIR) ~ \ diff --git a/win32/win32.c b/win32/win32.c index e28be3a95e..228dddedb8 100644 --- a/win32/win32.c +++ b/win32/win32.c @@ -22,14 +22,6 @@ #include <windows.h> -#ifndef HWND_MESSAGE -# define HWND_MESSAGE ((HWND)-3) -#endif - -#ifndef WC_NO_BEST_FIT_CHARS -# define WC_NO_BEST_FIT_CHARS 0x00000400 /* requires Windows 2000 or later */ -#endif - #include <winnt.h> #include <commctrl.h> #include <tlhelp32.h> @@ -473,22 +465,6 @@ has_shell_metachars(const char *ptr) PerlIO * Perl_my_popen(pTHX_ const char *cmd, const char *mode) { -#ifdef FIXCMD -#define fixcmd(x) { \ - char *pspace = strchr((x),' '); \ - if (pspace) { \ - char *p = (x); \ - while (p < pspace) { \ - if (*p == '/') \ - *p = '\\'; \ - p++; \ - } \ - } \ - } -#else -#define fixcmd(x) -#endif - fixcmd(cmd); PERL_FLUSHALL_FOR_CHILD; return win32_popen(cmd, mode); } @@ -821,16 +797,6 @@ win32_opendir(const char *filename) return NULL; } -#if 0 /* This call to stat is unnecessary. The FindFirstFile() below will - * fail with ERROR_PATH_NOT_FOUND if filename is not a directory. */ - { - /* check to see if filename is a directory */ - Stat_t sbuf; - if (win32_stat(filename, &sbuf) < 0 || !S_ISDIR(sbuf.st_mode)) - return NULL; - } -#endif - /* Get us a DIR structure */ Newxz(dirp, 1, DIR); @@ -1961,44 +1927,12 @@ win32_uname(struct utsname *name) switch (procarch) { case PROCESSOR_ARCHITECTURE_INTEL: arch = "x86"; break; - case PROCESSOR_ARCHITECTURE_MIPS: - arch = "mips"; break; - case PROCESSOR_ARCHITECTURE_ALPHA: - arch = "alpha"; break; - case PROCESSOR_ARCHITECTURE_PPC: - arch = "ppc"; break; -#ifdef PROCESSOR_ARCHITECTURE_SHX - case PROCESSOR_ARCHITECTURE_SHX: - arch = "shx"; break; -#endif -#ifdef PROCESSOR_ARCHITECTURE_ARM - case PROCESSOR_ARCHITECTURE_ARM: - arch = "arm"; break; -#endif -#ifdef PROCESSOR_ARCHITECTURE_IA64 case PROCESSOR_ARCHITECTURE_IA64: arch = "ia64"; break; -#endif -#ifdef PROCESSOR_ARCHITECTURE_ALPHA64 - case PROCESSOR_ARCHITECTURE_ALPHA64: - arch = "alpha64"; break; -#endif -#ifdef PROCESSOR_ARCHITECTURE_MSIL - case PROCESSOR_ARCHITECTURE_MSIL: - arch = "msil"; break; -#endif -#ifdef PROCESSOR_ARCHITECTURE_AMD64 case PROCESSOR_ARCHITECTURE_AMD64: arch = "amd64"; break; -#endif -#ifdef PROCESSOR_ARCHITECTURE_IA32_ON_WIN64 - case PROCESSOR_ARCHITECTURE_IA32_ON_WIN64: - arch = "ia32-64"; break; -#endif -#ifdef PROCESSOR_ARCHITECTURE_UNKNOWN case PROCESSOR_ARCHITECTURE_UNKNOWN: arch = "unknown"; break; -#endif default: sprintf(name->machine, "unknown(0x%x)", procarch); arch = name->machine; @@ -2330,20 +2264,13 @@ win32_alarm(unsigned int sec) return 0; } -#ifdef HAVE_DES_FCRYPT extern char * des_fcrypt(const char *txt, const char *salt, char *cbuf); -#endif DllExport char * win32_crypt(const char *txt, const char *salt) { dTHX; -#ifdef HAVE_DES_FCRYPT return des_fcrypt(txt, salt, w32_crypt_buffer); -#else - Perl_croak(aTHX_ "The crypt() function is unimplemented due to excessive paranoia."); - return NULL; -#endif } /* simulate flock by locking a range on the file */ @@ -3237,210 +3164,10 @@ win32_dup2(int fd1,int fd2) return dup2(fd1,fd2); } -#ifdef PERL_MSVCRT_READFIX - -#define LF 10 /* line feed */ -#define CR 13 /* carriage return */ -#define CTRLZ 26 /* ctrl-z means eof for text */ -#define FOPEN 0x01 /* file handle open */ -#define FEOFLAG 0x02 /* end of file has been encountered */ -#define FCRLF 0x04 /* CR-LF across read buffer (in text mode) */ -#define FPIPE 0x08 /* file handle refers to a pipe */ -#define FAPPEND 0x20 /* file handle opened O_APPEND */ -#define FDEV 0x40 /* file handle refers to device */ -#define FTEXT 0x80 /* file handle is in text mode */ -#define MAX_DESCRIPTOR_COUNT (64*32) /* this is the maximun that MSVCRT can handle */ - -int __cdecl -_fixed_read(int fh, void *buf, unsigned cnt) -{ - int bytes_read; /* number of bytes read */ - char *buffer; /* buffer to read to */ - int os_read; /* bytes read on OS call */ - char *p, *q; /* pointers into buffer */ - char peekchr; /* peek-ahead character */ - ULONG filepos; /* file position after seek */ - ULONG dosretval; /* o.s. return value */ - - /* validate handle */ - if (((unsigned)fh >= (unsigned)MAX_DESCRIPTOR_COUNT) || - !(_osfile(fh) & FOPEN)) - { - /* out of range -- return error */ - errno = EBADF; - _doserrno = 0; /* not o.s. error */ - return -1; - } - - /* - * If lockinitflag is FALSE, assume fd is device - * lockinitflag is set to TRUE by open. - */ - if (_pioinfo(fh)->lockinitflag) - EnterCriticalSection(&(_pioinfo(fh)->lock)); /* lock file */ - - bytes_read = 0; /* nothing read yet */ - buffer = (char*)buf; - - if (cnt == 0 || (_osfile(fh) & FEOFLAG)) { - /* nothing to read or at EOF, so return 0 read */ - goto functionexit; - } - - if ((_osfile(fh) & (FPIPE|FDEV)) && _pipech(fh) != LF) { - /* a pipe/device and pipe lookahead non-empty: read the lookahead - * char */ - *buffer++ = _pipech(fh); - ++bytes_read; - --cnt; - _pipech(fh) = LF; /* mark as empty */ - } - - /* read the data */ - - if (!ReadFile((HANDLE)_osfhnd(fh), buffer, cnt, (LPDWORD)&os_read, NULL)) - { - /* ReadFile has reported an error. recognize two special cases. - * - * 1. map ERROR_ACCESS_DENIED to EBADF - * - * 2. just return 0 if ERROR_BROKEN_PIPE has occurred. it - * means the handle is a read-handle on a pipe for which - * all write-handles have been closed and all data has been - * read. */ - - if ((dosretval = GetLastError()) == ERROR_ACCESS_DENIED) { - /* wrong read/write mode should return EBADF, not EACCES */ - errno = EBADF; - _doserrno = dosretval; - bytes_read = -1; - goto functionexit; - } - else if (dosretval == ERROR_BROKEN_PIPE) { - bytes_read = 0; - goto functionexit; - } - else { - bytes_read = -1; - goto functionexit; - } - } - - bytes_read += os_read; /* update bytes read */ - - if (_osfile(fh) & FTEXT) { - /* now must translate CR-LFs to LFs in the buffer */ - - /* set CRLF flag to indicate LF at beginning of buffer */ - /* if ((os_read != 0) && (*(char *)buf == LF)) */ - /* _osfile(fh) |= FCRLF; */ - /* else */ - /* _osfile(fh) &= ~FCRLF; */ - - _osfile(fh) &= ~FCRLF; - - /* convert chars in the buffer: p is src, q is dest */ - p = q = (char*)buf; - while (p < (char *)buf + bytes_read) { - if (*p == CTRLZ) { - /* if fh is not a device, set ctrl-z flag */ - if (!(_osfile(fh) & FDEV)) - _osfile(fh) |= FEOFLAG; - break; /* stop translating */ - } - else if (*p != CR) - *q++ = *p++; - else { - /* *p is CR, so must check next char for LF */ - if (p < (char *)buf + bytes_read - 1) { - if (*(p+1) == LF) { - p += 2; - *q++ = LF; /* convert CR-LF to LF */ - } - else - *q++ = *p++; /* store char normally */ - } - else { - /* This is the hard part. We found a CR at end of - buffer. We must peek ahead to see if next char - is an LF. */ - ++p; - - dosretval = 0; - if (!ReadFile((HANDLE)_osfhnd(fh), &peekchr, 1, - (LPDWORD)&os_read, NULL)) - dosretval = GetLastError(); - - if (dosretval != 0 || os_read == 0) { - /* couldn't read ahead, store CR */ - *q++ = CR; - } - else { - /* peekchr now has the extra character -- we now - have several possibilities: - 1. disk file and char is not LF; just seek back - and copy CR - 2. disk file and char is LF; store LF, don't seek back - 3. pipe/device and char is LF; store LF. - 4. pipe/device and char isn't LF, store CR and - put char in pipe lookahead buffer. */ - if (_osfile(fh) & (FDEV|FPIPE)) { - /* non-seekable device */ - if (peekchr == LF) - *q++ = LF; - else { - *q++ = CR; - _pipech(fh) = peekchr; - } - } - else { - /* disk file */ - if (peekchr == LF) { - /* nothing read yet; must make some - progress */ - *q++ = LF; - /* turn on this flag for tell routine */ - _osfile(fh) |= FCRLF; - } - else { - HANDLE osHandle; /* o.s. handle value */ - /* seek back */ - if ((osHandle = (HANDLE)_get_osfhandle(fh)) != (HANDLE)-1) - { - if ((filepos = SetFilePointer(osHandle, -1, NULL, FILE_CURRENT)) == -1) - dosretval = GetLastError(); - } - if (peekchr != LF) - *q++ = CR; - } - } - } - } - } - } - - /* we now change bytes_read to reflect the true number of chars - in the buffer */ - bytes_read = q - (char *)buf; - } - -functionexit: - if (_pioinfo(fh)->lockinitflag) - LeaveCriticalSection(&(_pioinfo(fh)->lock)); /* unlock file */ - - return bytes_read; -} - -#endif /* PERL_MSVCRT_READFIX */ - DllExport int win32_read(int fd, void *buf, unsigned int cnt) { -#ifdef PERL_MSVCRT_READFIX - return _fixed_read(fd, buf, cnt); -#else return read(fd, buf, cnt); -#endif } DllExport int @@ -4517,7 +4244,7 @@ Perl_win32_init(int *argcp, char ***argvp) * want to be at the vendor's whim on the default, we set * it explicitly here. */ -#if !defined(_ALPHA_) && !defined(__GNUC__) +#if !defined(__GNUC__) _control87(MCW_EM, MCW_EM); #endif MALLOC_INIT; diff --git a/win32/win32.h b/win32/win32.h index 5be01254df..65d6d319d0 100644 --- a/win32/win32.h +++ b/win32/win32.h @@ -422,9 +422,7 @@ struct thread_intern { # ifdef USE_SOCKETS_AS_HANDLES int Winit_socktype; # endif -# ifdef HAVE_DES_FCRYPT char Wcrypt_buffer[30]; -# endif # ifdef USE_RTL_THREAD_API void * retv; /* slot for thread return value */ # endif @@ -518,59 +516,6 @@ DllExport int win32_async_check(pTHX); } STMT_END #endif -#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) -#ifdef PERL_CORE - -/* C doesn't like repeat struct definitions */ -#if defined(__MINGW32__) && (__MINGW32_MAJOR_VERSION>=3) -#undef _CRTIMP -#endif -#ifndef _CRTIMP -#define _CRTIMP __declspec(dllimport) -#endif - -/* - * Control structure for lowio file handles - */ -typedef struct { - intptr_t osfhnd;/* underlying OS file HANDLE */ - char osfile; /* attributes of file (e.g., open in text mode?) */ - char pipech; /* one char buffer for handles opened on pipes */ - int lockinitflag; - CRITICAL_SECTION lock; -} ioinfo; - - -/* - * Array of arrays of control structures for lowio files. - */ -EXTERN_C _CRTIMP ioinfo* __pioinfo[]; - -/* - * Definition of IOINFO_L2E, the log base 2 of the number of elements in each - * array of ioinfo structs. - */ -#define IOINFO_L2E 5 - -/* - * Definition of IOINFO_ARRAY_ELTS, the number of elements in ioinfo array - */ -#define IOINFO_ARRAY_ELTS (1 << IOINFO_L2E) - -/* - * Access macros for getting at an ioinfo struct and its fields from a - * file handle - */ -#define _pioinfo(i) (__pioinfo[(i) >> IOINFO_L2E] + ((i) & (IOINFO_ARRAY_ELTS - 1))) -#define _osfhnd(i) (_pioinfo(i)->osfhnd) -#define _osfile(i) (_pioinfo(i)->osfile) -#define _pipech(i) (_pioinfo(i)->pipech) - -/* since we are not doing a dup2(), this works fine */ -#define _set_osfhnd(fh, osfh) (void)(_osfhnd(fh) = (intptr_t)osfh) -#endif -#endif - /* IO.xs and POSIX.xs define PERLIO_NOT_STDIO to 1 */ #if defined(PERL_EXT_IO) || defined(PERL_EXT_POSIX) #undef PERLIO_NOT_STDIO diff --git a/win32/win32sck.c b/win32/win32sck.c index 8dbeeb6487..22cc72eefa 100644 --- a/win32/win32sck.c +++ b/win32/win32sck.c @@ -473,9 +473,6 @@ int my_close(int fd) int err; err = closesocket(osf); if (err == 0) { -#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) - _set_osfhnd(fd, INVALID_HANDLE_VALUE); -#endif (void)close(fd); /* handle already closed, ignore error */ return 0; } @@ -504,9 +501,6 @@ my_fclose (FILE *pf) win32_fflush(pf); err = closesocket(osf); if (err == 0) { -#if defined(USE_FIXED_OSFHANDLE) || defined(PERL_MSVCRT_READFIX) - _set_osfhnd(win32_fileno(pf), INVALID_HANDLE_VALUE); -#endif (void)fclose(pf); /* handle already closed, ignore error */ return 0; } |