In perl.git, the branch maint-5.10 has been updated <http://perl5.git.perl.org/perl.git/commitdiff/f8317c58d6b2e50f8774407deb37f71d38986277?hp=d3833d976cb99fa6773254fdbee77c050bf3f149>
- Log ----------------------------------------------------------------- commit f8317c58d6b2e50f8774407deb37f71d38986277 Author: John Peacock <[email protected]> Date: Sun Jun 28 18:56:07 2009 -0400 Integrate version.pm-0.77 into bleadperl (cherry picked from commit f941e6586d4c29e3329b7b366a6684d78e3a5735) M lib/version.pm M lib/version.t M universal.c M util.c commit 5244251b564f9c3821736923857945849cf6bdc1 Author: Jim Cromie <[email protected]> Date: Sat Jun 27 13:16:38 2009 -0400 add some BUGS items to Porting/Maintainers (cherry picked from commit e1466347d2d91d81b58b469c8fe703042244c9df) M Porting/Maintainers.pl commit 6cbefcb810f4685b18a270a6cb1ad4d0bc955ded Author: Adam Russell <[email protected]> Date: Sun Jun 28 18:04:00 2009 -0400 patch submission(symbian/symbian_utils.dll) Another symbian update. Changes in this patch are describe below... Changes made by Osvaldo Villalon: -deleted references to TDllReason -replaced TInt64.Low() with the I64LOW(TInt64) Macro -updated the 'Create' function call Changes made by Adam Russell: -in order to resolve two kernel panics: -removed reference to PL_clocktick at line 198 as it is not correctly defined when first called there -changed CPerlBase to call a new constructor I created in Perl Base.cpp. The reason for this is that the new constructor does not push anything into the CleanupStack because doing so from a console app will cause a panic. Signed-off-by: H.Merijn Brand <[email protected]> (cherry picked from commit 515fe3bd5a6032b6cb95d6331b812add93160bfd) M symbian/symbian_utils.cpp commit fd0cc0188e17c59fbc21340d9d27e530bfd56d7e Author: Adam Russell <[email protected]> Date: Sun Jun 28 18:13:28 2009 -0400 patch submission(symbian/PerlBase.cpp) charset="iso-8859-1" I needed to create a new constructor which does not use the cleanup stack since use of the cleanup stack from a console app will cause a kernel panic. Signed-off-by: H.Merijn Brand <[email protected]> (cherry picked from commit 43639bac1f28a48b8efcdee9011ac1116f2dad8d) M symbian/PerlBase.cpp commit 726999f7294e839f4834dad6a8e7b14b2fc595ab Author: Tim Jenness <[email protected]> Date: Sun Jun 28 21:44:20 2009 -1000 tjenness: dual life modules On Mon, 8 Jun 2009, Dave Mitchell wrote: > File::Temp > > blead and maint have some local portability fixes to > lib/File/Temp/t/fork.t, which is would be nice to see backported > to a new CPAN release. V0.22 is on its way to CPAN. Patch against blead is attached. This only includes the patch to fork.t rather than risking changes to Temp.pm itself. From e4eb4ee45a57b117f82541fbc66320112da228d4 Mon Sep 17 00:00:00 2001 From: Tim Jenness <[email protected]> Date: Sun, 28 Jun 2009 21:41:14 -1000 Subject: [PATCH] Synchronize File::Temp with CPAN v0.22 Signed-off-by: H.Merijn Brand <[email protected]> (cherry picked from commit c3624cb8d7408c7bfe21b5f565063cc92cecfd19) M lib/File/Temp.pm M lib/File/Temp/t/fork.t commit e8cf42f3c62a02df5e64bdac936f835ccd568dd9 Author: David Golden <[email protected]> Date: Sun Jun 28 21:51:39 2009 -0400 fix MANIFEST perms & add case-insensitive exclude Signed-off-by: H.Merijn Brand <[email protected]> (cherry picked from commit 74182dbd4562aa2e1f203924b0b5e6676faec47c) M Porting/add-package.pl commit bd632cc91e198dadee80d82a86688e543be40327 Author: Rafael Garcia-Suarez <[email protected]> Date: Sun Jun 28 14:03:36 2009 +0200 Small pod/wording fixes (cherry picked from commit 1cb246e8dcbc92bfdff3156b4963ab3a06f97534) M pod/perlfunc.pod commit c4041971dd4ae8c6cf31bca93f95c8c6ade95cdf Author: Adam Russell <[email protected]> Date: Sat Jun 27 22:06:01 2009 -0400 Removed obsolete E32Dll dll entry point which was removed from Symbian SDKs a long time ago(as of S60 3rd edition). (cherry picked from commit 0ee0837e8d54264dbb29748bad993d0f255f67f4) M symbian/symbian_dll.cpp commit 6ee1a79ccc4ab0b346a2b23409cc36afad031cf9 Author: Osvaldo Villalon <[email protected]> Date: Fri Jun 26 23:12:24 2009 -0400 Changed to incorporate latest SDKs. (cherry picked from commit 0e637710e635c1f42e13242e1ea416e9304090f6) M symbian/sdk.pl ----------------------------------------------------------------------- Summary of changes: Porting/Maintainers.pl | 12 +- Porting/add-package.pl | 4 +- lib/File/Temp.pm | 4 +- lib/File/Temp/t/fork.t | 29 ++-- lib/version.pm | 45 ++++- lib/version.t | 452 ++++++++++++++++++++++++++------------------- pod/perlfunc.pod | 13 +- symbian/PerlBase.cpp | 13 ++ symbian/sdk.pl | 13 ++ symbian/symbian_dll.cpp | 2 - symbian/symbian_utils.cpp | 31 ++-- universal.c | 50 ++++- util.c | 10 +- 13 files changed, 430 insertions(+), 248 deletions(-) diff --git a/Porting/Maintainers.pl b/Porting/Maintainers.pl index e609313..b4e3d99 100755 --- a/Porting/Maintainers.pl +++ b/Porting/Maintainers.pl @@ -130,6 +130,12 @@ package Maintainers; # that blead can be patched freely if it is in sync with the # latest release on CPAN. +# BUGS is an email or url to post bug reports. For modules with +# UPSTREAM => 'blead', use [email protected]. rt.cpan.org +# appears to automatically provide a URL for CPAN modules; any value +# given here overrides the default: +# http://rt.cpan.org/Public/Dist/Display.html?Name=$ModuleName + # DISTRIBUTION names the tarball on CPAN which (allegedly) the files # included in core are derived from. Note that the file's version may not # necessarily match the newest version on CPAN. @@ -174,6 +180,7 @@ package Maintainers; 'FILES' => q[lib/Archive/Extract.pm lib/Archive/Extract], 'CPAN' => 1, 'UPSTREAM' => 'cpan', + 'BUGS' => '[email protected]', }, 'Archive::Tar' => @@ -183,6 +190,7 @@ package Maintainers; 'FILES' => q[lib/Archive/Tar.pm lib/Archive/Tar], 'CPAN' => 1, 'UPSTREAM' => 'cpan', + 'BUGS' => '[email protected]', }, 'Attribute::Handlers' => @@ -231,7 +239,7 @@ package Maintainers; 'MAINTAINER' => 'smccam', 'FILES' => q[ext/B/B/Concise.pm ext/B/t/concise.t], 'CPAN' => 0, - 'UPSTREAM' => undef, + 'UPSTREAM' => 'blead', }, 'B::Debug' => @@ -245,6 +253,7 @@ package Maintainers; }, 'CPAN' => 1, 'UPSTREAM' => undef, + 'UPSTREAM' => 'blead', }, 'B::Deparse' => @@ -469,6 +478,7 @@ package Maintainers; ], 'CPAN' => 1, 'UPSTREAM' => 'cpan', + 'BUGS' => '[email protected]', }, 'CPANPLUS::Dist::Build' => diff --git a/Porting/add-package.pl b/Porting/add-package.pl index 20947c0..6a07d7e 100644 --- a/Porting/add-package.pl +++ b/Porting/add-package.pl @@ -12,7 +12,7 @@ getopts( 'r:p:e:vudn', $Opts ); my $Cwd = cwd(); my $Verbose = 1; -my $ExcludeRe = $Opts->{e} ? qr/$Opts->{e}/ : undef; +my $ExcludeRe = $Opts->{e} ? qr/$Opts->{e}/i : undef; my $Debug = $Opts->{v} || 0; my $RunDiff = $Opts->{d} || 0; my $PkgDir = $Opts->{p} || cwd(); @@ -439,7 +439,7 @@ my @ChangedFiles; push @manifest, values %pkg_files; - { chmod 0755, $file; + { chmod 0644, $file; open my $fh, ">$file" or die "Could not open $file for writing: $!"; #print $fh sort { lc $a cmp lc $b } @manifest; ### XXX stolen from pod/buildtoc:sub do_manifest diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index c0d7eef..a2d4ae0 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -203,7 +203,7 @@ Exporter::export_tags('POSIX','mktemp','seekable'); # Version number -$VERSION = '0.21'; +$VERSION = '0.22'; # This is a list of characters that can be used in random filenames @@ -2387,7 +2387,7 @@ the C<tempdir> function. Tim Jenness E<lt>[email protected]<gt> -Copyright (C) 2007-2008 Tim Jenness. +Copyright (C) 2007-2009 Tim Jenness. Copyright (C) 1999-2007 Tim Jenness and the UK Particle Physics and Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same diff --git a/lib/File/Temp/t/fork.t b/lib/File/Temp/t/fork.t index a522ca7..fd3f5a6 100644 --- a/lib/File/Temp/t/fork.t +++ b/lib/File/Temp/t/fork.t @@ -6,25 +6,25 @@ $| = 1; use strict; BEGIN { - require Config; - my $can_fork = $Config::Config{d_fork} || - (($^O eq 'MSWin32' || $^O eq 'NetWare') and - $Config::Config{useithreads} and - $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ - ); - if ( $can_fork ) { - print "1..8\n"; - } else { - print "1..0 # Skip No fork available\n"; - exit; - } + require Config; + my $can_fork = $Config::Config{d_fork} || + (($^O eq 'MSWin32' || $^O eq 'NetWare') and + $Config::Config{useithreads} and + $Config::Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/ + ); + if ( $can_fork ) { + print "1..8\n"; + } else { + print "1..0 # Skip No fork available\n"; + exit; + } } use File::Temp; # OO interface -my $file = File::Temp->new(CLEANUP=>1); +my $file = File::Temp->new(); myok( 1, -f $file->filename, "OO File exists" ); @@ -60,7 +60,7 @@ myok( 4, -f $file->filename(), "OO File exists in parent" ); # non-OO interface -my ($fh, $filename) = File::Temp::tempfile(); +my ($fh, $filename) = File::Temp::tempfile( UNLINK => 1 ); myok( 5, -f $filename, "non-OO File exists" ); @@ -88,7 +88,6 @@ while ($children) { $children--; } myok(8, -f $filename, "non-OO File exists in parent" ); -unlink($filename); # Cleanup # Local ok sub handles explicit number diff --git a/lib/version.pm b/lib/version.pm index 998180b..9201a02 100644 --- a/lib/version.pm +++ b/lib/version.pm @@ -4,22 +4,53 @@ package version; use 5.005_04; use strict; -use vars qw(@ISA $VERSION $CLASS *qv); +use vars qw(@ISA $VERSION $CLASS *declare *qv); -$VERSION = 0.76; +$VERSION = 0.77; $CLASS = 'version'; # Preloaded methods go here. sub import { - my ($class) = @_; - my $callpkg = caller(); no strict 'refs'; + my ($class) = shift; + + # Set up any derived class + unless ($class eq 'version') { + local $^W; + *{$class.'::declare'} = \&version::declare; + *{$class.'::qv'} = \&version::qv; + } + + my %args; + if (@_) { # any remaining terms are arguments + map { $args{$_} = 1 } @_ + } + else { # no parameters at all on use line + %args = + ( + qv => 1, + 'UNIVERSAL::VERSION' => 1, + ); + } - *{$callpkg."::qv"} = - sub {return bless version::qv(shift), $class } - unless defined (&{"$callpkg\::qv"}); + my $callpkg = caller(); + + if (exists($args{declare})) { + *{$callpkg."::declare"} = + sub {return $class->declare(shift) } + unless defined(&{$callpkg.'::declare'}); + } + + if (exists($args{qv})) { + *{$callpkg."::qv"} = + sub {return $class->qv(shift) } + unless defined(&{"$callpkg\::qv"}); + } + if (exists($args{'VERSION'})) { + *{$callpkg."::VERSION"} = \&version::_VERSION; + } } 1; diff --git a/lib/version.t b/lib/version.t index 47989e3..580ad1e 100644 --- a/lib/version.t +++ b/lib/version.t @@ -9,40 +9,79 @@ use Data::Dumper; require Test::Harness; no warnings 'once'; *Verbose = \$Test::Harness::Verbose; - -diag "Tests with base class" unless $ENV{PERL_CORE}; +use POSIX qw/locale_h/; +use File::Temp qw/tempfile/; +use File::Basename; BEGIN { - use_ok("version", 0.50); # If we made it this far, we are ok. + use_ok("version", 0.77); + # If we made it this far, we are ok. } -BaseTests("version"); +my $Verbose; + +diag "Tests with base class" unless $ENV{PERL_CORE}; -diag "Tests with empty derived class" unless $ENV{PERL_CORE}; +BaseTests("version","new","qv"); +BaseTests("version","new","declare"); +BaseTests("version","parse", "qv"); +BaseTests("version","parse", "declare"); -package version::Empty; -use base version; -$VERSION = 0.01; -no warnings 'redefine'; -*::qv = sub { return bless version::qv(shift), __PACKAGE__; }; +# dummy up a redundant call to satify David Wheeler +local $SIG{__WARN__} = sub { die $_[0] }; +eval 'use version;'; +unlike ($@, qr/^Subroutine main::declare redefined/, + "Only export declare once per package (to prevent redefined warnings)."); package version::Bad; -use base version; +use base 'version'; sub new { my($self,$n)=...@_; bless \$n, $self } package main; -my $testobj = version::Empty->new(1.002_003); -isa_ok( $testobj, "version::Empty" ); + +my $warning; +local $SIG{__WARN__} = sub { $warning = $_[0] }; +my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); +(my $package = basename($filename)) =~ s/\.pm$//; +print $fh <<"EOF"; +# This is an empty subclass +package $package; +use base 'version'; +use vars '\$VERSION'; +\$VERSION=0.001; +EOF +close $fh; + +sub main_reset { + delete $main::INC{'$package'}; + undef &qv; undef *::qv; # avoid 'used once' warning + undef &declare; undef *::declare; # avoid 'used once' warning +} + +diag "Tests with empty derived class" unless $ENV{PERL_CORE}; + +use_ok($package, 0.001); +my $testobj = $package->new(1.002_003); +isa_ok( $testobj, $package ); ok( $testobj->numify == 1.002003, "Numified correctly" ); ok( $testobj->stringify eq "1.002003", "Stringified correctly" ); ok( $testobj->normal eq "v1.2.3", "Normalified correctly" ); -my $verobj = version->new("1.2.4"); +my $verobj = version::->new("1.2.4"); ok( $verobj > $testobj, "Comparison vs parent class" ); -ok( $verobj gt $testobj, "Comparison vs parent class" ); -BaseTests("version::Empty"); -diag "tests with bad subclass" unless $ENV{PERL_CORE}; +BaseTests($package, "new", "qv"); +main_reset; +use_ok($package, 0.001, "declare"); +BaseTests($package, "new", "declare"); +main_reset; +use_ok($package, 0.001); +BaseTests($package, "parse", "qv"); +main_reset; +use_ok($package, 0.001, "declare"); +BaseTests($package, "parse", "declare"); + +diag "tests with bad subclass" unless $ENV{PERL_CORE}; $testobj = version::Bad->new(1.002_003); isa_ok( $testobj, "version::Bad" ); eval { my $string = $testobj->numify }; @@ -54,64 +93,58 @@ like($@, qr/Invalid version object/, eval { my $string = $testobj->stringify }; like($@, qr/Invalid version object/, "Bad subclass stringify"); -eval { my $test = $testobj > 1.0 }; +eval { my $test = ($testobj > 1.0) }; like($@, qr/Invalid version object/, "Bad subclass vcmp"); -# dummy up a redundant call to satify David Wheeler -local $SIG{__WARN__} = sub { die $_[0] }; -eval 'use version;'; -unlike ($@, qr/^Subroutine main::qv redefined/, - "Only export qv once per package (to prevent redefined warnings)."); - sub BaseTests { - my ($CLASS, $no_qv) = @_; + my ($CLASS, $method, $qv_declare) = @_; # Insert your test code below, the Test module is use()ed here so read # its man page ( perldoc Test ) for help writing this test script. # Test bare number processing - diag "tests with bare numbers" if $Verbose; - $version = $CLASS->new(5.005_03); + diag "tests with bare numbers" unless $ENV{PERL_CORE}; + $version = $CLASS->$method(5.005_03); is ( "$version" , "5.00503" , '5.005_03 eq 5.00503' ); - $version = $CLASS->new(1.23); + $version = $CLASS->$method(1.23); is ( "$version" , "1.23" , '1.23 eq "1.23"' ); # Test quoted number processing - diag "tests with quoted numbers" if $Verbose; - $version = $CLASS->new("5.005_03"); + diag "tests with quoted numbers" unless $ENV{PERL_CORE}; + $version = $CLASS->$method("5.005_03"); is ( "$version" , "5.005_03" , '"5.005_03" eq "5.005_03"' ); - $version = $CLASS->new("v1.23"); + $version = $CLASS->$method("v1.23"); is ( "$version" , "v1.23" , '"v1.23" eq "v1.23"' ); # Test stringify operator - diag "tests with stringify" if $Verbose; - $version = $CLASS->new("5.005"); + diag "tests with stringify" unless $ENV{PERL_CORE}; + $version = $CLASS->$method("5.005"); is ( "$version" , "5.005" , '5.005 eq "5.005"' ); - $version = $CLASS->new("5.006.001"); + $version = $CLASS->$method("5.006.001"); is ( "$version" , "5.006.001" , '5.006.001 eq v5.6.1' ); - $version = $CLASS->new("1.2.3_4"); + $version = $CLASS->$method("1.2.3_4"); is ( "$version" , "1.2.3_4" , 'alpha version 1.2.3_4 eq v1.2.3_4' ); # test illegal formats - diag "test illegal formats" if $Verbose; - eval {my $version = $CLASS->new("1.2_3_4")}; + diag "test illegal formats" unless $ENV{PERL_CORE}; + eval {my $version = $CLASS->$method("1.2_3_4")}; like($@, qr/multiple underscores/, "Invalid version format (multiple underscores)"); - eval {my $version = $CLASS->new("1.2_3.4")}; + eval {my $version = $CLASS->$method("1.2_3.4")}; like($@, qr/underscores before decimal/, "Invalid version format (underscores before decimal)"); - eval {my $version = $CLASS->new("1_2")}; + eval {my $version = $CLASS->$method("1_2")}; like($@, qr/alpha without decimal/, "Invalid version format (alpha without decimal)"); # for this first test, just upgrade the warn() to die() eval { local $SIG{__WARN__} = sub { die $_[0] }; - $version = $CLASS->new("1.2b3"); + $version = $CLASS->$method("1.2b3"); }; my $warnregex = "Version string '.+' contains invalid data; ". "ignoring: '.+'"; @@ -123,7 +156,7 @@ sub BaseTests { { my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; - $version = $CLASS->new("99 and 44/100 pure"); + $version = $CLASS->$method("99 and 44/100 pure"); like($warning, qr/$warnregex/, "Version string contains invalid data; ignoring"); @@ -131,13 +164,13 @@ sub BaseTests { ok ($version->numify == 99.0, '$version->numify == 99.0'); ok ($version->normal eq "v99.0.0", '$version->normal eq v99.0.0'); - $version = $CLASS->new("something"); + $version = $CLASS->$method("something"); like($warning, qr/$warnregex/, "Version string contains invalid data; ignoring"); ok (defined $version, 'defined $version'); # reset the test object to something reasonable - $version = $CLASS->new("1.2.3"); + $version = $CLASS->$method("1.2.3"); # Test boolean operator ok ($version, 'boolean'); @@ -146,53 +179,53 @@ sub BaseTests { isa_ok ( $version, $CLASS ); # Test comparison operators with self - diag "tests with self" if $Verbose; + diag "tests with self" unless $ENV{PERL_CORE}; is ( $version <=> $version, 0, '$version <=> $version == 0' ); ok ( $version == $version, '$version == $version' ); # Test Numeric Comparison operators # test first with non-object - $version = $CLASS->new("5.006.001"); + $version = $CLASS->$method("5.006.001"); $new_version = "5.8.0"; - diag "numeric tests with non-objects" if $Verbose; + diag "numeric tests with non-objects" unless $ENV{PERL_CORE}; ok ( $version == $version, '$version == $version' ); ok ( $version < $new_version, '$version < $new_version' ); ok ( $new_version > $version, '$new_version > $version' ); ok ( $version != $new_version, '$version != $new_version' ); # now test with existing object - $new_version = $CLASS->new($new_version); - diag "numeric tests with objects" if $Verbose; + $new_version = $CLASS->$method($new_version); + diag "numeric tests with objects" unless $ENV{PERL_CORE}; ok ( $version < $new_version, '$version < $new_version' ); ok ( $new_version > $version, '$new_version > $version' ); ok ( $version != $new_version, '$version != $new_version' ); # now test with actual numbers - diag "numeric tests with numbers" if $Verbose; + diag "numeric tests with numbers" unless $ENV{PERL_CORE}; ok ( $version->numify() == 5.006001, '$version->numify() == 5.006001' ); ok ( $version->numify() <= 5.006001, '$version->numify() <= 5.006001' ); ok ( $version->numify() < 5.008, '$version->numify() < 5.008' ); #ok ( $version->numify() > v5.005_02, '$version->numify() > 5.005_02' ); # test with long decimals - diag "Tests with extended decimal versions" if $Verbose; - $version = $CLASS->new(1.002003); + diag "Tests with extended decimal versions" unless $ENV{PERL_CORE}; + $version = $CLASS->$method(1.002003); ok ( $version == "1.2.3", '$version == "1.2.3"'); ok ( $version->numify == 1.002003, '$version->numify == 1.002003'); - $version = $CLASS->new("2002.09.30.1"); + $version = $CLASS->$method("2002.09.30.1"); ok ( $version == "2002.9.30.1",'$version == 2002.9.30.1'); ok ( $version->numify == 2002.009030001, '$version->numify == 2002.009030001'); # now test with alpha version form with string - $version = $CLASS->new("1.2.3"); + $version = $CLASS->$method("1.2.3"); $new_version = "1.2.3_4"; - diag "numeric tests with alpha-style non-objects" if $Verbose; + diag "numeric tests with alpha-style non-objects" unless $ENV{PERL_CORE}; ok ( $version < $new_version, '$version < $new_version' ); ok ( $new_version > $version, '$new_version > $version' ); ok ( $version != $new_version, '$version != $new_version' ); - $version = $CLASS->new("1.2.4"); + $version = $CLASS->$method("1.2.4"); diag "numeric tests with alpha-style non-objects" if $Verbose; ok ( $version > $new_version, '$version > $new_version' ); @@ -200,44 +233,44 @@ sub BaseTests { ok ( $version != $new_version, '$version != $new_version' ); # now test with alpha version form with object - $version = $CLASS->new("1.2.3"); - $new_version = $CLASS->new("1.2.3_4"); - diag "tests with alpha-style objects" if $Verbose; + $version = $CLASS->$method("1.2.3"); + $new_version = $CLASS->$method("1.2.3_4"); + diag "tests with alpha-style objects" unless $ENV{PERL_CORE}; ok ( $version < $new_version, '$version < $new_version' ); ok ( $new_version > $version, '$new_version > $version' ); ok ( $version != $new_version, '$version != $new_version' ); ok ( !$version->is_alpha, '!$version->is_alpha'); ok ( $new_version->is_alpha, '$new_version->is_alpha'); - $version = $CLASS->new("1.2.4"); - diag "tests with alpha-style objects" if $Verbose; + $version = $CLASS->$method("1.2.4"); + diag "tests with alpha-style objects" unless $ENV{PERL_CORE}; ok ( $version > $new_version, '$version > $new_version' ); ok ( $new_version < $version, '$new_version < $version' ); ok ( $version != $new_version, '$version != $new_version' ); - $version = $CLASS->new("1.2.3.4"); - $new_version = $CLASS->new("1.2.3_4"); + $version = $CLASS->$method("1.2.3.4"); + $new_version = $CLASS->$method("1.2.3_4"); diag "tests with alpha-style objects with same subversion" if $Verbose; ok ( $version > $new_version, '$version > $new_version' ); ok ( $new_version < $version, '$new_version < $version' ); ok ( $version != $new_version, '$version != $new_version' ); - diag "test implicit [in]equality" if $Verbose; - $version = $CLASS->new("v1.2.3"); - $new_version = $CLASS->new("1.2.3.0"); + diag "test implicit [in]equality" unless $ENV{PERL_CORE}; + $version = $CLASS->$method("v1.2.3"); + $new_version = $CLASS->$method("1.2.3.0"); ok ( $version == $new_version, '$version == $new_version' ); - $new_version = $CLASS->new("1.2.3_0"); + $new_version = $CLASS->$method("1.2.3_0"); ok ( $version == $new_version, '$version == $new_version' ); - $new_version = $CLASS->new("1.2.3.1"); + $new_version = $CLASS->$method("1.2.3.1"); ok ( $version < $new_version, '$version < $new_version' ); - $new_version = $CLASS->new("1.2.3_1"); + $new_version = $CLASS->$method("1.2.3_1"); ok ( $version < $new_version, '$version < $new_version' ); - $new_version = $CLASS->new("1.1.999"); + $new_version = $CLASS->$method("1.1.999"); ok ( $version > $new_version, '$version > $new_version' ); # that which is not expressly permitted is forbidden - diag "forbidden operations" if $Verbose; + diag "forbidden operations" unless $ENV{PERL_CORE}; ok ( !eval { ++$version }, "noop ++" ); ok ( !eval { --$version }, "noop --" ); ok ( !eval { $version/1 }, "noop /" ); @@ -245,61 +278,62 @@ sub BaseTests { ok ( !eval { abs($version) }, "noop abs" ); SKIP: { - skip "version require'd instead of use'd, cannot test qv", 3 - if defined $no_qv; - # test the qv() sub - diag "testing qv" if $Verbose; - $version = qv("1.2"); - is ( "$version", "v1.2", 'qv("1.2") == "1.2.0"' ); - $version = qv(1.2); - is ( "$version", "v1.2", 'qv(1.2) == "1.2.0"' ); - isa_ok( qv('5.008'), $CLASS ); + skip "version require'd instead of use'd, cannot test $qv_declare", 3 + unless defined $qv_declare; + # test the $qv_declare() sub + diag "testing $qv_declare" unless $ENV{PERL_CORE}; + $version = $CLASS->$qv_declare("1.2"); + is ( "$version", "v1.2", $qv_declare.'("1.2") == "1.2.0"' ); + $version = $CLASS->$qv_declare(1.2); + is ( "$version", "v1.2", $qv_declare.'(1.2) == "1.2.0"' ); + isa_ok( $CLASS->$qv_declare('5.008'), $CLASS ); } # test creation from existing version object - diag "create new from existing version" if $Verbose; - ok (eval {$new_version = $CLASS->new($version)}, + diag "create new from existing version" unless $ENV{PERL_CORE}; + ok (eval {$new_version = $CLASS->$method($version)}, "new from existing object"); - ok ($new_version == $version, "class->new($version) identical"); - $new_version = $version->new(); + ok ($new_version == $version, "class->$method($version) identical"); + $new_version = $version->$method(); isa_ok ($new_version, $CLASS ); - is ($new_version, "0", "version->new() doesn't clone"); - $new_version = $version->new("1.2.3"); - is ($new_version, "1.2.3" , '$version->new("1.2.3") works too'); + is ($new_version, "0", "version->$method() doesn't clone"); + $new_version = $version->$method("1.2.3"); + is ($new_version, "1.2.3" , '$version->$method("1.2.3") works too'); # test the CVS revision mode - diag "testing CVS Revision" if $Verbose; + diag "testing CVS Revision" unless $ENV{PERL_CORE}; $version = new $CLASS qw$Revision: 1.2$; ok ( $version == "1.2.0", 'qw$Revision: 1.2$ == 1.2.0' ); $version = new $CLASS qw$Revision: 1.2.3.4$; ok ( $version == "1.2.3.4", 'qw$Revision: 1.2.3.4$ == 1.2.3.4' ); # test the CPAN style reduced significant digit form - diag "testing CPAN-style versions" if $Verbose; - $version = $CLASS->new("1.23_01"); + diag "testing CPAN-style versions" unless $ENV{PERL_CORE}; + $version = $CLASS->$method("1.23_01"); is ( "$version" , "1.23_01", "CPAN-style alpha version" ); ok ( $version > 1.23, "1.23_01 > 1.23"); ok ( $version < 1.24, "1.23_01 < 1.24"); # test reformed UNIVERSAL::VERSION - diag "Replacement UNIVERSAL::VERSION tests" if $Verbose; + diag "Replacement UNIVERSAL::VERSION tests" unless $ENV{PERL_CORE}; my $error_regex = $] < 5.006 ? 'version \d required' - : 'does not define \$...::VERSION'; + : 'does not define \$t.{7}::VERSION'; { - open F, ">aaa.pm" or die "Cannot open aaa.pm: $!\n"; - print F "package aaa;\n\$aaa::VERSION=0.58;\n1;\n"; - close F; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh "package $package;\n\$$package\::VERSION=0.58;\n1;\n"; + close $fh; $version = 0.58; - eval "use lib '.'; use aaa $version"; - unlike($@, qr/aaa version $version/, + eval "use lib '.'; use $package $version"; + unlike($@, qr/$package version $version/, 'Replacement eval works with exact version'); # test as class method - $new_version = "aaa"->VERSION; + $new_version = $package->VERSION; cmp_ok($new_version,'==',$version, "Called as class method"); eval "print Completely::Unknown::Module->VERSION"; @@ -314,30 +348,31 @@ SKIP: { # this should fail even with old UNIVERSAL::VERSION $version += 0.01; - eval "use lib '.'; use aaa $version"; - like($@, qr/aaa version $version/, + eval "use lib '.'; use $package $version"; + like($@, qr/$package version $version/, 'Replacement eval works with incremented version'); $version =~ s/0+$//; #convert to string and remove trailing 0's chop($version); # shorten by 1 digit, should still succeed - eval "use lib '.'; use aaa $version"; - unlike($@, qr/aaa version $version/, + eval "use lib '.'; use $package $version"; + unlike($@, qr/$package version $version/, 'Replacement eval works with single digit'); # this would fail with old UNIVERSAL::VERSION $version += 0.1; - eval "use lib '.'; use aaa $version"; - like($@, qr/aaa version $version/, + eval "use lib '.'; use $package $version"; + like($@, qr/$package version $version/, 'Replacement eval works with incremented digit'); - unlink 'aaa.pm'; + unlink $filename; } { # dummy up some variously broken modules for testing - open F, ">xxx.pm" or die "Cannot open xxx.pm: $!\n"; - print F "1;\n"; - close F; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh "1;\n"; + close $fh; - eval "use lib '.'; use xxx 3;"; + eval "use lib '.'; use $package 3;"; if ( $] < 5.008 ) { like($@, qr/$error_regex/, 'Replacement handles modules without package or VERSION'); @@ -346,207 +381,246 @@ SKIP: { like($@, qr/defines neither package nor VERSION/, 'Replacement handles modules without package or VERSION'); } - eval "use lib '.'; use xxx; \$version = xxx->VERSION"; + eval "use lib '.'; use $package; \$version = $package->VERSION"; unlike ($@, qr/$error_regex/, 'Replacement handles modules without package or VERSION'); ok (!defined($version), "Called as class method"); - unlink 'xxx.pm'; + unlink $filename; } { # dummy up some variously broken modules for testing - open F, ">yyy.pm" or die "Cannot open yyy.pm: $!\n"; - print F "package yyy;\n#look ma no VERSION\n1;\n"; - close F; - eval "use lib '.'; use yyy 3;"; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh "package $package;\n#look ma no VERSION\n1;\n"; + close $fh; + eval "use lib '.'; use $package 3;"; like ($@, qr/$error_regex/, 'Replacement handles modules without VERSION'); - eval "use lib '.'; use yyy; print yyy->VERSION"; + eval "use lib '.'; use $package; print $package->VERSION"; unlike ($@, qr/$error_regex/, 'Replacement handles modules without VERSION'); - unlink 'yyy.pm'; + unlink $filename; } { # dummy up some variously broken modules for testing - open F, ">zzz.pm" or die "Cannot open zzz.pm: $!\n"; - print F "package zzz;\...@version = ();\n1;\n"; - close F; - eval "use lib '.'; use zzz 3;"; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh "package $package;\...@version = ();\n1;\n"; + close $fh; + eval "use lib '.'; use $package 3;"; like ($@, qr/$error_regex/, 'Replacement handles modules without VERSION'); - eval "use lib '.'; use zzz; print zzz->VERSION"; + eval "use lib '.'; use $package; print $package->VERSION"; unlike ($@, qr/$error_regex/, 'Replacement handles modules without VERSION'); - unlink 'zzz.pm'; + unlink $filename; } SKIP: { skip 'Cannot test bare v-strings with Perl < 5.6.0', 4 if $] < 5.006_000; - diag "Tests with v-strings" if $Verbose; - $version = $CLASS->new(1.2.3); + diag "Tests with v-strings" unless $ENV{PERL_CORE}; + $version = $CLASS->$method(1.2.3); ok("$version" == "v1.2.3", '"$version" == 1.2.3'); - $version = $CLASS->new(1.0.0); - $new_version = $CLASS->new(1); + $version = $CLASS->$method(1.0.0); + $new_version = $CLASS->$method(1); ok($version == $new_version, '$version == $new_version'); - skip "version require'd instead of use'd, cannot test qv", 1 - if defined $no_qv; - $version = qv(1.2.3); - ok("$version" == "v1.2.3", 'v-string initialized qv()'); + skip "version require'd instead of use'd, cannot test declare", 1 + unless defined $qv_declare; + $version = &$qv_declare(1.2.3); + ok("$version" == "v1.2.3", 'v-string initialized $qv_declare()'); } - diag "Tests with real-world (malformed) data" if $Verbose; + diag "Tests with real-world (malformed) data" unless $ENV{PERL_CORE}; # trailing zero testing (reported by Andreas Koenig). - $version = $CLASS->new("1"); + $version = $CLASS->$method("1"); ok($version->numify eq "1.000", "trailing zeros preserved"); - $version = $CLASS->new("1.0"); + $version = $CLASS->$method("1.0"); ok($version->numify eq "1.000", "trailing zeros preserved"); - $version = $CLASS->new("1.0.0"); + $version = $CLASS->$method("1.0.0"); ok($version->numify eq "1.000000", "trailing zeros preserved"); - $version = $CLASS->new("1.0.0.0"); + $version = $CLASS->$method("1.0.0.0"); ok($version->numify eq "1.000000000", "trailing zeros preserved"); # leading zero testing (reported by Andreas Koenig). - $version = $CLASS->new(".7"); + $version = $CLASS->$method(".7"); ok($version->numify eq "0.700", "leading zero inferred"); # leading space testing (reported by Andreas Koenig). - $version = $CLASS->new(" 1.7"); + $version = $CLASS->$method(" 1.7"); ok($version->numify eq "1.700", "leading space ignored"); # RT 19517 - deal with undef and 'undef' initialization ok("$version" ne 'undef', "Undef version comparison #1"); ok("$version" ne undef, "Undef version comparison #2"); - $version = $CLASS->new('undef'); + $version = $CLASS->$method('undef'); unlike($warning, qr/^Version string 'undef' contains invalid data/, "Version string 'undef'"); - $version = $CLASS->new(undef); + $version = $CLASS->$method(undef); like($warning, qr/^Use of uninitialized value/, "Version string 'undef'"); ok($version == 'undef', "Undef version comparison #3"); ok($version == undef, "Undef version comparison #4"); - eval "\$version = \$CLASS->new()"; # no parameter at all + eval "\$version = \$CLASS->$method()"; # no parameter at all unlike($@, qr/^Bizarre copy of CODE/, "No initializer at all"); ok($version == 'undef', "Undef version comparison #5"); ok($version == undef, "Undef version comparison #6"); - $version = $CLASS->new(0.000001); + $version = $CLASS->$method(0.000001); unlike($warning, qr/^Version string '1e-06' contains invalid data/, "Very small version objects"); } SKIP: { + my $warning; + local $SIG{__WARN__} = sub { $warning = $_[0] }; # dummy up a legal module for testing RT#19017 - open F, ">www.pm" or die "Cannot open www.pm: $!\n"; - print F <<"EOF"; -package www; -use version; \$VERSION = qv('0.0.4'); + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh <<"EOF"; +package $package; +use $CLASS; \$VERSION = ${CLASS}->new('0.0.4'); 1; EOF - close F; + close $fh; - eval "use lib '.'; use www 0.000008;"; - like ($@, qr/^www version 0.000008 required/, + eval "use lib '.'; use $package 0.000008;"; + like ($@, qr/^$package version 0.000008 required/, "Make sure very small versions don't freak"); - eval "use lib '.'; use www 1;"; - like ($@, qr/^www version 1 required/, + eval "use lib '.'; use $package 1;"; + like ($@, qr/^$package version 1 required/, "Comparing vs. version with no decimal"); - eval "use lib '.'; use www 1.;"; - like ($@, qr/^www version 1 required/, + eval "use lib '.'; use $package 1.;"; + like ($@, qr/^$package version 1 required/, "Comparing vs. version with decimal only"); - if ( $] < 5.006_000 ) { - unlink 'www.pm'; skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; } - eval "use lib '.'; use www v0.0.8;"; - my $regex = "^www version v0.0.8 required"; + eval "use lib '.'; use $package v0.0.8;"; + my $regex = "^$package version v0.0.8 required"; like ($@, qr/$regex/, "Make sure very small versions don't freak"); $regex =~ s/8/4/; # set for second test - eval "use lib '.'; use www v0.0.4;"; + eval "use lib '.'; use $package v0.0.4;"; unlike($@, qr/$regex/, 'Succeed - required == VERSION'); - cmp_ok ( "www"->VERSION, 'eq', '0.0.4', 'No undef warnings' ); - - unlink 'www.pm'; + cmp_ok ( $package->VERSION, 'eq', '0.0.4', 'No undef warnings' ); + unlink $filename; } - open F, ">vvv.pm" or die "Cannot open vvv.pm: $!\n"; - print F <<"EOF"; -package vvv; +SKIP: { + skip 'Cannot test "use base qw(version)" when require is used', 3 + unless defined $qv_declare; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh <<"EOF"; +package $package; use base qw(version); 1; EOF - close F; - # need to eliminate any other qv()'s - undef *main::qv; - ok(!defined(&{"main\::qv"}), "make sure we cleared qv() properly"); - eval "use lib '.'; use vvv;"; - ok(defined(&{"main\::qv"}), "make sure we exported qv() properly"); - isa_ok( qv(1.2), "vvv"); - unlink 'vvv.pm'; + close $fh; + # need to eliminate any other $qv_declare()'s + undef *{"main\::$qv_declare"}; + ok(!defined(&{"main\::$qv_declare"}), "make sure we cleared $qv_declare() properly"); + eval "use lib '.'; use $package qw/declare qv/;"; + ok(defined(&{"main\::$qv_declare"}), "make sure we exported $qv_declare() properly"); + isa_ok( &$qv_declare(1.2), $package); + unlink $filename; +} SKIP: { if ( $] < 5.006_000 ) { skip 'Cannot "use" extended versions with Perl < 5.6.0', 3; } - open F, ">uuu.pm" or die "Cannot open uuu.pm: $!\n"; - print F <<"EOF"; -package uuu; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh <<"EOF"; +package $package; \$VERSION = 1.0; 1; EOF - close F; - eval "use lib '.'; use uuu 1.001;"; - like ($@, qr/^uuu version 1.001 required/, + close $fh; + eval "use lib '.'; use $package 1.001;"; + like ($@, qr/^$package version 1.001 required/, "User typed numeric so we error with numeric"); - eval "use lib '.'; use uuu v1.1.0;"; - like ($@, qr/^uuu version v1.1.0 required/, + eval "use lib '.'; use $package v1.1.0;"; + like ($@, qr/^$package version v1.1.0 required/, "User typed extended so we error with extended"); - unlink 'uuu.pm'; + unlink $filename; } SKIP: { # test locale handling my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; + +$DB::single = 1; + my $v = $CLASS->$method('1,7'); + unlike($warning, qr"Version string '1,7' contains invalid data", + 'Directly test comma as decimal compliance'); + my $ver = 1.23; # has to be floating point number + my $orig_loc = setlocale( LC_ALL ); my $loc; while (<DATA>) { chomp; - $loc = POSIX::setlocale( &POSIX::LC_ALL, $_); - last if POSIX::localeconv()->{decimal_point} eq ','; + $loc = setlocale( LC_ALL, $_); + last if localeconv()->{decimal_point} eq ','; } skip 'Cannot test locale handling without a comma locale', 4 unless ( $loc and ($ver eq '1,23') ); - diag ("Testing locale handling with $loc") if $Verbose; + diag ("Testing locale handling with $loc") unless $ENV{PERL_CORE}; - my $v = $CLASS->new($ver); - unlike($warning,qr/Version string '1,23' contains invalid data/, + $v = $CLASS->$method($ver); + unlike($warning, qr/Version string '1,23' contains invalid data/, "Process locale-dependent floating point"); is ($v, "1.23", "Locale doesn't apply to version objects"); ok ($v == $ver, "Comparison to locale floating point"); + + setlocale( LC_ALL, $orig_loc); # reset this before possible skip + skip 'Cannot test RT#46921 with Perl < 5.008', 1 + if ($] < 5.008); + skip 'Cannot test RT#46921 with pure Perl module', 1 + if exists $INC{'version/vpp.pm'}; + my ($fh, $filename) = tempfile('tXXXXXXX', SUFFIX => '.pm', UNLINK => 1); + (my $package = basename($filename)) =~ s/\.pm$//; + print $fh <<"EOF"; +package $package; +use POSIX qw(locale_h); +\$^W = 1; +use $CLASS; +setlocale (LC_ALL, '$loc'); +use $CLASS ; +eval "use Socket 1.7"; +setlocale( LC_ALL, '$orig_loc'); +1; +EOF + close $fh; + + eval "use lib '.'; use $package;"; + unlike($warning, qr"Version string '1,7' contains invalid data", + 'Handle locale action-at-a-distance'); } - eval 'my $v = $CLASS->new("1._1");'; + eval 'my $v = $CLASS->$method("1._1");'; unlike($@, qr/^Invalid version format \(alpha with zero width\)/, "Invalid version format 1._1"); { my $warning; local $SIG{__WARN__} = sub { $warning = $_[0] }; - eval 'my $v = $CLASS->new(~0);'; + eval 'my $v = $CLASS->$method(~0);'; unlike($@, qr/Integer overflow in version/, "Too large version"); like($warning, qr/Integer overflow in version/, "Too large version"); } { # http://rt.cpan.org/Public/Bug/Display.html?id=30004 - my $v1 = $CLASS->new("v0.1_1"); + my $v1 = $CLASS->$method("v0.1_1"); (my $alpha1 = Dumper($v1)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms; - my $v2 = $CLASS->new($v1); + my $v2 = $CLASS->$method($v1); (my $alpha2 = Dumper($v2)) =~ s/.+'alpha' => ([^,]+),.+/$1/ms; is $alpha2, $alpha1, "Don't fall for Data::Dumper's tricks"; } diff --git a/pod/perlfunc.pod b/pod/perlfunc.pod index ddae4ed..bf22584 100644 --- a/pod/perlfunc.pod +++ b/pod/perlfunc.pod @@ -5356,27 +5356,26 @@ Examples: use sort '_mergesort'; # note discouraging _ @new = sort { substr($a, 3, 5) cmp substr($b, 3, 5) } @old; +Warning: syntactical care is required when sorting the list returned from +a function. If you want to sort the list returned by the function call +C<find_records(@key)>, you can use: -Warning: Care is required when sorting the list returned from a function. - -If you want to sort returned by the function call: find_records(@key) then -you can use: @contact = sort { $a cmp $b } find_records @key; @contact = sort +find_records(@key); @contact = sort &find_records(@key); @contact = sort(find_records(@key)); If instead you want to sort the array @key with the comparison routine -find_records then you can use: +C<find_records()> then you can use: + @contact = sort { find_records() } @key; @contact = sort find_records(@key); @contact = sort(find_records @key); @contact = sort(find_records (@key)); - If you're using strict, you I<must not> declare $a and $b as lexicals. They are package globals. That means -if you're in the C<main> package and type +that if you're in the C<main> package and type @articles = sort {$b <=> $a} @files; diff --git a/symbian/PerlBase.cpp b/symbian/PerlBase.cpp index 851fc15..4162e57 100644 --- a/symbian/PerlBase.cpp +++ b/symbian/PerlBase.cpp @@ -55,6 +55,19 @@ CPerlBase::~CPerlBase() Destruct(); } +EXPORT_C CPerlBase* CPerlBase::NewInterpreter(TBool aCloseStdlib, + void (*aStdioInitFunc)(void*), + void *aStdioInitCookie) +{ + CPerlBase* self = new (ELeave) CPerlBase; + self->iCloseStdlib = aCloseStdlib; + self->iStdioInitFunc = aStdioInitFunc; + self->iStdioInitCookie = aStdioInitCookie; + self->ConstructL(); + PERL_APPCTX_SET(self); + return self; +} + EXPORT_C CPerlBase* CPerlBase::NewInterpreterL(TBool aCloseStdlib, void (*aStdioInitFunc)(void*), void *aStdioInitCookie) diff --git a/symbian/sdk.pl b/symbian/sdk.pl index 4003ae0..ef0db0a 100644 --- a/symbian/sdk.pl +++ b/symbian/sdk.pl @@ -67,6 +67,15 @@ if (open(GCC, "gcc -v 2>&1 |")) { die "$0: failed to run gcc: $!\n"; } +# Configuration for S60 5th Edition SDK v0.9 +$SYMBIAN_VERSION = '9.4'; +$SDK_NAME = 'S60_5th_Edition_SDK'; +$WIN = 'winscw'; +$ENV{WIN} = $WIN; +$SDK_VARIANT = 'S60'; +$SDK_VERSION = $ENV{S60SDK} = '5.0'; +$SYMBIAN_ROOT = '\\'; + die "$0: failed to locate the Symbian SDK\n" unless defined $SYMBIAN_ROOT; my $UARM = $ENV{UARM} ? $ENV{UARM} : "urel"; @@ -201,5 +210,9 @@ $ENV{UARM} = $UARM; # set PATH=%EPOC_BIN%;%MWCW%\Bin;%MWCW%\Symbian_Tools\Command_Line_Tools;%MSVC_BIN%;C:\perl\bin;C:\winnt\system32;%PATH% # set USERDEFS=%USERDEFS% -D__UIQ_21__ -D__UIQ_MAJOR__=2 -D__UIQ_MINOR__=1 -D__UIQ_2X__ # +# Configuration for S60 5th Edition SDK v0.9 +#set EPOCROOT=\ +#set PATH=%EPOCROOT%epoc32\gcc\bin;%EPOCROOT%epoc32\tools;%PATH% +# # EOF diff --git a/symbian/symbian_dll.cpp b/symbian/symbian_dll.cpp index 92a06b8..a206c99 100644 --- a/symbian/symbian_dll.cpp +++ b/symbian/symbian_dll.cpp @@ -10,8 +10,6 @@ #include <e32base.h> #include "PerlBase.h" -EXPORT_C GLDEF_C TInt E32Dll(TDllReason /*aReason*/) { return KErrNone; } - extern "C" { EXPORT_C void* symbian_get_vars(void) { return Dll::Tls(); } EXPORT_C void symbian_set_vars(const void *p) { Dll::SetTls((TAny*)p); } diff --git a/symbian/symbian_utils.cpp b/symbian/symbian_utils.cpp index e6483ef..d4448fe 100644 --- a/symbian/symbian_utils.cpp +++ b/symbian/symbian_utils.cpp @@ -76,6 +76,8 @@ extern "C" { #ifdef PERL_GLOBAL_STRUCT /* Avoid unused variable warning. */ dVAR; #endif + if(!PL_appctx) + ((CPerlBase*)PL_appctx) = CPerlBase::NewInterpreter(); return ((CPerlBase*)PL_appctx)->ConsoleRead(fd, b, n); } EXPORT_C SSize_t symbian_write_stdout(const int fd, const char *b, int n) @@ -83,6 +85,8 @@ extern "C" { #ifdef PERL_GLOBAL_STRUCT /* Avoid unused variable warning. */ dVAR; #endif + if(!PL_appctx) + ((CPerlBase*)PL_appctx) = CPerlBase::NewInterpreter(); return ((CPerlBase*)PL_appctx)->ConsoleWrite(fd, b, n); } static const char NullErr[] = ""; @@ -171,7 +175,7 @@ extern "C" { } else { buf8.Format(_L8("Symbian error %d"), error); } - SV* sv = Perl_get_sv(aTHX_ "\005", GV_ADD); /* $^E or ${^OS_ERROR} */ + SV* sv = Perl_get_sv(aTHX_ "\005", TRUE); /* $^E or ${^OS_ERROR} */ if (!sv) return (char*)NullErr; sv_setpv(sv, (const char *)buf8.PtrZ()); @@ -195,13 +199,13 @@ extern "C" { TUint tick = User::TickCount(); if (PL_timesbase.tms_utime == 0) { PL_timesbase.tms_utime = tick; - PL_clocktick = PERL_SYMBIAN_CLK_TCK; + //PL_clocktick = PERL_SYMBIAN_CLK_TCK; } tick -= PL_timesbase.tms_utime; TInt64 tickus = TInt64(tick) * TInt64(periodus); TInt64 tmps = tickus / 1000000; - if (sec) *sec = tmps.Low(); - if (usec) *usec = tickus.Low() - tmps.Low() * 1000000; + if (sec) *sec = I64LOW(tmps); + if (usec) *usec = I64LOW(tickus) - I64LOW(tmps) * 1000000; return 0; } EXPORT_C int symbian_usleep(unsigned int usec) @@ -284,15 +288,16 @@ extern "C" { if (error == KErrNone) { TThreadFunction func = (TThreadFunction)(lib.Lookup(1)); if (func) - error = proc.Create(aFilename, - func, - KStackSize, - (TAny*)command, - &lib, - RThread().Heap(), - KHeapMin, - KHeapMax, - EOwnerProcess); + error = proc.Create(aFilename, + func, + KStackSize, + // (TAny*)command, + // &lib, + // RThread().Heap(), + KHeapMin, + KHeapMax, + (TAny*)command, + EOwnerProcess); else error = KErrNotFound; lib.Close(); diff --git a/universal.c b/universal.c index 2596600..7788c61 100644 --- a/universal.c +++ b/universal.c @@ -221,6 +221,7 @@ XS(XS_version_noop); #endif XS(XS_version_is_alpha); XS(XS_version_qv); +XS(XS_version_is_qv); XS(XS_utf8_is_utf8); XS(XS_utf8_valid); XS(XS_utf8_encode); @@ -268,6 +269,7 @@ Perl_boot_core_UNIVERSAL(pTHX) /* Make it findable via fetchmethod */ newXS("version::()", XS_version_noop, file); newXS("version::new", XS_version_new, file); + newXS("version::parse", XS_version_new, file); newXS("version::(\"\"", XS_version_stringify, file); newXS("version::stringify", XS_version_stringify, file); newXS("version::(0+", XS_version_numify, file); @@ -282,6 +284,8 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("version::noop", XS_version_noop, file); newXS("version::is_alpha", XS_version_is_alpha, file); newXS("version::qv", XS_version_qv, file); + newXS("version::declare", XS_version_qv, file); + newXS("version::is_qv", XS_version_is_qv, file); } newXS("utf8::is_utf8", XS_utf8_is_utf8, file); newXS("utf8::valid", XS_utf8_valid, file); @@ -728,25 +732,53 @@ XS(XS_version_qv) { dVAR; dXSARGS; - if (items != 1) - croak_xs_usage(cv, "ver"); SP -= items; { - SV * ver = ST(0); - if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */ - SV * const rv = sv_newmortal(); + SV * ver = ST(0); + SV * rv; + const char * classname = ""; + if ( items == 2 && (ST(1)) != &PL_sv_undef ) { + /* getting called as object or class method */ + ver = ST(1); + classname = + sv_isobject(ST(0)) /* class called as an object method */ + ? HvNAME_get(SvSTASH(SvRV(ST(0)))) + : (char *)SvPV_nolen(ST(0)); + } + if ( !SvVOK(ver) ) { /* not already a v-string */ + rv = sv_newmortal(); sv_setsv(rv,ver); /* make a duplicate */ upg_version(rv, TRUE); - PUSHs(rv); + } else { + rv = sv_2mortal(new_version(ver)); } - else - { - mPUSHs(new_version(ver)); + if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */ + sv_bless(rv, gv_stashpv(classname, GV_ADD)); } + PUSHs(rv); + } + PUTBACK; + return; +} +XS(XS_version_is_qv) +{ + dVAR; + dXSARGS; + if (items != 1) + croak_xs_usage(cv, "lobj"); + SP -= items; + if (sv_derived_from(ST(0), "version")) { + SV * const lobj = ST(0); + if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) ) + XSRETURN_YES; + else + XSRETURN_NO; PUTBACK; return; } + else + Perl_croak(aTHX_ "lobj is not of type version"); } XS(XS_utf8_is_utf8) diff --git a/util.c b/util.c index 5ee7425..23d5d2d 100644 --- a/util.c +++ b/util.c @@ -4279,7 +4279,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) pos = s; /* pre-scan the input string to check for decimals/underbars */ - while ( *pos == '.' || *pos == '_' || isDIGIT(*pos) ) + while ( *pos == '.' || *pos == '_' || *pos == ',' || isDIGIT(*pos) ) { if ( *pos == '.' ) { @@ -4295,6 +4295,12 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) alpha = 1; width = pos - last - 1; /* natural width of sub-version */ } + else if ( *pos == ',' && isDIGIT(pos[1]) ) + { + saw_period++ ; + last = pos; + } + pos++; } @@ -4382,6 +4388,8 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) s = ++pos; else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; + else if ( *pos == ',' && isDIGIT(pos[1]) ) + s = ++pos; else if ( isDIGIT(*pos) ) s = pos; else { -- Perl5 Master Repository
