dslinux/user/perl/ext/Time/HiRes Changes HiRes.pm HiRes.xs Makefile.PL ppport.h typemap
cayenne
dslinux_cayenne at user.in-berlin.de
Tue Dec 5 05:26:58 CET 2006
Update of /cvsroot/dslinux/dslinux/user/perl/ext/Time/HiRes
In directory antilope:/tmp/cvs-serv7729/ext/Time/HiRes
Added Files:
Changes HiRes.pm HiRes.xs Makefile.PL ppport.h typemap
Log Message:
Adding fresh perl source to HEAD to branch from
--- NEW FILE: HiRes.pm ---
package Time::HiRes;
use strict;
use vars qw($VERSION $XS_VERSION @ISA @EXPORT @EXPORT_OK $AUTOLOAD);
require Exporter;
require DynaLoader;
@ISA = qw(Exporter DynaLoader);
@EXPORT = qw( );
@EXPORT_OK = qw (usleep sleep ualarm alarm gettimeofday time tv_interval
getitimer setitimer nanosleep clock_gettime clock_getres
clock clock_nanosleep
CLOCK_HIGHRES CLOCK_MONOTONIC CLOCK_PROCESS_CPUTIME_ID
CLOCK_REALTIME CLOCK_SOFTTIME CLOCK_THREAD_CPUTIME_ID
CLOCK_TIMEOFDAY CLOCKS_PER_SEC
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
TIMER_ABSTIME
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
d_nanosleep d_clock_gettime d_clock_getres
d_clock d_clock_nanosleep);
$VERSION = '1.86';
$XS_VERSION = $VERSION;
$VERSION = eval $VERSION;
sub AUTOLOAD {
my $constname;
($constname = $AUTOLOAD) =~ s/.*:://;
# print "AUTOLOAD: constname = $constname ($AUTOLOAD)\n";
die "&Time::HiRes::constant not defined" if $constname eq 'constant';
my ($error, $val) = constant($constname);
# print "AUTOLOAD: error = $error, val = $val\n";
if ($error) {
my (undef,$file,$line) = caller;
die "$error at $file line $line.\n";
}
{
no strict 'refs';
*$AUTOLOAD = sub { $val };
}
goto &$AUTOLOAD;
}
sub import {
my $this = shift;
for my $i (@_) {
if (($i eq 'clock_getres' && !&d_clock_getres) ||
($i eq 'clock_gettime' && !&d_clock_gettime) ||
($i eq 'clock_nanosleep' && !&d_clock_nanosleep) ||
($i eq 'clock' && !&d_clock) ||
($i eq 'nanosleep' && !&d_nanosleep) ||
($i eq 'usleep' && !&d_usleep) ||
($i eq 'ualarm' && !&d_ualarm)) {
require Carp;
Carp::croak("Time::HiRes::$i(): unimplemented in this platform");
}
}
Time::HiRes->export_to_level(1, $this, @_);
}
bootstrap Time::HiRes;
# Preloaded methods go here.
sub tv_interval {
# probably could have been done in C
my ($a, $b) = @_;
$b = [gettimeofday()] unless defined($b);
(${$b}[0] - ${$a}[0]) + ((${$b}[1] - ${$a}[1]) / 1_000_000);
}
# Autoload methods go after =cut, and are processed by the autosplit program.
1;
__END__
=head1 NAME
Time::HiRes - High resolution alarm, sleep, gettimeofday, interval timers
=head1 SYNOPSIS
use Time::HiRes qw( usleep ualarm gettimeofday tv_interval nanosleep
clock_gettime clock_getres clock_nanosleep clock );
usleep ($microseconds);
nanosleep ($nanoseconds);
ualarm ($microseconds);
ualarm ($microseconds, $interval_microseconds);
$t0 = [gettimeofday];
($seconds, $microseconds) = gettimeofday;
$elapsed = tv_interval ( $t0, [$seconds, $microseconds]);
$elapsed = tv_interval ( $t0, [gettimeofday]);
$elapsed = tv_interval ( $t0 );
use Time::HiRes qw ( time alarm sleep );
$now_fractions = time;
sleep ($floating_seconds);
alarm ($floating_seconds);
alarm ($floating_seconds, $floating_interval);
use Time::HiRes qw( setitimer getitimer
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF );
setitimer ($which, $floating_seconds, $floating_interval );
getitimer ($which);
$realtime = clock_gettime(CLOCK_REALTIME);
$resolution = clock_getres(CLOCK_REALTIME);
clock_nanosleep(CLOCK_REALTIME, 1.5);
clock_nanosleep(CLOCK_REALTIME, time() + 10, TIMER_ABSTIME);
my $ticktock = clock();
=head1 DESCRIPTION
The C<Time::HiRes> module implements a Perl interface to the
C<usleep>, C<nanosleep>, C<ualarm>, C<gettimeofday>, and
C<setitimer>/C<getitimer> system calls, in other words, high
resolution time and timers. See the L</EXAMPLES> section below and the
test scripts for usage; see your system documentation for the
description of the underlying C<nanosleep> or C<usleep>, C<ualarm>,
C<gettimeofday>, and C<setitimer>/C<getitimer> calls.
If your system lacks C<gettimeofday()> or an emulation of it you don't
get C<gettimeofday()> or the one-argument form of C<tv_interval()>.
If your system lacks all of C<nanosleep()>, C<usleep()>,
C<select()>, and C<poll>, you don't get C<Time::HiRes::usleep()>,
C<Time::HiRes::nanosleep()>, or C<Time::HiRes::sleep()>.
If your system lacks both C<ualarm()> and C<setitimer()> you don't get
C<Time::HiRes::ualarm()> or C<Time::HiRes::alarm()>.
If you try to import an unimplemented function in the C<use> statement
it will fail at compile time.
If your subsecond sleeping is implemented with C<nanosleep()> instead
of C<usleep()>, you can mix subsecond sleeping with signals since
C<nanosleep()> does not use signals. This, however, is not portable,
and you should first check for the truth value of
C<&Time::HiRes::d_nanosleep> to see whether you have nanosleep, and
then carefully read your C<nanosleep()> C API documentation for any
peculiarities.
If you are using C<nanosleep> for something else than mixing sleeping
with signals, give some thought to whether Perl is the tool you should
be using for work requiring nanosecond accuracies.
The following functions can be imported from this module.
No functions are exported by default.
=over 4
=item gettimeofday ()
In array context returns a two-element array with the seconds and
microseconds since the epoch. In scalar context returns floating
seconds like C<Time::HiRes::time()> (see below).
=item usleep ( $useconds )
Sleeps for the number of microseconds (millionths of a second)
specified. Returns the number of microseconds actually slept. Can
sleep for more than one second, unlike the C<usleep> system call. Can
also sleep for zero seconds, which often works like a I<thread yield>.
See also C<Time::HiRes::usleep()>, C<Time::HiRes::sleep()>, and
C<Time::HiRes::clock_nanosleep()>.
Do not expect usleep() to be exact down to one microsecond.
=item nanosleep ( $nanoseconds )
Sleeps for the number of nanoseconds (1e9ths of a second) specified.
Returns the number of nanoseconds actually slept (accurate only to
microseconds, the nearest thousand of them). Can sleep for more than
one second. Can also sleep for zero seconds, which often works like a
I<thread yield>. See also C<Time::HiRes::sleep()>,
C<Time::HiRes::usleep()>, and C<Time::HiRes::clock_nanosleep()>.
Do not expect nanosleep() to be exact down to one nanosecond.
Getting even accuracy of one thousand nanoseconds is good.
=item ualarm ( $useconds [, $interval_useconds ] )
Issues a C<ualarm> call; the C<$interval_useconds> is optional and
will be zero if unspecified, resulting in C<alarm>-like behaviour.
Note that the interaction between alarms and sleeps is unspecified.
=item tv_interval
tv_interval ( $ref_to_gettimeofday [, $ref_to_later_gettimeofday] )
Returns the floating seconds between the two times, which should have
been returned by C<gettimeofday()>. If the second argument is omitted,
then the current time is used.
=item time ()
Returns a floating seconds since the epoch. This function can be
imported, resulting in a nice drop-in replacement for the C<time>
provided with core Perl; see the L</EXAMPLES> below.
B<NOTE 1>: This higher resolution timer can return values either less
or more than the core C<time()>, depending on whether your platform
rounds the higher resolution timer values up, down, or to the nearest second
to get the core C<time()>, but naturally the difference should be never
more than half a second. See also L</clock_getres>, if available
in your system.
B<NOTE 2>: Since Sunday, September 9th, 2001 at 01:46:40 AM GMT, when
the C<time()> seconds since epoch rolled over to 1_000_000_000, the
default floating point format of Perl and the seconds since epoch have
conspired to produce an apparent bug: if you print the value of
C<Time::HiRes::time()> you seem to be getting only five decimals, not
six as promised (microseconds). Not to worry, the microseconds are
there (assuming your platform supports such granularity in the first
place). What is going on is that the default floating point format of
Perl only outputs 15 digits. In this case that means ten digits
before the decimal separator and five after. To see the microseconds
you can use either C<printf>/C<sprintf> with C<"%.6f">, or the
C<gettimeofday()> function in list context, which will give you the
seconds and microseconds as two separate values.
=item sleep ( $floating_seconds )
Sleeps for the specified amount of seconds. Returns the number of
seconds actually slept (a floating point value). This function can
be imported, resulting in a nice drop-in replacement for the C<sleep>
provided with perl, see the L</EXAMPLES> below.
Note that the interaction between alarms and sleeps is unspecified.
=item alarm ( $floating_seconds [, $interval_floating_seconds ] )
The C<SIGALRM> signal is sent after the specified number of seconds.
Implemented using C<ualarm()>. The C<$interval_floating_seconds> argument
is optional and will be zero if unspecified, resulting in C<alarm()>-like
behaviour. This function can be imported, resulting in a nice drop-in
replacement for the C<alarm> provided with perl, see the L</EXAMPLES> below.
B<NOTE 1>: With some combinations of operating systems and Perl
releases C<SIGALRM> restarts C<select()>, instead of interrupting it.
This means that an C<alarm()> followed by a C<select()> may together
take the sum of the times specified for the the C<alarm()> and the
C<select()>, not just the time of the C<alarm()>.
Note that the interaction between alarms and sleeps is unspecified.
=item setitimer ( $which, $floating_seconds [, $interval_floating_seconds ] )
Start up an interval timer: after a certain time, a signal arrives,
and more signals may keep arriving at certain intervals. To disable
an "itimer", use C<$floating_seconds> of zero. If the
C<$interval_floating_seconds> is set to zero (or unspecified), the
timer is disabled B<after> the next delivered signal.
Use of interval timers may interfere with C<alarm()>, C<sleep()>,
and C<usleep()>. In standard-speak the "interaction is unspecified",
which means that I<anything> may happen: it may work, it may not.
In scalar context, the remaining time in the timer is returned.
In list context, both the remaining time and the interval are returned.
There are usually three or four interval timers available: the
C<$which> can be C<ITIMER_REAL>, C<ITIMER_VIRTUAL>, C<ITIMER_PROF>, or
C<ITIMER_REALPROF>. Note that which ones are available depends: true
UNIX platforms usually have the first three, but (for example) Win32
and Cygwin have only C<ITIMER_REAL>, and only Solaris seems to have
C<ITIMER_REALPROF> (which is used to profile multithreaded programs).
C<ITIMER_REAL> results in C<alarm()>-like behaviour. Time is counted in
I<real time>; that is, wallclock time. C<SIGALRM> is delivered when
the timer expires.
C<ITIMER_VIRTUAL> counts time in (process) I<virtual time>; that is,
only when the process is running. In multiprocessor/user/CPU systems
this may be more or less than real or wallclock time. (This time is
also known as the I<user time>.) C<SIGVTALRM> is delivered when the
timer expires.
C<ITIMER_PROF> counts time when either the process virtual time or when
the operating system is running on behalf of the process (such as I/O).
(This time is also known as the I<system time>.) (The sum of user
time and system time is known as the I<CPU time>.) C<SIGPROF> is
delivered when the timer expires. C<SIGPROF> can interrupt system calls.
The semantics of interval timers for multithreaded programs are
system-specific, and some systems may support additional interval
timers. See your C<setitimer()> documentation.
=item getitimer ( $which )
Return the remaining time in the interval timer specified by C<$which>.
In scalar context, the remaining time is returned.
In list context, both the remaining time and the interval are returned.
The interval is always what you put in using C<setitimer()>.
=item clock_gettime ( $which )
Return as seconds the current value of the POSIX high resolution timer
specified by C<$which>. All implementations that support POSIX high
resolution timers are supposed to support at least the C<$which> value
of C<CLOCK_REALTIME>, which is supposed to return results close to the
results of C<gettimeofday>, or the number of seconds since 00:00:00:00
January 1, 1970 Greenwich Mean Time (GMT). Do not assume that
CLOCK_REALTIME is zero, it might be one, or something else.
Another potentially useful (but not available everywhere) value is
C<CLOCK_MONOTONIC>, which guarantees a monotonically increasing time
value (unlike time(), which can be adjusted). See your system
documentation for other possibly supported values.
=item clock_getres ( $which )
Return as seconds the resolution of the POSIX high resolution timer
specified by C<$which>. All implementations that support POSIX high
resolution timers are supposed to support at least the C<$which> value
of C<CLOCK_REALTIME>, see L</clock_gettime>.
=item clock_nanosleep ( $which, $seconds, $flags = 0)
Sleeps for the number of seconds (1e9ths of a second) specified.
Returns the number of seconds actually slept. The $which is the
"clock id", as with clock_gettime() and clock_getres(). The flags
default to zero but C<TIMER_ABSTIME> can specified (must be exported
explicitly) which means that C<$nanoseconds> is not a time interval
(as is the default) but instead an absolute time. Can sleep for more
than one second. Can also sleep for zero seconds, which often works
like a I<thread yield>. See also C<Time::HiRes::sleep()>,
C<Time::HiRes::usleep()>, and C<Time::HiRes::nanosleep()>.
Do not expect clock_nanosleep() to be exact down to one nanosecond.
Getting even accuracy of one thousand nanoseconds is good.
=item clock()
Return as seconds the I<process time> (user + system time) spent by
the process since the first call to clock() (the definition is B<not>
"since the start of the process", though if you are lucky these times
may be quite close to each other, depending on the system). What this
means is that you probably need to store the result of your first call
to clock(), and subtract that value from the following results of clock().
The time returned also includes the process times of the terminated
child processes for which wait() has been executed. This value is
somewhat like the second value returned by the times() of core Perl,
but not necessarily identical. Note that due to backward
compatibility limitations the returned value may wrap around at about
2147 seconds or at about 36 minutes.
=back
=head1 EXAMPLES
use Time::HiRes qw(usleep ualarm gettimeofday tv_interval);
$microseconds = 750_000;
usleep($microseconds);
# signal alarm in 2.5s & every .1s thereafter
ualarm(2_500_000, 100_000);
# get seconds and microseconds since the epoch
($s, $usec) = gettimeofday();
# measure elapsed time
# (could also do by subtracting 2 gettimeofday return values)
$t0 = [gettimeofday];
# do bunch of stuff here
$t1 = [gettimeofday];
# do more stuff here
$t0_t1 = tv_interval $t0, $t1;
$elapsed = tv_interval ($t0, [gettimeofday]);
$elapsed = tv_interval ($t0); # equivalent code
#
# replacements for time, alarm and sleep that know about
# floating seconds
#
use Time::HiRes;
$now_fractions = Time::HiRes::time;
Time::HiRes::sleep (2.5);
Time::HiRes::alarm (10.6666666);
use Time::HiRes qw ( time alarm sleep );
$now_fractions = time;
sleep (2.5);
alarm (10.6666666);
# Arm an interval timer to go off first at 10 seconds and
# after that every 2.5 seconds, in process virtual time
use Time::HiRes qw ( setitimer ITIMER_VIRTUAL time );
$SIG{VTALRM} = sub { print time, "\n" };
setitimer(ITIMER_VIRTUAL, 10, 2.5);
use Time::HiRes qw( clock_gettime clock_getres CLOCK_REALTIME );
# Read the POSIX high resolution timer.
my $high = clock_getres(CLOCK_REALTIME);
# But how accurate we can be, really?
my $reso = clock_getres(CLOCK_REALTIME);
use Time::HiRes qw( clock_nanosleep TIMER_ABSTIME );
clock_nanosleep(CLOCK_REALTIME, 1e6);
clock_nanosleep(CLOCK_REALTIME, 2e9, TIMER_ABSTIME);
use Time::HiRes qw( clock );
my $clock0 = clock();
... # Do something.
my $clock1 = clock();
my $clockd = $clock1 - $clock0;
=head1 C API
In addition to the perl API described above, a C API is available for
extension writers. The following C functions are available in the
modglobal hash:
name C prototype
--------------- ----------------------
Time::NVtime double (*)()
Time::U2time void (*)(pTHX_ UV ret[2])
Both functions return equivalent information (like C<gettimeofday>)
but with different representations. The names C<NVtime> and C<U2time>
were selected mainly because they are operating system independent.
(C<gettimeofday> is Unix-centric, though some platforms like Win32 and
VMS have emulations for it.)
Here is an example of using C<NVtime> from C:
double (*myNVtime)(); /* Returns -1 on failure. */
SV **svp = hv_fetch(PL_modglobal, "Time::NVtime", 12, 0);
if (!svp) croak("Time::HiRes is required");
if (!SvIOK(*svp)) croak("Time::NVtime isn't a function pointer");
myNVtime = INT2PTR(double(*)(), SvIV(*svp));
printf("The current time is: %f\n", (*myNVtime)());
=head1 DIAGNOSTICS
=head2 negative time not invented yet
You tried to use a negative time argument.
=head2 internal error: useconds < 0 (unsigned ... signed ...)
Something went horribly wrong-- the number of microseconds that cannot
become negative just became negative. Maybe your compiler is broken?
=head1 CAVEATS
Notice that the core C<time()> maybe rounding rather than truncating.
What this means is that the core C<time()> may be reporting the time
as one second later than C<gettimeofday()> and C<Time::HiRes::time()>.
Adjusting the system clock (either manually or by services like ntp)
may cause problems, especially for long running programs that assume
a monotonously increasing time (note that all platforms do not adjust
time as gracefully as UNIX ntp does). For example in Win32 (and derived
platforms like Cygwin and MinGW) the Time::HiRes::time() may temporarily
drift off from the system clock (and the original time()) by up to 0.5
seconds. Time::HiRes will notice this eventually and recalibrate.
Note that since Time::HiRes 1.77 the clock_gettime(CLOCK_MONOTONIC)
might help in this (in case your system supports CLOCK_MONOTONIC).
=head1 SEE ALSO
Perl modules L<BSD::Resource>, L<Time::TAI64>.
Your system documentation for C<clock_gettime>, C<clock_settime>,
C<gettimeofday>, C<getitimer>, C<setitimer>, C<ualarm>.
=head1 AUTHORS
D. Wegscheid <wegscd at whirlpool.com>
R. Schertler <roderick at argon.org>
J. Hietaniemi <jhi at iki.fi>
G. Aas <gisle at aas.no>
=head1 COPYRIGHT AND LICENSE
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
Copyright (c) 2002, 2003, 2004, 2005 Jarkko Hietaniemi. All rights reserved.
This program is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
--- NEW FILE: Makefile.PL ---
#!/usr/bin/perl
#
# In general we trust %Config, but for nanosleep() this trust
# may be misplaced (it may be linkable but not really functional).
# Use $ENV{FORCE_NANOSLEEP_SCAN} to force rescanning whether there
# really is hope.
require 5.002;
use Config;
use ExtUtils::MakeMaker;
use strict;
my $VERBOSE = $ENV{VERBOSE};
my $DEFINE;
my $LIBS = [];
my $XSOPT = '';
my $SYSCALL_H;
use vars qw($self); # Used in 'sourcing' the hints.
my $ld_exeext = ($^O eq 'cygwin' ||
$^O eq 'os2' && $Config{ldflags} =~ /-Zexe\b/) ? '.exe' : '';
unless($ENV{PERL_CORE}) {
$ENV{PERL_CORE} = 1 if grep { $_ eq 'PERL_CORE=1' } @ARGV;
}
# Perls 5.002 and 5.003 did not have File::Spec, fake what we need.
sub my_dirsep {
$^O eq 'VMS' ? '.' :
$^O =~ /mswin32|netware|djgpp/i ? '\\' :
$^O eq 'MacOS' ? ':'
: '/';
}
sub my_catdir {
shift;
my $catdir = join(my_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 {
shift;
$^O eq 'VMS' ? "-" : "..";
}
BEGIN {
eval { require File::Spec };
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.
# my choice is leave it in and have people with old perls complain
# about the "Usage" bug, or leave it out and be unable to compile myself
# without changing it, and then I'd always forget to change it before a
# release. Sorry, Edward :)
sub try_compile_and_link {
my ($c, %args) = @_;
my ($ok) = 0;
my ($tmp) = "tmp$$";
local(*TMPC);
my $obj_ext = $Config{obj_ext} || ".o";
unlink("$tmp.c", "$tmp$obj_ext");
if (open(TMPC, ">$tmp.c")) {
print TMPC $c;
close(TMPC);
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 hierarchy within
# the Perl core but this should do for now.
$cccmd = "$Config{'cc'} /include=([---]) $tmp.c";
} else {
my $perl_core = $Config{'installarchlib'};
$perl_core =~ s/\]$/.CORE]/;
$cccmd = "$Config{'cc'} /include=(perl_root:[000000],$perl_core) $tmp.c";
}
}
if ($args{silent} || !$VERBOSE) {
$errornull = "2>/dev/null" unless defined $errornull;
} else {
$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
close CMDFILE;
system("\@ $tmp.com");
$ok = $?==0;
for ("$tmp.c", "$tmp$obj_ext", "$tmp.com", "$tmp$Config{exe_ext}") {
1 while unlink $_;
}
}
else
{
my $tmp_exe = "$tmp$ld_exeext";
printf "cccmd = $cccmd\n" if $VERBOSE;
my $res = system($cccmd);
$ok = defined($res) && $res == 0 && -s $tmp_exe && -x _;
if ( $ok && exists $args{run} && $args{run}) {
my $tmp_exe =
File::Spec->catfile(File::Spec->curdir, $tmp_exe);
printf "Running $tmp_exe..." if $VERBOSE;
if (system($tmp_exe) == 0) {
$ok = 1;
} else {
$ok = 0;
my $errno = $? >> 8;
local $! = $errno;
printf <<EOF;
*** The test run of '$tmp_exe' failed: status $?
*** (the status means: errno = $errno or '$!')
*** DO NOT PANIC: this just means that *some* functionality will be missing.
EOF
}
}
unlink("$tmp.c", $tmp_exe);
}
}
return $ok;
}
sub has_gettimeofday {
# confusing but true (if condition true ==> -DHAS_GETTIMEOFDAY already)
return 0 if $Config{d_gettimeod};
return 1 if try_compile_and_link(<<EOM);
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef I_SYS_TYPES
# include <sys/types.h>
#endif
#ifdef I_SYS_TIME
# include <sys/time.h>
#endif
#ifdef I_SYS_SELECT
# include <sys/select.h> /* struct timeval might be hidden in here */
#endif
static int foo()
{
struct timeval tv;
gettimeofday(&tv, 0);
}
int main _((int argc, char** argv, char** env))
{
foo();
}
EOM
return 0;
}
sub has_x {
my ($x, %args) = @_;
return 1 if
try_compile_and_link(<<EOM, %args);
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#ifdef I_UNISTD
# include <unistd.h>
#endif
#ifdef I_SYS_TYPES
# include <sys/types.h>
#endif
#ifdef I_SYS_TIME
# include <sys/time.h>
#endif
int main _((int argc, char** argv, char** env))
{
$x;
}
EOM
return 0;
}
sub has_nanosleep {
print "testing... ";
return 1 if
try_compile_and_link(<<EOM, run => 1);
#include <time.h>
#include <sys/time.h>
#include <stdio.h>
#include <stdlib.h>
#include <errno.h>
/* int nanosleep(const struct timespec *rqtp, struct timespec *rmtp); */
int main() {
struct timespec ts1, ts2;
int ret;
ts1.tv_sec = 0;
ts1.tv_nsec = 750000000;
ts2.tv_sec = 0;
ts2.tv_nsec = 0;
errno = 0;
ret = nanosleep(&ts1, &ts2); /* E.g. in AIX nanosleep() fails and sets errno to ENOSYS. */
ret == 0 ? exit(0) : exit(errno ? errno : -1);
}
EOM
}
sub has_include {
my ($inc) = @_;
return 1 if
try_compile_and_link(<<EOM);
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <$inc>
int main _((int argc, char** argv, char** env))
{
return 0;
}
EOM
return 0;
}
sub has_clock_xxx_syscall {
my $x = shift;
return 0 unless defined $SYSCALL_H;
return 1 if
try_compile_and_link(<<EOM, run => 1);
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include <$SYSCALL_H>
int main _((int argc, char** argv, char** env))
{
struct timespec ts;
/* Many Linuxes get ENOSYS even though the syscall exists. */
/* All implementations are supposed to support CLOCK_REALTIME. */
int ret = syscall(SYS_clock_$x, CLOCK_REALTIME, &ts);
ret == 0 ? exit(0) : exit(errno ? errno : -1);
}
EOM
}
sub has_clock_xxx {
my $xxx = shift;
return 1 if
try_compile_and_link(<<EOM, run => 1);
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int main _((int argc, char** argv, char** env))
{
struct timespec ts;
int ret = clock_$xxx(CLOCK_REALTIME, &ts); /* Many Linuxes get ENOSYS. */
/* All implementations are supposed to support CLOCK_REALTIME. */
ret == 0 ? exit(0) : exit(errno ? errno : -1);
}
EOM
}
sub has_clock {
return 1 if
try_compile_and_link(<<EOM, run => 1);
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int main _((int argc, char** argv, char** env))
{
clock_t tictoc;
clock_t ret = clock();
ret == (clock_t)-1 ? exit(errno ? errno : -1) : exit(0);
}
EOM
}
sub has_clock_nanosleep {
return 1 if
try_compile_and_link(<<EOM, run => 1);
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
int main _((int argc, char** argv, char** env))
{
int ret;
struct timerspec ts1;
struct timerspec ts2;
ts1.tv_sec = 0;
ts1.tv_nsec = 750000000;;
ret = clock_nanosleep(CLOCK_MONOTONIC, 0, &ts1, &ts2);
ret == 0 ? exit(0) : exit(errno ? errno : -1);
}
EOM
}
sub init {
my $hints = File::Spec->catfile("hints", "$^O.pl");
if (-f $hints) {
print "Using hints $hints...\n";
local $self;
do $hints;
if (exists $self->{LIBS}) {
$LIBS = $self->{LIBS};
print "Extra libraries: @$LIBS...\n";
}
}
$DEFINE = '';
if ($Config{d_syscall}) {
print "Have syscall()... looking for syscall.h... ";
if (has_include('syscall.h')) {
$SYSCALL_H = 'syscall.h';
} elsif (has_include('sys/syscall.h')) {
$SYSCALL_H = 'sys/syscall.h';
}
} else {
print "No syscall()...\n";
}
if ($Config{d_syscall}) {
if (defined $SYSCALL_H) {
print "found <$SYSCALL_H>.\n";
} else {
print "NOT found.\n";
}
}
print "Looking for gettimeofday()... ";
my $has_gettimeofday;
if (exists $Config{d_gettimeod}) {
$has_gettimeofday++ if $Config{d_gettimeod};
} elsif (has_gettimeofday()) {
$DEFINE .= ' -DHAS_GETTIMEOFDAY';
$has_gettimeofday++;
}
if ($has_gettimeofday) {
print "found.\n";
} else {
die <<EOD
Your operating system does not seem to have the gettimeofday() function.
(or, at least, I cannot find it)
There is no way Time::HiRes is going to work.
I am awfully sorry but I cannot go further.
Aborting configuration.
EOD
}
print "Looking for setitimer()... ";
my $has_setitimer;
if (exists $Config{d_setitimer}) {
$has_setitimer++ if $Config{d_setitimer};
} elsif (has_x("setitimer(ITIMER_REAL, 0, 0)")) {
$has_setitimer++;
$DEFINE .= ' -DHAS_SETITIMER';
}
if ($has_setitimer) {
print "found.\n";
} else {
print "NOT found.\n";
}
print "Looking for getitimer()... ";
my $has_getitimer;
if (exists $Config{'d_getitimer'}) {
$has_getitimer++ if $Config{'d_getitimer'};
} elsif (has_x("getitimer(ITIMER_REAL, 0)")) {
$has_getitimer++;
$DEFINE .= ' -DHAS_GETITIMER';
}
if ($has_getitimer) {
print "found.\n";
} else {
print "NOT found.\n";
}
if ($has_setitimer && $has_getitimer) {
print "You have interval timers (both setitimer and getitimer).\n";
} else {
print "You do not have interval timers.\n";
}
print "Looking for ualarm()... ";
my $has_ualarm;
if (exists $Config{d_ualarm}) {
$has_ualarm++ if $Config{d_ualarm};
} elsif (has_x ("ualarm (0, 0)")) {
$has_ualarm++;
$DEFINE .= ' -DHAS_UALARM';
}
if ($has_ualarm) {
print "found.\n";
} else {
print "NOT found.\n";
if ($has_setitimer) {
print "But you have setitimer().\n";
print "We can make a Time::HiRes::ualarm().\n";
}
}
print "Looking for usleep()... ";
my $has_usleep;
if (exists $Config{d_usleep}) {
$has_usleep++ if $Config{d_usleep};
} elsif (has_x ("usleep (0)")) {
$has_usleep++;
$DEFINE .= ' -DHAS_USLEEP';
}
if ($has_usleep) {
print "found.\n";
} else {
print "NOT found.\n";
print "Let's see if you have select()... ";
if ($Config{'d_select'}) {
print "found.\n";
print "We can make a Time::HiRes::usleep().\n";
} else {
print "NOT found.\n";
print "You won't have a Time::HiRes::usleep().\n";
}
}
print "Looking for nanosleep()... ";
my $has_nanosleep;
if ($ENV{FORCE_NANOSLEEP_SCAN}) {
print "forced scan... ";
if (has_nanosleep()) {
$has_nanosleep++;
$DEFINE .= ' -DTIME_HIRES_NANOSLEEP';
}
}
elsif (exists $Config{d_nanosleep}) {
print "believing \$Config{d_nanosleep}... ";
if ($Config{d_nanosleep}) {
$has_nanosleep++;
$DEFINE .= ' -DTIME_HIRES_NANOSLEEP';
}
} elsif ($^O =~ /^(mpeix)$/) {
# MPE/iX falsely finds nanosleep from its libc equivalent.
print "skipping because in $^O... ";
} else {
if (has_nanosleep()) {
$has_nanosleep++;
$DEFINE .= ' -DTIME_HIRES_NANOSLEEP';
}
}
if ($has_nanosleep) {
print "found.\n";
print "You can mix subsecond sleeps with signals, if you want to.\n";
print "(It's still not portable, though.)\n";
} else {
print "NOT found.\n";
my $nt = ($^O eq 'os2' ? '' : 'not');
print "You can$nt mix subsecond sleeps with signals.\n";
print "(It would not be portable anyway.)\n";
}
print "Looking for clock_gettime()... ";
my $has_clock_gettime;
if (exists $Config{d_clock_gettime}) {
$has_clock_gettime++ if $Config{d_clock_gettime}; # Unlikely...
} elsif (has_clock_xxx('gettime')) {
$has_clock_gettime++;
$DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME';
} elsif (defined $SYSCALL_H && has_clock_xxx_syscall('gettime')) {
$has_clock_gettime++;
$DEFINE .= ' -DTIME_HIRES_CLOCK_GETTIME -DTIME_HIRES_CLOCK_GETTIME_SYSCALL';
}
if ($has_clock_gettime) {
if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETTIME_SYSCALL/) {
print "found (via syscall).\n";
} else {
print "found.\n";
}
} else {
print "NOT found.\n";
}
print "Looking for clock_getres()... ";
my $has_clock_getres;
if (exists $Config{d_clock_getres}) {
$has_clock_getres++ if $Config{d_clock_getres}; # Unlikely...
} elsif (has_clock_xxx('getres')) {
$has_clock_getres++;
$DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES';
} elsif (defined $SYSCALL_H && has_clock_xxx_syscall('getres')) {
$has_clock_getres++;
$DEFINE .= ' -DTIME_HIRES_CLOCK_GETRES -DTIME_HIRES_CLOCK_GETRES_SYSCALL';
}
if ($has_clock_getres) {
if ($DEFINE =~ /-DTIME_HIRES_CLOCK_GETRES_SYSCALL/) {
print "found (via syscall).\n";
} else {
print "found.\n";
}
} else {
print "NOT found.\n";
}
print "Looking for clock_nanosleep()... ";
my $has_clock_nanosleep;
if (exists $Config{d_clock_nanosleep}) {
$has_clock_nanosleep++ if $Config{d_clock_nanosleep}; # Unlikely...
} elsif (has_clock_nanosleep()) {
$has_clock_nanosleep++;
$DEFINE .= ' -DTIME_HIRES_CLOCK_NANOSLEEP';
}
if ($has_clock_nanosleep) {
print "found.\n";
} else {
print "NOT found.\n";
}
print "Looking for clock()... ";
my $has_clock;
if (exists $Config{d_clock}) {
$has_clock++ if $Config{d_clock}; # Unlikely...
} elsif (has_clock()) {
$has_clock++;
$DEFINE .= ' -DTIME_HIRES_CLOCK';
}
if ($has_clock) {
print "found.\n";
} else {
print "NOT found.\n";
}
my $has_w32api_windows_h;
if ($^O eq 'cygwin') {
print "Looking for <w32api/windows.h>... ";
if (has_include('w32api/windows.h')) {
$has_w32api_windows_h++;
$DEFINE .= ' -DHAS_W32API_WINDOWS_H';
}
if ($has_w32api_windows_h) {
print "found.\n";
} else {
print "NOT found.\n";
}
}
if ($DEFINE) {
$DEFINE =~ s/^\s+//;
if (open(XDEFINE, ">xdefine")) {
print XDEFINE $DEFINE, "\n";
close(XDEFINE);
}
}
}
sub doMakefile {
my @makefileopts = ();
if ($] >= 5.005) {
push (@makefileopts,
'AUTHOR' => 'Jarkko Hietaniemi <jhi at iki.fi>',
'ABSTRACT_FROM' => 'HiRes.pm',
);
$DEFINE .= " -DATLEASTFIVEOHOHFIVE";
}
push (@makefileopts,
'NAME' => 'Time::HiRes',
'VERSION_FROM' => 'HiRes.pm', # finds $VERSION
'LIBS' => $LIBS, # e.g., '-lm'
'DEFINE' => $DEFINE, # e.g., '-DHAS_SOMETHING'
'XSOPT' => $XSOPT,
# Do not even think about 'INC' => '-I/usr/ucbinclude',
# Solaris will avenge.
'INC' => '', # e.g., '-I/usr/include/other'
'INSTALLDIRS' => ($] >= 5.008 ? 'perl' : 'site'),
'dist' => {
'CI' => 'ci -l',
'COMPRESS' => 'gzip -9f',
'SUFFIX' => 'gz',
},
clean => { FILES => "xdefine" },
realclean => { FILES=> 'const-c.inc const-xs.inc' },
);
if ($ENV{PERL_CORE}) {
push @makefileopts, MAN3PODS => {};
}
WriteMakefile(@makefileopts);
}
sub doConstants {
if (eval {require ExtUtils::Constant; 1}) {
my @names = (qw(CLOCK_HIGHRES CLOCK_MONOTONIC
CLOCK_PROCESS_CPUTIME_ID
CLOCK_REALTIME
CLOCK_SOFTTIME
CLOCK_THREAD_CPUTIME_ID
CLOCK_TIMEOFDAY
CLOCKS_PER_SEC
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF
ITIMER_REALPROF
TIMER_ABSTIME));
foreach (qw (d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
d_nanosleep d_clock_gettime d_clock_getres
d_clock d_clock_nanosleep)) {
my $macro = $_;
if ($macro =~ /^(d_nanosleep|d_clock_gettime|d_clock_getres|d_clock|d_clock_nanosleep)$/) {
$macro =~ s/^d_(.+)/TIME_HIRES_\U$1/;
} else {
$macro =~ s/^d_(.+)/HAS_\U$1/;
}
push @names, {name => $_, macro => $macro, value => 1,
default => ["IV", "0"]};
}
ExtUtils::Constant::WriteConstants(
NAME => 'Time::HiRes',
NAMES => \@names,
);
} else {
my $file;
foreach $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 <IN> or die $!;
close OUT or die "Can't close $file: $!";
close IN or die "Can't close $fallback: $!";
}
}
}
sub main {
print "Configuring Time::HiRes...\n";
if ($] == 5.007002) {
die "Cannot Configure Time::HiRes for Perl $], aborting.\n";
}
if ($^O =~ /Win32/i) {
$DEFINE = '-DSELECT_IS_BROKEN';
$LIBS = [];
print "System is $^O, skipping full configure...\n";
} else {
init();
}
doMakefile;
doConstants;
my $make = $Config{'make'} || "make";
unless (exists $ENV{PERL_CORE} && $ENV{PERL_CORE}) {
print <<EOM;
Now you may issue '$make'. Do not forget also '$make test'.
EOM
if ((exists $ENV{LC_ALL} && $ENV{LC_ALL} =~ /utf-?8/i) ||
(exists $ENV{LC_CTYPE} && $ENV{LC_CTYPE} =~ /utf-?8/i) ||
(exists $ENV{LANG} && $ENV{LANG} =~ /utf-?8/i)) {
print <<EOM;
NOTE: if you get an error like this (the Makefile line number may vary):
Makefile:91: *** missing separator
then set the environment variable LC_ALL to "C" and retry
from scratch (re-run perl "Makefile.PL").
EOM
}
}
}
&main;
# EOF
--- NEW FILE: HiRes.xs ---
/*
*
* Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
*
* Copyright (c) 2002,2003,2004,2005 Jarkko Hietaniemi. All rights reserved.
*
* This program is free software; you can redistribute it and/or modify
* it under the same terms as Perl itself.
*/
#ifdef __cplusplus
extern "C" {
#endif
#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "ppport.h"
#if defined(__CYGWIN__) && defined(HAS_W32API_WINDOWS_H)
[...1100 lines suppressed...]
clock()
PREINIT:
clock_t clocks;
CODE:
clocks = clock();
RETVAL = clocks == -1 ? -1 : (NV)clocks / (NV)CLOCKS_PER_SEC;
OUTPUT:
RETVAL
#else /* if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
NV
clock()
CODE:
croak("Time::HiRes::clock(): unimplemented in this platform");
RETVAL = 0.0;
#endif /* #if defined(TIME_HIRES_CLOCK) && defined(CLOCKS_PER_SEC) */
--- NEW FILE: ppport.h ---
#if 0
<<'SKIP';
#endif
/*
----------------------------------------------------------------------
ppport.h -- Perl/Pollution/Portability Version 3.06
Automatically created by Devel::PPPort running under
perl 5.009003 on Fri May 20 22:14:30 2005.
Do NOT edit this file directly! -- Edit PPPort_pm.PL and the
includes in parts/inc/ instead.
Use 'perldoc ppport.h' to view the documentation below.
----------------------------------------------------------------------
SKIP
[...4857 lines suppressed...]
#ifdef NO_XSLOCKS
# ifdef dJMPENV
# define dXCPT dJMPENV; int rEtV = 0
# define XCPT_TRY_START JMPENV_PUSH(rEtV); if (rEtV == 0)
# define XCPT_TRY_END JMPENV_POP;
# define XCPT_CATCH if (rEtV != 0)
# define XCPT_RETHROW JMPENV_JUMP(rEtV)
# else
# define dXCPT Sigjmp_buf oldTOP; int rEtV = 0
# define XCPT_TRY_START Copy(top_env, oldTOP, 1, Sigjmp_buf); rEtV = Sigsetjmp(top_env, 1); if (rEtV == 0)
# define XCPT_TRY_END Copy(oldTOP, top_env, 1, Sigjmp_buf);
# define XCPT_CATCH if (rEtV != 0)
# define XCPT_RETHROW Siglongjmp(top_env, rEtV)
# endif
#endif
#endif /* _P_P_PORTABILITY_H_ */
/* End of File ppport.h */
--- NEW FILE: Changes ---
Revision history for Perl extension Time::HiRes.
1.86 [2005-12-17]
- HiRes.t:s/ok 32/ok 33/, from Dominic Dunlop
- tighten up the clock() test marginally by requiring non-negative
- clock_nanosleep() and clock() doc tweaks
1.85 [2005-12-16]
- the interface to clock_nanosleep() is more natural
when it is like (hires) time() (instead of like nanosleep),
and the .xs implementation of clock_nanosleep() in 1.84
was broken anyway
- the semantics of clock() are not quite so silly as I thought,
but still somewhat odd, documented as such
- additional enhancements to the clock() documentation
- add test for clock_nanosleep() (I cannot test this
since none of my systems have the function)
- add test for clock()
1.84 [2005-12-16]
- add clock() which returns the processor time in
(floating point) seconds since an arbitrary era
- add clock_nanosleep() which suspends the current
thread until either absolute time or for relative time
- [rt.cpan.org #16486] printf missing value in HiRes.t
- add constants CLOCKS_PER_SEC, CLOCK_SOFTTIME, TIMER_ABSTIME
- tiny typo fixes
1.83 [2005-11-19]
- has_symbol() was wrong since e.g. ITIMER_VIRTUAL is exported
via @EXPORT_OK even when it is not available. This is heinous.
@EXPORT_OK should be determined at Makefile.PL time.
- be more lenient is testing clock_gettime(): allow more slop,
and retry up to three times, sleeping a random nap between
the retries
- human months are one-based (noticed by Anton Berezin)
1.82 [2005-10-06]
- CLOCK_REALTIME is an enum value (of the clockid_t enum)
in HP-UX (and might be so elsewhere, too), debugged by
H. Merijn Brand
- include const-c.inc as late as possible (from Randy Kobes,
[rt.cpan.org #15552] to avoid undefined usleep() on Win32
1.81 [2005-11-05]
- try to be more robust and consistent in the detection of
CLOCK_REALTIME and ITIMER_VIRTUAL in HiRes.t: the proper
way is
sub has_symbol {
my $symbol = shift;
eval 'import Time::HiRes qw($symbol)';
return 0 unless $@ eq '';
return exists ${"Time::HiRes::$symbol"};
}
and then use
&FOO_BAR
in the test. All these moves are needed because
1) one cannot directly do eval 'Time::HiRes::FOO_BAR'
because FOO_BAR might have a true value of zero
(or in the general case an empty string or even undef)
2) In case FOO_BAR is not available in this platform,
&FOO_BAR avoids the bareword warning
- wait more (1.5 seconds instead of 0.1) for the CLOCK_REALTIME test
but expect the 'customary' slop of 0.20 instead of 0.25
- fixed inside a comment HAS_POLL -> TIME_HIRES_NANOSLEEP
- at the end of HiRest.t tell how close we were to termination
1.80 [2005-11-04]
- Gisle noticed a mistake (using HAS_NANOSLEEP) in 1.79
1.79 [2005-11-03]
- try nanosleep for emulating usleep -- may help in some weird
embedded realtime places which have nanosleep but neither usleep
nor select nor poll (doesn't have to be weird embedded realtime
place, though -- in many places usleep is nanosleep anyway)
- try poll for emulating usleep -- this may help some obscure/old
SVR4 places that have neither usleep nor select
- a redundant test guard in HiRes.t
1.78 [2005-11-03]
- ITIMER_VIRTUAL detection in HiRes.t had problems (that we cannot
in the general case fail already at 'use' phase is suboptimal)
- fixes to the documentation of clock_gettime() and clock_getres()
1.77 [2005-11-03]
- add support for the POSIX clock_gettime() and clock_getres(),
if available, either as library calls or as syscalls
- be more defensive about missing functionality: break out
early (during 'use') if no e.g. clock_getres() is available,
and protect our back by trapping those cases also in HiRes.xs
- the test added in 1.76 could cause an endless loop e.g. in Solaris,
due to mixing of sleep() and alarm() (bad programmer, no cookie!)
1.76 [2005-10-22]
- testing for nanosleep had wrong logic which caused nanosleep
to become undefined for e.g. Mac OS X
- added a test for a core dump that was introduced by Perl 5.8.0
safe signals and was fixed for the time of 5.8.1 (one report of
the core dump was [perl #20920]), the test skipped pre-5.8.1.
- *cough* s/unanosleep/nanosleep/g; *cough*
1.75 [2005-10-18]
- installation patch from Gisle Aas: in Perls 5.8.x and later
use MakeMaker INSTALLDIRS value of 'perl' instead of 'site'.
1.74 [2005-09-19]
- [cpan #14608] Solaris 8 perl 5.005_03 File::Spec module does not have method rel2abs
(the workaround is not to use rel2abs, should not be necessary)
- [cpan #14642] U2time wrongly exported on the C API
(patch supplied by the reporter, SALVA at cpan.org)
- add release dates to Changes
1.73 [2005-08-16]
- Time::HiRes::nanosleep support for Solaris [PATCH]
(POSIX::uname() not available if building with core perl,
from Gisle Aas, via perl5-porters, perl change #25295)
1.72 [2005-07-01]
- going back to the 1.68 loader setup (using DynaLoader)
since too many weird things starting breaking
- fix a typo in José Auguste-Etienne's name
1.71 [2005-06-28]
- a thinko in the nanosleep() detection
- move more changes stuff from the README to Changes
- add -w to the Makefile.PL
1.70 [2005-06-26]
- oops in 1.69 about @ISA (not affecting anything but silly)
- add copyright 2005 to HiRes.pm
- add copyright and license to HiRes.xs
- add copyrights 2003, 2004, 2005 to README
1.69 [2005-06-25]
- actually run a test for nanosleep
(if there is no $Config{d_nanosleep}) since e.g. in AIX 4.2
it seems that one can link in nanosleep() but then calling
it fails instantly and sets errno to ENOSYS (Not implemented).
This may be fixable in the AIX case by figuring out the right
(realtime POSIX?) libs and whatnot, but in the general case
running a real test case is better. (Of course, this change
will no doubt run into portability problems because of the
execution step...) Note that because of hysterical raisins
most Perls do NOT have $Config{d_nanosleep} (scanning for
it by Configure would in many platforms require linking in
things like -lrt, which would in many platforms be a bad idea
for Perl itself).
(from José Auguste-Etienne)
- support XSLoader also since it's much faster
(from Alexey Tourbin)
- add SEE ALSO (BSD::Resource and Time::TAI64)
1.68 [2005-05-14]
- somehow 1.67 had a lot of doubled lines (a major cut-and-paste
error suspected), but miraculously it still worked since the
doubling took place below the __END__ token
- undef Pause() before defining it to avoid redefinition warnings
during compilation in case perl.h had already defined Pause()
(part of perl change #24271)
- minor doc tweaks
1.67 [2005-05-04]
- (internal) don't ignore the return value of gettimeofday()
- (external) return undef or an empty if the C gettimeofday() fails
(affects Time::HiRes gettimeofday() and the hires time())
1.66 [2004-12-19]
- add nanosleep()
- fix the 'hierachy' typo in Makefile.PL [rt.cpan.org #8492]
- should now build in Solaris [rt.cpan.org #7165] (since 1.64)
- should now build in Cygwin [rt.cpan.org #7535] (since 1.64)
- close also [rt.cpan.org #5933] "Time::HiRes::time does not
pick up time adjustments like ntp" since ever reproducing it
(and therefore verifying a possible fix) in the same environment
has become rather unlikely
1.65 [2004-09-18]
- one should not mix u?alarm and sleep (the tests modified
by 1.65, #12 and #13, hung in Solaris), now we just busy
loop executing an empty block
- in the documentation underline the unspecificity of mixing
sleeps and alarms
- small spelling fixes
1.64 [2004-09-16]
- regenerate ppport.h with Devel::PPPort 3.03,
now the MY_CXT_CLONE is defined in ppport.h,
we no more need to do that.
- the test #12 would often hang in sigsuspend() (at least that's
where Mac OS X' ktrace shows it hanging). With the sleep()s
changed to sleep(1)s, the tests still pass but no hang after
a few hundred repeats.
1.63 [2004-09-01]
- Win32 and any ithread build: ppport.h didn't define
MY_CXT_CLONE, which seems to be a Time-HiRes-ism.
1.62 [2004-08-31]
- Skip testing if under PERL_CORE and Time::HiRes has not
been Configured (from Marcus Holland-Moritz, core change
#23246)
- Use ppport.h generated by Devel::PPPort 3.01,
allowing cutting away our own portability code.
- Don't use $ENV{PERL_CORE} for < 5.6.0.
- Don't use "for my $i" for <= 5.003.
- Don't use Pause() for <= 5.003.
- Can't use newSVpvf for <= 5.003.
(most of the changes from Marcus)
1.61 [2004-08-21]
- Win32: reset reading from the performance counters every
five minutes to better track wall clock time (thanks to
PC timers being often quite bad), should help long-running
programs.
1.60 [2004-08-15]
- Win32: Patch from Steve Hay
[PATCH] Re: [perl #30755] [Win32] Different results from Time::HiRes::gettimeofdayunder the debugger
to [perl #30755] reported by Nigel Sandever
- Cygwin: Use the Win32 recalibration code also in Cygwin if the
<w32api/windows.h> APIs are available. Cygwin testing by
Yitzchak Scott-Thoennes.
- Solaris: use -lposix4 to get nanosleep for Solaris 2.6,
after that keep using -lrt, patch from Alan Burlison,
bug reported in [cpan #7165]
1.59 [2004-04-08]
- Change the Win32 recalibration limit to 0.5 seconds and tweak
the documentation to blather less about the gory details of the
Win32 implementation and more about the complications in general
of meddling with the system clock.
1.58 [2004-04-08]
- Document the 1.57 change better.
1.57 [2004-07-04]
- Win32/Cygwin/MinGW: if the performance counter drifts by more
than two seconds from the system clock (due to ntp adjustments,
for example), recalibrate our internal counter: from Jan Dubois,
based on [cpan #5933] by Jerry D. Hedden.
1.56 [2004-29-02]
- Give a clearer message if the tests timeout (perl change #22253)
- Don't use /tmp or its moral equivalents (perl bug #15036,
perl change #22258)
1.55 [2004-01-14]
- Windows: mingw32 patch from Mike Pomraning (use Perl's Const64()
instead of VC-specific i64 suffix)
1.54 [2003-12-31]
- Solaris: like Tru64 (dec_osf) also Solaris need -lrt for nanosleep
1.53 [2003-12-30]
- Windows: higher resolution time() by using the Windows
performance counter API, from Jan Dubois and Anton Shcherbinin.
The exact new higher resolution depends on the hardware,
but it should be quite a bit better than using the basic
Windows timers.
1.52 [2003-10-28]
- In AIX (v?) with perl 5.6.1 the HiRes.t can hang after
the subtest 18. No known analysis nor fix, but added
an alarm (that requires fork() and alarm()) to the test.
1.51 [2003-09-22]
- doc tweaks from mjd (perl change #20456)
- NCR MP-RAS hints file added (svr4.pl) (perl change #21249)
1.50 [2003-08-02]
- add a message (for non-core builds) to Makefile.PL about
the LC_ALL=C workaround
- &Time::HiRes::d_nanosleep was broken (perl change #20131)
- the nanosleep() probe was broken (perl change #20061)
- use existence instead of definedness for feature probes
(perl change #20043)
- MPE/iX tweak (perl change #20042)
- do not use HAS_NANOSLEEP (perl change #19898)
1.49 [2003-06-23]
- UVuf for non-IVSIZE platforms (from Keiichiro Nagano)
- OS/2 can always mix subsecond sleeps with signals
(part of perl change #19789)
1.48 [2003-06-04]
- workaround for buggy gcc 2.95.3 in openbsd/sparc64
(perl change #19592)
1.47 [2003-05-03]
- do not use -lrt in Linux (from March Lehmann, perl change #19449)
- unnecessary (nanosleep is in libc anyway)
- harmful (-lrt slows down execution)
- incompatible (with many distributions' pthreads)
1.46 [2003-04-25]
- do not create files in blib directories under core
(perl change #19160, from rgs)
- detypo s/VTLARM/VTARLM/ (perl change #19328, from mjd)
1.45 [2003-04-01]
- guarantee that $xdefine in HiRes.t is always defined
(perl change #19109, from IlyaZ)
- a cleaner way to detect PERL_CORE (perl change #19111,
from IlyaZ)
1.44 [2003-03-30]
- add hints/irix.pl to turn off overly POSIX flags that
cause hide struct timespec to be hidden (and compilation
to fail) (bleadperl change #19085)
- documentation tweaks
1.43 [2003-03-11]
- add c:/temp to the list of temp directories to probe
so that cygwin (and win*?) builds are happy. This was
needed at least in my cygwin 1.3.20/w2k setup.
1.42 [2003-01-07]
- modernize the constants code (from Nicholas Clark)
1.41 [2003-01-03]
- 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 this 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 [2003-01-03]
- 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 [2003-10-20]
- fix from Craig Berry for better building in VMS with PERL_CORE
1.38 [2003-10-13]
- no functional changes
- move lib/Time/HiRes.pm as Hires.pm
- libraries scanning was slightly broken (always scanned
for a library even when $Config{libs} already had it)
1.37 [2003-09-23]
- Ray Zimmerman ran into a race condition in Mac OS X.
A 0.01-second alarm fired before the test expected.
The test first slept indefinitely (blocking for signals)
and only after that tested for the signal having been sent.
Since the signal had already been sent, the test #12 never
completed. The solution: test first, then block.
- default to being silent on all probing attempts, set the
environment variable VERBOSE to a true value to see the
details (the probing command and the possible errors)
1.36 [2003-09-12]
- do not clear MAN3PODS in Makefile.PL (Radoslaw Zielinski)
- INSTALLDIRS => 'perl' missing which means that Time::HiRes
cannot be upgraded from CPAN to override the 5.8.0 version
(Guido A. Ostkamp)
- Time::HiRes 1.35 could not be dropped as-is to bleadperl
because the include directories did not adjust themselves
if $ENV{PERL_CORE} (Hugo van der Sanden)
- add documentation about the restart of select() under alarm()
1.35 [2003-08-24]
- small documentation tweaks
1.34 [2003-08-22]
- better VMS operation (Craig Berry)
1.33 [2003-08-20]
- our time machine is accelerating: now works with Perl 5.004_01
(tried with 5.003_07 and 5.002 but I get segmentation faults
from running the Makefile.PL with those in Tru64 4.0D)
1.32 [2003-08-20]
- backward compatibility (pre-5.6.0) tweaks:
- no XSLoader in 5.00503, use DynaLoader instead
- no SvPV_nolen, either
- no PerlProc_pause(), either
- now tested with 5.00404 and 5.00503
- Makefile.PL requires 5.00404 (no more 5.002)
- use nanosleep instead of usleep, if it is available (Wilson Snyder)
(this means that one can mix subsecond sleeps with alarms)
- because of nanosleep we probe for -lrt and -lposix4
- the existence of getitimer/nanosleep/setitimer/ualarm/usleep
is available by exportable constants Time::HiRes::d_func
(since older Perl do not have them in %Config, and even
5.8.0 does not probe for nanosleep)
1.31 [2003-08-19]
- backward compatibility (pre-5.6.1) tweaks:
- define NV if no NVTYPE
- define IVdf if needed (note: the Devel::PPPort
in 5.8.0 does not try hard hard enough since
the IVSIZE might not be defined)
- define NVgf if needed
- grab the typemap from 5.8.0 for the NV stuff
1.31 and 1.32 add more backward compatibility (now all the way
back to Perl 5.00404), and using nanosleep() (if available) for
subsecond sleeps.
1.30 [2003-08-16]
- release 1.29_02 as 1.30
1.30 adds all the changes made during the Perl 5.6->5.7->5.8
development cycle. Most notably portability across platforms has been
enhanced, and the interval timers (setitimer, getitimer) have been
added. Note that the version of Time::HiRes that is included in Perl
5.8.0 calls itself 1.20_00, but it is equivalent to this Time::HiRes
version. Note also that in 1.30 Wegscheid turns over the maintenance
to Jarkko Hietaniemi.
1.29_02 [2003-08-16]
- fix a silly unclosed comment typo in HiRes.xs
- document and export REALTIME_REALPROF (Solaris)
1.29_01 [2003-08-16]
- only getitimer(ITIMER_REAL) available in Cygwin and Win32
(need to patch this also in Perl 5.[89])
- remove CVS revision log from HiRes.xs
1.29_00 [2003-08-14]
The following numbered patches refer to the Perl 5.7 changes,
you can browse them at http://public.activestate.com/cgi-bin/perlbrowse
- 17558: Add #!./perl to the .t
- 17201: linux + usemorebits fix, from Rafael Garcia-Suarez
- 16198: political correctness, from Simon Cozens
- 15857: doc tweaks, from Jarkko Hietaniemi
- 15593: optimization in .xs, from Paul Green
- 14892: pod fixes, from Robin Barker
- 14100: VOS fixes, from Paul Green
- 13422: XS segfault, from Marc Lehmann
- 13378: whether select() gets restarted on signals, depends
- 13354: timing constraints, again, from Andy Dougherty
- 13278: can't do subsecond alarms with ualarm;
break out early if alarms do not seem to be working
- 13266: test relaxation (cygwin gets lower hires
times than lores ones)
- 12846: protect against high load, from Jarkko Hietaniemi
- 12837: HiRes.t VMS tweak, from Craig A. Berry
- 12797: HiRes.t VMS tweak, from Charles Lane
- 12769: HiRes.t VMS tweak, from Craig A. Berry
- 12744: gcc vs MS 64-bit constant syntax, from Nick Ing-Simmons
- 12722: VMS ualarm for VMS without ualarm, from Charles Lane
- 12692: alarm() ain't gonna work if ualarm() ain't,
from Gurusamy Sarathy
- 12680: minor VMS tweak, from Charles Lane
- 12617: don't try to print ints as IVs, from Jarkko Hietaniemi
- 12609: croak on negative time, from Jarkko Hietaniemi
- 12595: Cygwin rounds up for time(), from Jarkko Hietaniemi
- 12594: MacOS Classic timeofday, from Chris Nandor
- 12473: allow for more than one second for sleep() and usleep()
- 12458: test tuning, relax timing constraints,
from Jarkko Hietaniemi
- 12449: make sleep() and usleep() to return the number
of seconds and microseconds actually slept (analogously
with the builtin sleep()), also make usleep() croak if
asked for more than 1_000_000 useconds, from Jarkko Hietaniemi
- 12366: Time::HiRes for VMS pre-7.0, from Charles Lane
- 12199: do not use ftime on Win32, from Gurusamy Sarathy
- 12196: use ftime() on Win32, from Artur Bergman
- 12184: fix Time::HiRes gettimeofday() on Win32, from Gurusamy Sarathy
- 12105: use GetSystemTime() on Win32, from Artur Bergman
- 12060: explain the 1e9 seconds problem, from Jarkko Hietaniemi
- 11901: UNICOS sloppy division, from Jarkko Hietaniemi
- 11797: problem in HiRes.t, from John P. Linderman
- 11414: prototype from Time::HiRes::sleep(), from Abhijit Menon-Sen
- 11409: Time::HiRes qw(sleep) failed, from Abhijit Menon-Sen
- 11270: dynix/ptx 4.5.2 hints fix, from Peter Prymmer
- 11032: VAX VMS s/div/lib\$ediv/ fix, from Peter Prymmer
- 11011: VAX VMS s/qdiv/div/ fix, from Peter Prymmer
- 10953: SCO OpenServer 5.0.5 requires an explicit -lc for usleep(),
from Jonathan Stowe
- 10942: MPE/IX test tweaks, from Mark Bixby
- 10784: unnecessary pod2man calls, from Andy Dougherty
- 10354: ext/ + -Wall, from Doug MacEachern
- 10320: fix the BOOT section to call myU2time correctly
- 10317: correct casting for AIX< from H. Merijn Brand
- 10119: document that the core time() may be rounding, not truncating
- 10118: test fix, from John Peacock
- 9988: long =item, from Robin Barker
- 9714: correct test output
- 9708: test also the scalar aspect of getitimer()
- 9705: Add interval timers (setitimer, getitimer)
- 9692: do not require at least 5.005 using XS
The following changes were made on top of the changes
made for Time::HiRes during the Perl 5.7 development
cycle that culminated in the release of Perl 5.8.0.
- add "require 5.005" to the Makefile.PL
- remove the REVISION section (CVS log) from HiRes.pm
- add jhi's copyright alongside Douglas'
- move HiRes.pm to lib/Time/
- move HiRes.t to t/
- modify HiRes.t to use $ENV{PERL_CORE}
- modify the original Time::HiRes version 1.20 Makefile.PL
to work both with Perl 5.8.0 and the new code with pre-5.8.0
Perls (tried with 5.6.1)
- tiny tweaks and updates in README and TODO
- bump the VERSION to 1.29
1.20 Wed Feb 24 21:30 1999
- make our usleep and ualarm substitutes into hrt_usleep
and hrt_ualarm. This helps static links of Perl with other
packages that also have usleep, etc. From
Ilya Zakharevich <ilya at math.ohio-state.edu>
- add C API stuff. From Joshua Pritikin
<joshua.pritikin at db.com>
- VMS Makefile.PL fun. From pvhp at forte.com (Peter Prymmer)
- hopefully correct "-lc" fix for SCO.
- add PPD stuff
1.20 adds a platform neutral set of C accessible routines if you are
running 5.005+. All other changes are packaging changes and build
fixes(?) for statically linked Perl, SCO, and VMS.
1.19 Tue Sep 29 22:30 1998
- put VMS gettimeofday() in. Patch is from Sebastian Bazley
<seb at stian.demon.co.uk>
- change GIMME_V to GIMME to help people with older versions of
Perl.
- fix Win32 version of gettimeofday(). It didn't affect anything,
but it confuses people reading the code when the return value
is backwards (0 is success).
- fix Makefile.PL (more) so that detection of gettimeofday is
more correct.
1.19 has better VMS support.
1.18 Mon Jul 6 22:40 1998
- add usleep() for Win32.
- fix Makefile.PL to fix reported HP/UX feature where unresolved
externals still cause an executable to be generated (though no
x bit set). Thanks to David Kozinn for report and explanation.
Problems with the fix are mine :)
1.18 has limited Win32 support (no ualarm). Added usleep for Win32.
Probably buggy. I'm sure I'll hear.
1.17 Wed Jul 1 20:10 1998
- fix setitimer calls so microseconds is not more than 1000000.
Hp/UX 9 doesn't like that. Provided by Roland B Robert, PhD.
- make Win32. We only get gettimeofday (the select hack doesn't
seem to work on my Win95 system).
- fix test 4 on 01test.t. add test to see if time() and
Time::HiRes::time() are close.
1.16 Wed Nov 12 21:05 1997
- add missing EXTEND in new gettimeofday scalar code.
1.16+ should be closer to building out of the box on Linux. Thanks
to Gisle Aas for patches, and the ualarm equivalent using setitimer.
If your underlying operating system doesn't implement ualarm(), then
a fake using setitimer() will be made. If the OS is missing usleep(),
a fake one using select() will be made. If a fake can't be made for
either ualarm() or usleep(), then the corresponding Perl function will
not be available. If the OS is missing gettimeofday(), you will get
unresolved externals, either at link- or run-time.
This is an improvement; the package used to not even build if
you were missing any of these bits. Roderick Schertler
<roderick at argon.org> did all the conditional compilation stuff,
look at HiRes.pm and the test suites; it's good educational reading.
1.15 Mon Nov 10 21:30 1997
- HiRes.pm: update pod. Provided by Gisle Aas.
- HiRes.xs: if gettimeofday() called in scalar context, do
something more useful than before. Provided by Gisle Aas.
- README: tell of xsubpp '-nolinenumber' woes. thanks to
Edward Henigin <ed at texas.net> for pointing out the problem.
1.14 Wed Nov 5 9:40 1997
- Makefile.PL: look for setitimer
- HiRes.xs: if missing ualarm, but we have setitimer, make up
our own setitimer. These were provided by Gisle Aas.
1.13 Tue Nov 4 23:30 1997
- Makefile.PL: fix autodetect mechanism to do try linking in addition
to just compiling; should fix Linux build problem. Fix was provided
by Gisle Aas.
1.12 Sun Oct 12 12:00:00 1997
- Makefile.PL: set XSOPT to '-nolinenumbers' to work around xsubpp bug;
you may need to comment this back out if you have an older xsubpp.
- HiRes.xs: set PROTOTYPES: DISABLE
1.11 Fri Sep 05 16:00:00 1997
- Makefile.PL:
Had some line commented out that shouldn't have been (testing
remnants)
- README:
Previous version was corrupted.
1.10 Thu May 22 20:20:00 1997
- HiRes.xs, HiRes.pm, t/*:
- only compile what we have OS support for (or can
fake with select())
- only test what we compiled
- gross improvement to the test suite
- fix EXPORT_FAIL.
This work was all done by Roderick Schertler
<roderick at argon.org>. If you run Linux or
one of the other ualarm-less platforms, and you like this
module, let Roderick know; without him, it still wouldn't
be working on those boxes...
- Makefile.PL: figure out what routines the OS has and
only build what we need. These bits were written by Jarkko
Hietaniemi <jhi at iki.fi>. Again, gratitude is due...
1.02 Mon Dec 30 08:00:00 1996
- HiRes.pm: update documentation to say what to do when missing
ualarm() and friends.
- README: update to warn that ualarm() and friends need to exist
1.01 Fri Oct 17 08:00:00 1996
- Makefile.PL: make XSPROTOARGS => '-noprototyopes'
- HiRes.pm: put blank line between __END__ and =head1 so that
pod2man works.
1.00 Tue Sep 03 13:00:00 1996
- original version; created by h2xs 1.16
--- NEW FILE: typemap ---
# basic C types
int T_IV
unsigned T_UV
unsigned int T_UV
long T_IV
unsigned long T_UV
short T_IV
unsigned short T_UV
char T_CHAR
unsigned char T_U_CHAR
char * T_PV
unsigned char * T_PV
const char * T_PV
caddr_t T_PV
wchar_t * T_PV
wchar_t T_IV
bool_t T_IV
size_t T_UV
ssize_t T_IV
time_t T_NV
unsigned long * T_OPAQUEPTR
char ** T_PACKEDARRAY
void * T_PTR
Time_t * T_PV
SV * T_SV
SVREF T_SVREF
AV * T_AVREF
HV * T_HVREF
CV * T_CVREF
IV T_IV
UV T_UV
NV T_NV
I32 T_IV
I16 T_IV
I8 T_IV
STRLEN T_UV
U32 T_U_LONG
U16 T_U_SHORT
U8 T_UV
Result T_U_CHAR
Boolean T_BOOL
float T_FLOAT
double T_DOUBLE
SysRet T_SYSRET
SysRetLong T_SYSRET
FILE * T_STDIO
PerlIO * T_INOUT
FileHandle T_PTROBJ
InputStream T_IN
InOutStream T_INOUT
OutputStream T_OUT
bool T_BOOL
#############################################################################
INPUT
T_SV
$var = $arg
T_SVREF
if (SvROK($arg))
$var = (SV*)SvRV($arg);
else
Perl_croak(aTHX_ \"$var is not a reference\")
T_AVREF
if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVAV)
$var = (AV*)SvRV($arg);
else
Perl_croak(aTHX_ \"$var is not an array reference\")
T_HVREF
if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVHV)
$var = (HV*)SvRV($arg);
else
Perl_croak(aTHX_ \"$var is not a hash reference\")
T_CVREF
if (SvROK($arg) && SvTYPE(SvRV($arg))==SVt_PVCV)
$var = (CV*)SvRV($arg);
else
Perl_croak(aTHX_ \"$var is not a code reference\")
T_SYSRET
$var NOT IMPLEMENTED
T_UV
$var = ($type)SvUV($arg)
T_IV
$var = ($type)SvIV($arg)
T_INT
$var = (int)SvIV($arg)
T_ENUM
$var = ($type)SvIV($arg)
T_BOOL
$var = (bool)SvTRUE($arg)
T_U_INT
$var = (unsigned int)SvUV($arg)
T_SHORT
$var = (short)SvIV($arg)
T_U_SHORT
$var = (unsigned short)SvUV($arg)
T_LONG
$var = (long)SvIV($arg)
T_U_LONG
$var = (unsigned long)SvUV($arg)
T_CHAR
$var = (char)*SvPV_nolen($arg)
T_U_CHAR
$var = (unsigned char)SvUV($arg)
T_FLOAT
$var = (float)SvNV($arg)
T_NV
$var = ($type)SvNV($arg)
T_DOUBLE
$var = (double)SvNV($arg)
T_PV
$var = ($type)SvPV_nolen($arg)
T_PTR
$var = INT2PTR($type,SvIV($arg))
T_PTRREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"$var is not a reference\")
T_REF_IV_REF
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type *, tmp);
}
else
Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
T_REF_IV_PTR
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type, tmp);
}
else
Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
T_PTROBJ
if (sv_derived_from($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
T_PTRDESC
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
${type}_desc = (\U${type}_DESC\E*) tmp;
$var = ${type}_desc->ptr;
}
else
Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
T_REFREF
if (SvROK($arg)) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"$var is not a reference\")
T_REFOBJ
if (sv_isa($arg, \"${ntype}\")) {
IV tmp = SvIV((SV*)SvRV($arg));
$var = *INT2PTR($type,tmp);
}
else
Perl_croak(aTHX_ \"$var is not of type ${ntype}\")
T_OPAQUE
$var = *($type *)SvPV_nolen($arg)
T_OPAQUEPTR
$var = ($type)SvPV_nolen($arg)
T_PACKED
$var = XS_unpack_$ntype($arg)
T_PACKEDARRAY
$var = XS_unpack_$ntype($arg)
T_CALLBACK
$var = make_perl_cb_$type($arg)
T_ARRAY
U32 ix_$var = $argoff;
$var = $ntype(items -= $argoff);
while (items--) {
DO_ARRAY_ELEM;
ix_$var++;
}
/* this is the number of elements in the array */
ix_$var -= $argoff
T_STDIO
$var = PerlIO_findFILE(IoIFP(sv_2io($arg)))
T_IN
$var = IoIFP(sv_2io($arg))
T_INOUT
$var = IoIFP(sv_2io($arg))
T_OUT
$var = IoOFP(sv_2io($arg))
#############################################################################
OUTPUT
T_SV
$arg = $var;
T_SVREF
$arg = newRV((SV*)$var);
T_AVREF
$arg = newRV((SV*)$var);
T_HVREF
$arg = newRV((SV*)$var);
T_CVREF
$arg = newRV((SV*)$var);
T_IV
sv_setiv($arg, (IV)$var);
T_UV
sv_setuv($arg, (UV)$var);
T_INT
sv_setiv($arg, (IV)$var);
T_SYSRET
if ($var != -1) {
if ($var == 0)
sv_setpvn($arg, "0 but true", 10);
else
sv_setiv($arg, (IV)$var);
}
T_ENUM
sv_setiv($arg, (IV)$var);
T_BOOL
$arg = boolSV($var);
T_U_INT
sv_setuv($arg, (UV)$var);
T_SHORT
sv_setiv($arg, (IV)$var);
T_U_SHORT
sv_setuv($arg, (UV)$var);
T_LONG
sv_setiv($arg, (IV)$var);
T_U_LONG
sv_setuv($arg, (UV)$var);
T_CHAR
sv_setpvn($arg, (char *)&$var, 1);
T_U_CHAR
sv_setuv($arg, (UV)$var);
T_FLOAT
sv_setnv($arg, (double)$var);
T_NV
sv_setnv($arg, (NV)$var);
T_DOUBLE
sv_setnv($arg, (double)$var);
T_PV
sv_setpv((SV*)$arg, $var);
T_PTR
sv_setiv($arg, PTR2IV($var));
T_PTRREF
sv_setref_pv($arg, Nullch, (void*)$var);
T_REF_IV_REF
sv_setref_pv($arg, \"${ntype}\", (void*)new $ntype($var));
T_REF_IV_PTR
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTROBJ
sv_setref_pv($arg, \"${ntype}\", (void*)$var);
T_PTRDESC
sv_setref_pv($arg, \"${ntype}\", (void*)new\U${type}_DESC\E($var));
T_REFREF
NOT_IMPLEMENTED
T_REFOBJ
NOT IMPLEMENTED
T_OPAQUE
sv_setpvn($arg, (char *)&$var, sizeof($var));
T_OPAQUEPTR
sv_setpvn($arg, (char *)$var, sizeof(*$var));
T_PACKED
XS_pack_$ntype($arg, $var);
T_PACKEDARRAY
XS_pack_$ntype($arg, $var, count_$ntype);
T_DATAUNIT
sv_setpvn($arg, $var.chp(), $var.size());
T_CALLBACK
sv_setpvn($arg, $var.context.value().chp(),
$var.context.value().size());
T_ARRAY
{
U32 ix_$var;
EXTEND(SP,size_$var);
for (ix_$var = 0; ix_$var < size_$var; ix_$var++) {
ST(ix_$var) = sv_newmortal();
DO_ARRAY_ELEM
}
}
T_STDIO
{
GV *gv = newGVgen("$Package");
PerlIO *fp = PerlIO_importFILE($var,0);
if ( fp && do_open(gv, "+<&", 3, FALSE, 0, 0, fp) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
T_IN
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "<&", 2, FALSE, 0, 0, $var) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
T_INOUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+<&", 3, FALSE, 0, 0, $var) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
T_OUT
{
GV *gv = newGVgen("$Package");
if ( do_open(gv, "+>&", 3, FALSE, 0, 0, $var) )
sv_setsv($arg, sv_bless(newRV((SV*)gv), gv_stashpv("$Package",1)));
else
$arg = &PL_sv_undef;
}
More information about the dslinux-commit
mailing list