From: Jarkko Hietaniemi Date: Wed, 15 Jan 2003 14:09:57 +0000 (+0000) Subject: Upgrade to Time::HiRes 1.42. X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=98b50af3d45dfb6f244ad0156bf5b77f62f20375;p=p5sagit%2Fp5-mst-13.2.git Upgrade to Time::HiRes 1.42. p4raw-id: //depot/perl@18484 --- diff --git a/MANIFEST b/MANIFEST index 44a53a7..e8c8e66 100644 --- a/MANIFEST +++ b/MANIFEST @@ -710,6 +710,8 @@ ext/threads/threads.pm ithreads ext/threads/threads.xs ithreads ext/threads/typemap ithreads ext/Time/HiRes/Changes Time::HiRes extension +ext/Time/HiRes/fallback/const-c.inc Time::HiRes extension +ext/Time/HiRes/fallback/const-xs.inc Time::HiRes extension ext/Time/HiRes/hints/dynixptx.pl Hint for Time::HiRes for named architecture ext/Time/HiRes/hints/sco.pl Hints for Time::HiRes for named architecture ext/Time/HiRes/HiRes.pm Time::HiRes extension diff --git a/ext/Time/HiRes/Changes b/ext/Time/HiRes/Changes index 2340fb5..971e701 100644 --- a/ext/Time/HiRes/Changes +++ b/ext/Time/HiRes/Changes @@ -1,5 +1,26 @@ Revision history for Perl extension Time::HiRes. +1.42 + - modernize the constants code (from Nicholas Clark) + +1.41 + - At some point the ability to figure our the correct incdir + for EXTERN.h (either a core perl build, or an installed perl) + had broken (which lead into all test compiles failing with + a core perl build, but thanks to the robustness of Makefile.PL + nothing of was visible). The brokenness seemed to be caused + by $ENV{PERL_CORE} not being on for core builds? Now stole + a trick from the Encode that sets $ENV{PERL_CORE} right, and + both styles of build should work again. + +1.40 + - Nicholas Clark noticed that the my_catdir() emulation function + was broken (which means that we didn't really work for Perls + 5.002 and 5.003) + - inspired by fixing the above made the whole Makefile.PL -w + and strict clean + - tightened up the Makefile.PL output, less whitespace + 1.39 - fix from Craig Berry for better building in VMS with PERL_CORE diff --git a/ext/Time/HiRes/HiRes.pm b/ext/Time/HiRes/HiRes.pm index 532484e..ffa010b 100644 --- a/ext/Time/HiRes/HiRes.pm +++ b/ext/Time/HiRes/HiRes.pm @@ -15,18 +15,16 @@ require DynaLoader; d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer d_nanosleep); -$VERSION = '1.39'; +$VERSION = '1.42'; $XS_VERSION = $VERSION; $VERSION = eval $VERSION; sub AUTOLOAD { my $constname; - ($constname= $AUTOLOAD) =~ s/.*:://; - my $val = constant($constname, @_ ? $_[0] : 0); - if ($!) { - my ($pack,$file,$line) = caller; - die "Your vendor has not defined Time::HiRes macro $constname, used at $file line $line.\n"; - } + ($constname = $AUTOLOAD) =~ s/.*:://; + die "&Time::HiRes::constant not defined" if $constname eq 'constant'; + my ($error, $val) = constant($constname); + if ($error) { die $error; } { no strict 'refs'; *$AUTOLOAD = sub { $val }; diff --git a/ext/Time/HiRes/HiRes.xs b/ext/Time/HiRes/HiRes.xs index 5da54c6..560cb3d 100644 --- a/ext/Time/HiRes/HiRes.xs +++ b/ext/Time/HiRes/HiRes.xs @@ -98,77 +98,14 @@ sv_2pv_nolen(pTHX_ register SV *sv) # undef ITIMER_REALPROF #endif -static IV -constant(char *name, int arg) -{ - errno = 0; - switch (*name) { - case 'd': - if (strEQ(name, "d_getitimer")) -#ifdef HAS_GETITIMER - return 1; -#else - return 0; -#endif - if (strEQ(name, "d_nanosleep")) -#ifdef HAS_NANOSLEEP - return 1; -#else - return 0; -#endif - if (strEQ(name, "d_setitimer")) -#ifdef HAS_SETITIMER - return 1; -#else - return 0; -#endif - if (strEQ(name, "d_ualarm")) -#ifdef HAS_UALARM - return 1; -#else - return 0; -#endif - if (strEQ(name, "d_usleep")) -#ifdef HAS_USLEEP - return 1; -#else - return 0; +/* 5.004 doesn't define PL_sv_undef */ +#ifndef ATLEASTFIVEOHOHFIVE +#ifndef PL_sv_undef +#define PL_sv_undef sv_undef #endif - break; - case 'I': - if (strEQ(name, "ITIMER_REAL")) -#ifdef ITIMER_REAL - return ITIMER_REAL; -#else - goto not_there; -#endif - if (strEQ(name, "ITIMER_REALPROF")) -#ifdef ITIMER_REALPROF - return ITIMER_REALPROF; -#else - goto not_there; #endif - if (strEQ(name, "ITIMER_VIRTUAL")) -#ifdef ITIMER_VIRTUAL - return ITIMER_VIRTUAL; -#else - goto not_there; -#endif - if (strEQ(name, "ITIMER_PROF")) -#ifdef ITIMER_PROF - return ITIMER_PROF; -#else - goto not_there; -#endif - break; - } - errno = EINVAL; - return 0; -not_there: - errno = ENOENT; - return 0; -} +#include "const-c.inc" #if !defined(HAS_GETTIMEOFDAY) && defined(WIN32) #define HAS_GETTIMEOFDAY @@ -699,10 +636,7 @@ BOOT: #endif #endif -IV -constant(name, arg) - char * name - int arg +INCLUDE: const-xs.inc #if defined(HAS_USLEEP) && defined(HAS_GETTIMEOFDAY) diff --git a/ext/Time/HiRes/Makefile.PL b/ext/Time/HiRes/Makefile.PL index 5868239..50b98ba 100644 --- a/ext/Time/HiRes/Makefile.PL +++ b/ext/Time/HiRes/Makefile.PL @@ -7,10 +7,18 @@ require 5.002; use Config; use ExtUtils::MakeMaker; - -# Perls 5.002 and 5.003 did not have File::Spec, fake what we need. +use strict; my $VERBOSE = $ENV{VERBOSE}; +my $DEFINE; +my $LIBS; +my $XSOPT; + +unless($ENV{PERL_CORE}) { # This trick from Encode/Makefile.PL. + $ENV{PERL_CORE} = 1 if ($^X =~ m{\bminiperl[^/\\\]>:]*$}o); +} + +# Perls 5.002 and 5.003 did not have File::Spec, fake what we need. sub my_dirsep { $^O eq 'VMS' ? '.' : @@ -22,7 +30,14 @@ sub my_dirsep { sub my_catdir { shift; my $catdir = join(my_dirsep, @_); - $^O eq 'VMS' ? "[$dirsep]" : $dirsep; + $^O eq 'VMS' ? "[$catdir]" : $catdir; +} + +sub my_catfile { + shift; + return join(my_dirsep, @_) unless $^O eq 'VMS'; + my $file = pop; + return my_catdir (undef, @_) . $file; } sub my_updir { @@ -35,9 +50,15 @@ BEGIN { if ($@) { *File::Spec::catdir = \&my_catdir; *File::Spec::updir = \&my_updir; + *File::Spec::catfile = \&my_catfile; } } +# Avoid 'used only once' warnings. +my $nop1 = *File::Spec::catdir; +my $nop2 = *File::Spec::updir; +my $nop3 = *File::Spec::catfile; + # if you have 5.004_03 (and some slightly older versions?), xsubpp # tries to generate line numbers in the C code generated from the .xs. # unfortunately, it is a little buggy around #ifdef'd code. @@ -50,8 +71,7 @@ sub TMPDIR { my $TMPDIR = (grep(defined $_ && -d $_ && -w _, ((defined $ENV{'TMPDIR'} ? $ENV{'TMPDIR'} : undef), - qw(/var/tmp /usr/tmp /tmp))))[0] - unless defined $TMPDIR; + qw(/var/tmp /usr/tmp /tmp))))[0]; $TMPDIR || die "Cannot find writable temporary directory.\n"; } @@ -59,7 +79,7 @@ sub try_compile_and_link { my ($c, %args) = @_; my ($ok) = 0; - my ($tmp) = (($^O eq 'VMS') ? "sys\$scratch:tmp$$" : TMPDIR . '/' . "tmp$$"); + my ($tmp) = (($^O eq 'VMS') ? "sys\$scratch:tmp$$" : TMPDIR() . '/' . "tmp$$"); local(*TMPC); my $obj_ext = $Config{obj_ext} || ".o"; @@ -69,18 +89,21 @@ sub try_compile_and_link { print TMPC $c; close(TMPC); - $cccmd = $args{cccmd}; + my $cccmd = $args{cccmd}; my $errornull; my $COREincdir; + if ($ENV{PERL_CORE}) { my $updir = File::Spec->updir; $COREincdir = File::Spec->catdir(($updir) x 3); } else { $COREincdir = File::Spec->catdir($Config{'archlibexp'}, 'CORE'); } + my $ccflags = $Config{'ccflags'} . ' ' . "-I$COREincdir"; + if ($^O eq 'VMS') { if ($ENV{PERL_CORE}) { # Fragile if the extensions change hierachy within @@ -89,7 +112,7 @@ sub try_compile_and_link { } else { my $perl_core = $Config{'installarchlib'}; $perl_core =~ s/\]$/.CORE]/; - $cccmd = "$Config{'cc'} /include=(perl_root:[000000],$perl_core) $tmp.c"; + $cccmd = "$Config{'cc'} /include=(perl_root:[000000],$perl_core) $tmp.c"; } } @@ -99,18 +122,19 @@ sub try_compile_and_link { $errornull = ''; } - $cccmd = "$Config{'cc'} -o $tmp $ccflags $tmp.c @$LIBS $errornull" + $cccmd = "$Config{'cc'} -o $tmp $ccflags $tmp.c @$LIBS $errornull" unless defined $cccmd; + if ($^O eq 'VMS') { open( CMDFILE, ">$tmp.com" ); print CMDFILE "\$ SET MESSAGE/NOFACILITY/NOSEVERITY/NOIDENT/NOTEXT\n"; print CMDFILE "\$ $cccmd\n"; - print CMDFILE "\$ IF \$SEVERITY .NE. 1 THEN EXIT 44\n"; # escalate + print CMDFILE "\$ IF \$SEVERITY .NE. 1 THEN EXIT 44\n"; # escalate close CMDFILE; system("\@ $tmp.com"); $ok = $?==0; for ("$tmp.c", "$tmp$obj_ext", "$tmp.com", "$tmp$Config{exe_ext}") { - 1 while unlink $_; + 1 while unlink $_; } } else @@ -128,7 +152,7 @@ sub try_compile_and_link { sub has_gettimeofday { # confusing but true (if condition true ==> -DHAS_GETTIMEOFDAY already) return 0 if $Config{'d_gettimeod'} eq 'define'; - return 1 if try_compile_and_link(<= 5.005) { push (@makefileopts, @@ -374,17 +405,42 @@ sub doMakefile { 'SUFFIX' => 'gz', }, clean => { FILES => "xdefine" }, + realclean => {FILES=> 'const-c.inc const-xs.inc'}, ); WriteMakefile(@makefileopts); } -sub main { - print < $_, macro => $macro, value => 1, + default => ["IV", "0"]}; + } + ExtUtils::Constant::WriteConstants( + NAME => 'Time::HiRes', + NAMES => \@names, + ); + } else { + foreach my $file ('const-c.inc', 'const-xs.inc') { + my $fallback = File::Spec->catfile('fallback', $file); + local $/; + open IN, "<$fallback" or die "Can't open $fallback: $!"; + open OUT, ">$file" or die "Can't open $file: $!"; + print OUT or die $!; + close OUT or die "Can't close $file: $!"; + close IN or die "Can't close $fallback: $!"; + } + } +} -EOM +sub main { + print "Configuring Time::HiRes...\n"; if ($^O =~ /Win32/i) { $DEFINE = '-DSELECT_IS_BROKEN'; @@ -392,16 +448,12 @@ EOM } else { unixinit(); } - configure; doMakefile; + doConstants; my $make = $Config{'make'} || "make"; unless ($ENV{PERL_CORE}) { print <"d_getitimer", type=>"IV", macro=>"HAS_GETITIMER", value=>"1", default=>["IV", "0"]}, + {name=>"d_gettimeofday", type=>"IV", macro=>"HAS_GETTIMEOFDAY", value=>"1", default=>["IV", "0"]}, + {name=>"d_nanosleep", type=>"IV", macro=>"HAS_NANOSLEEP", value=>"1", default=>["IV", "0"]}, + {name=>"d_setitimer", type=>"IV", macro=>"HAS_SETITIMER", value=>"1", default=>["IV", "0"]}, + {name=>"d_ualarm", type=>"IV", macro=>"HAS_UALARM", value=>"1", default=>["IV", "0"]}, + {name=>"d_usleep", type=>"IV", macro=>"HAS_USLEEP", value=>"1", default=>["IV", "0"]}); + +print constant_types(); # macro defs +foreach (C_constant ("Time::HiRes", 'constant', 'IV', $types, undef, 3, @names) ) { + print $_, "\n"; # C constant subs +} +print "#### XS Section:\n"; +print XS_constant ("Time::HiRes", $types); +__END__ + */ + + switch (len) { + case 8: + /* Names all of length 8. */ + /* d_ualarm d_usleep */ + /* Offset 7 gives the best switch position. */ + switch (name[7]) { + case 'm': + if (memEQ(name, "d_ualarm", 8)) { + /* ^ */ +#ifdef HAS_UALARM + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + case 'p': + if (memEQ(name, "d_usleep", 8)) { + /* ^ */ +#ifdef HAS_USLEEP + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + break; + case 11: + return constant_11 (aTHX_ name, iv_return); + break; + case 14: + /* Names all of length 14. */ + /* ITIMER_VIRTUAL d_gettimeofday */ + /* Offset 6 gives the best switch position. */ + switch (name[6]) { + case '_': + if (memEQ(name, "ITIMER_VIRTUAL", 14)) { + /* ^ */ +#ifdef ITIMER_VIRTUAL + *iv_return = ITIMER_VIRTUAL; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + case 'i': + if (memEQ(name, "d_gettimeofday", 14)) { + /* ^ */ +#ifdef HAS_GETTIMEOFDAY + *iv_return = 1; + return PERL_constant_ISIV; +#else + *iv_return = 0; + return PERL_constant_ISIV; +#endif + } + break; + } + break; + case 15: + if (memEQ(name, "ITIMER_REALPROF", 15)) { +#ifdef ITIMER_REALPROF + *iv_return = ITIMER_REALPROF; + return PERL_constant_ISIV; +#else + return PERL_constant_NOTDEF; +#endif + } + break; + } + return PERL_constant_NOTFOUND; +} + diff --git a/ext/Time/HiRes/fallback/const-xs.inc b/ext/Time/HiRes/fallback/const-xs.inc new file mode 100644 index 0000000..c84dd05 --- /dev/null +++ b/ext/Time/HiRes/fallback/const-xs.inc @@ -0,0 +1,88 @@ +void +constant(sv) + PREINIT: +#ifdef dXSTARG + dXSTARG; /* Faster if we have it. */ +#else + dTARGET; +#endif + STRLEN len; + int type; + IV iv; + /* NV nv; Uncomment this if you need to return NVs */ + /* const char *pv; Uncomment this if you need to return PVs */ + INPUT: + SV * sv; + const char * s = SvPV(sv, len); + PPCODE: + /* Change this to constant(aTHX_ s, len, &iv, &nv); + if you need to return both NVs and IVs */ + type = constant(aTHX_ s, len, &iv); + /* Return 1 or 2 items. First is error message, or undef if no error. + Second, if present, is found value */ + switch (type) { + case PERL_constant_NOTFOUND: + sv = sv_2mortal(newSVpvf("%s is not a valid Time::HiRes macro", s)); + PUSHs(sv); + break; + case PERL_constant_NOTDEF: + sv = sv_2mortal(newSVpvf( + "Your vendor has not defined Time::HiRes macro %s, used", s)); + PUSHs(sv); + break; + case PERL_constant_ISIV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHi(iv); + break; + /* Uncomment this if you need to return NOs + case PERL_constant_ISNO: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_no); + break; */ + /* Uncomment this if you need to return NVs + case PERL_constant_ISNV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHn(nv); + break; */ + /* Uncomment this if you need to return PVs + case PERL_constant_ISPV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, strlen(pv)); + break; */ + /* Uncomment this if you need to return PVNs + case PERL_constant_ISPVN: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHp(pv, iv); + break; */ + /* Uncomment this if you need to return SVs + case PERL_constant_ISSV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(sv); + break; */ + /* Uncomment this if you need to return UNDEFs + case PERL_constant_ISUNDEF: + break; */ + /* Uncomment this if you need to return UVs + case PERL_constant_ISUV: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHu((UV)iv); + break; */ + /* Uncomment this if you need to return YESs + case PERL_constant_ISYES: + EXTEND(SP, 1); + PUSHs(&PL_sv_undef); + PUSHs(&PL_sv_yes); + break; */ + default: + sv = sv_2mortal(newSVpvf( + "Unexpected return type %d while processing Time::HiRes macro %s, used", + type, s)); + PUSHs(sv); + }