1.1.10 release
git-svn-id: svn://192.168.202.10@1 3d104415-ff17-0410-8863-d5cf3c621b8a
This commit is contained in:
root
@@ -0,0 +1,146 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
### AST_VICI_conf.pl
|
||||
###
|
||||
### Copyright (C) 2006 Matt Florell <vicidial@gmail.com> LICENSE: GPLv2
|
||||
###
|
||||
|
||||
### Customized Variables
|
||||
$SIP_user = 'SIP/cc100'; # your phone id
|
||||
$server_ip = '10.10.10.15'; # Asterisk server IP
|
||||
$DB_server = '10.10.10.15'; # MySQL server IP
|
||||
$DB_database = 'asterisk'; # MySQL database name
|
||||
$DB_user = 'idcheck'; # MySQL user
|
||||
$DB_pass = '1234'; # MySQL pass
|
||||
$DB_port = '3306'; # MySQL connection port
|
||||
|
||||
### Constants
|
||||
$record_channel='';
|
||||
$filename='';
|
||||
$recording_id='';
|
||||
$US = '_';
|
||||
$MT[0] = '';
|
||||
|
||||
return 1;
|
||||
|
||||
|
||||
# this subroutine is to be used with the callerID function to customize the
|
||||
# variables that are passed in the URL string and the way that they are passed,
|
||||
# these are the variables you have to work with:
|
||||
# $callerID_areacode
|
||||
# $callerID_prefix
|
||||
# $callerID_last4
|
||||
# $callerID_Time
|
||||
# $callerID_Channel
|
||||
# $callerID_uniqueID
|
||||
# $callerID_phone_ext
|
||||
# $callerID_server_ip
|
||||
# $callerID_extension
|
||||
# $callerID_inbound_number
|
||||
# $callerID_comment_a
|
||||
# $callerID_comment_b
|
||||
# $callerID_comment_c
|
||||
# $callerID_comment_d
|
||||
# $callerID_comment_e
|
||||
|
||||
sub create_callerID_local_query_string
|
||||
{
|
||||
$local_web_callerID_QUERY_STRING ='';
|
||||
$local_web_callerID_QUERY_STRING.="?callerID_areacode=$callerID_areacode";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_prefix=$callerID_prefix";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_last4=$callerID_last4";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_Time=$callerID_Time";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_Channel=$callerID_Channel";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_uniqueID=$callerID_uniqueID";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_phone_ext=$callerID_phone_ext";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_server_ip=$callerID_server_ip";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_extension=$callerID_extension";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_inbound_number=$callerID_inbound_number";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_a=$callerID_comment_a";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_b=$callerID_comment_b";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_c=$callerID_comment_c";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_d=$callerID_comment_d";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_e=$callerID_comment_e";
|
||||
}
|
||||
|
||||
# $lead_id
|
||||
# $vendor_id
|
||||
# $list_id
|
||||
# $phone_code
|
||||
# $phone_number
|
||||
# $title
|
||||
# $first_name
|
||||
# $middle_initial
|
||||
# $last_name
|
||||
# $address1
|
||||
# $address2
|
||||
# $address3
|
||||
# $city
|
||||
# $state
|
||||
# $province
|
||||
# $postal_code
|
||||
# $country_code
|
||||
# $gender
|
||||
# $date_of_birth
|
||||
# $alt_phone
|
||||
# $email
|
||||
# $security
|
||||
# $comments
|
||||
# $user
|
||||
# $pass
|
||||
# $fronter
|
||||
# $closer
|
||||
# $campaign
|
||||
# $group
|
||||
# $SQLdate
|
||||
# $epoch
|
||||
# $uniqueid
|
||||
# $customer_zap_channel
|
||||
# $server_ip
|
||||
# $SIPexten
|
||||
|
||||
sub create_VICIDIAL_query_string
|
||||
{
|
||||
$VICIDIAL_web_QUERY_STRING ='';
|
||||
$VICIDIAL_web_QUERY_STRING.="?lead_id=$lead_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&vendor_id=$vendor_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&list_id=$list_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&phone_code=$phone_code";
|
||||
$VICIDIAL_web_QUERY_STRING.="&phone_number=$phone_number";
|
||||
$VICIDIAL_web_QUERY_STRING.="&title=$title";
|
||||
$VICIDIAL_web_QUERY_STRING.="&first_name=$first_name";
|
||||
$VICIDIAL_web_QUERY_STRING.="&middle_initial=$middle_initial";
|
||||
$VICIDIAL_web_QUERY_STRING.="&last_name=$last_name";
|
||||
$VICIDIAL_web_QUERY_STRING.="&address1=$address1";
|
||||
$VICIDIAL_web_QUERY_STRING.="&address2=$address2";
|
||||
$VICIDIAL_web_QUERY_STRING.="&address3=$address3";
|
||||
$VICIDIAL_web_QUERY_STRING.="&city=$city";
|
||||
$VICIDIAL_web_QUERY_STRING.="&state=$state";
|
||||
$VICIDIAL_web_QUERY_STRING.="&province=$province";
|
||||
$VICIDIAL_web_QUERY_STRING.="&postal_code=$postal_code";
|
||||
$VICIDIAL_web_QUERY_STRING.="&country_code=$country_code";
|
||||
$VICIDIAL_web_QUERY_STRING.="&gender=$gender";
|
||||
$VICIDIAL_web_QUERY_STRING.="&date_of_birth=$date_of_birth";
|
||||
$VICIDIAL_web_QUERY_STRING.="&alt_phone=$alt_phone";
|
||||
$VICIDIAL_web_QUERY_STRING.="&email=$email";
|
||||
$VICIDIAL_web_QUERY_STRING.="&security=$security";
|
||||
$VICIDIAL_web_QUERY_STRING.="&comments=$comments";
|
||||
$VICIDIAL_web_QUERY_STRING.="&user=$user";
|
||||
$VICIDIAL_web_QUERY_STRING.="&pass=$userpass";
|
||||
$VICIDIAL_web_QUERY_STRING.="&fronter=$fronter";
|
||||
$VICIDIAL_web_QUERY_STRING.="&closer=$user";
|
||||
$VICIDIAL_web_QUERY_STRING.="&campaign=$campaign";
|
||||
$VICIDIAL_web_QUERY_STRING.="&group=$group";
|
||||
$VICIDIAL_web_QUERY_STRING.="&channel_group=$channel_group";
|
||||
$VICIDIAL_web_QUERY_STRING.="&SQLdate=$SQLdate";
|
||||
$VICIDIAL_web_QUERY_STRING.="&epoch=$secX";
|
||||
$VICIDIAL_web_QUERY_STRING.="&uniqueid=$uniqueid";
|
||||
$VICIDIAL_web_QUERY_STRING.="&customer_zap_channel=$customer_zap_channel";
|
||||
$VICIDIAL_web_QUERY_STRING.="&server_ip=$server_ip";
|
||||
$VICIDIAL_web_QUERY_STRING.="&SIPexten=$SIPexten";
|
||||
$VICIDIAL_web_QUERY_STRING.="&session_id=$session_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&phone=$phone_number";
|
||||
$VICIDIAL_web_QUERY_STRING.="&parked_by=$lead_id";
|
||||
$VICIDIAL_web_QUERY_STRING =~ s/ /+/gi;
|
||||
$VICIDIAL_web_QUERY_STRING =~ s/\`|\~|\:|\;|\#|\'|\"|\{|\}|\(|\)|\*|\^|\%|\$|\!|\%|\r|\t|\n//gi;
|
||||
}
|
||||
@@ -0,0 +1,146 @@
|
||||
#!/usr/bin/perl
|
||||
|
||||
### AST_VICI_conf.pl
|
||||
###
|
||||
### Copyright (C) 2006 Matt Florell <vicidial@gmail.com> LICENSE: GPLv2
|
||||
###
|
||||
|
||||
### Customized Variables
|
||||
$SIP_user = 'SIP/cc100'; # your phone id
|
||||
$server_ip = '10.10.10.15'; # Asterisk server IP
|
||||
$DB_server = '10.10.10.15'; # MySQL server IP
|
||||
$DB_database = 'asterisk'; # MySQL database name
|
||||
$DB_user = 'idcheck'; # MySQL user
|
||||
$DB_pass = '1234'; # MySQL pass
|
||||
$DB_port = '3306'; # MySQL connection port
|
||||
|
||||
### Constants
|
||||
$record_channel='';
|
||||
$filename='';
|
||||
$recording_id='';
|
||||
$US = '_';
|
||||
$MT[0] = '';
|
||||
|
||||
return 1;
|
||||
|
||||
|
||||
# this subroutine is to be used with the callerID function to customize the
|
||||
# variables that are passed in the URL string and the way that they are passed,
|
||||
# these are the variables you have to work with:
|
||||
# $callerID_areacode
|
||||
# $callerID_prefix
|
||||
# $callerID_last4
|
||||
# $callerID_Time
|
||||
# $callerID_Channel
|
||||
# $callerID_uniqueID
|
||||
# $callerID_phone_ext
|
||||
# $callerID_server_ip
|
||||
# $callerID_extension
|
||||
# $callerID_inbound_number
|
||||
# $callerID_comment_a
|
||||
# $callerID_comment_b
|
||||
# $callerID_comment_c
|
||||
# $callerID_comment_d
|
||||
# $callerID_comment_e
|
||||
|
||||
sub create_callerID_local_query_string
|
||||
{
|
||||
$local_web_callerID_QUERY_STRING ='';
|
||||
$local_web_callerID_QUERY_STRING.="?callerID_areacode=$callerID_areacode";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_prefix=$callerID_prefix";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_last4=$callerID_last4";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_Time=$callerID_Time";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_Channel=$callerID_Channel";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_uniqueID=$callerID_uniqueID";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_phone_ext=$callerID_phone_ext";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_server_ip=$callerID_server_ip";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_extension=$callerID_extension";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_inbound_number=$callerID_inbound_number";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_a=$callerID_comment_a";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_b=$callerID_comment_b";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_c=$callerID_comment_c";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_d=$callerID_comment_d";
|
||||
$local_web_callerID_QUERY_STRING.="&callerID_comment_e=$callerID_comment_e";
|
||||
}
|
||||
|
||||
# $lead_id
|
||||
# $vendor_id
|
||||
# $list_id
|
||||
# $phone_code
|
||||
# $phone_number
|
||||
# $title
|
||||
# $first_name
|
||||
# $middle_initial
|
||||
# $last_name
|
||||
# $address1
|
||||
# $address2
|
||||
# $address3
|
||||
# $city
|
||||
# $state
|
||||
# $province
|
||||
# $postal_code
|
||||
# $country_code
|
||||
# $gender
|
||||
# $date_of_birth
|
||||
# $alt_phone
|
||||
# $email
|
||||
# $security
|
||||
# $comments
|
||||
# $user
|
||||
# $pass
|
||||
# $fronter
|
||||
# $closer
|
||||
# $campaign
|
||||
# $group
|
||||
# $SQLdate
|
||||
# $epoch
|
||||
# $uniqueid
|
||||
# $customer_zap_channel
|
||||
# $server_ip
|
||||
# $SIPexten
|
||||
|
||||
sub create_VICIDIAL_query_string
|
||||
{
|
||||
$VICIDIAL_web_QUERY_STRING ='';
|
||||
$VICIDIAL_web_QUERY_STRING.="?lead_id=$lead_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&vendor_id=$vendor_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&list_id=$list_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&phone_code=$phone_code";
|
||||
$VICIDIAL_web_QUERY_STRING.="&phone_number=$phone_number";
|
||||
$VICIDIAL_web_QUERY_STRING.="&title=$title";
|
||||
$VICIDIAL_web_QUERY_STRING.="&first_name=$first_name";
|
||||
$VICIDIAL_web_QUERY_STRING.="&middle_initial=$middle_initial";
|
||||
$VICIDIAL_web_QUERY_STRING.="&last_name=$last_name";
|
||||
$VICIDIAL_web_QUERY_STRING.="&address1=$address1";
|
||||
$VICIDIAL_web_QUERY_STRING.="&address2=$address2";
|
||||
$VICIDIAL_web_QUERY_STRING.="&address3=$address3";
|
||||
$VICIDIAL_web_QUERY_STRING.="&city=$city";
|
||||
$VICIDIAL_web_QUERY_STRING.="&state=$state";
|
||||
$VICIDIAL_web_QUERY_STRING.="&province=$province";
|
||||
$VICIDIAL_web_QUERY_STRING.="&postal_code=$postal_code";
|
||||
$VICIDIAL_web_QUERY_STRING.="&country_code=$country_code";
|
||||
$VICIDIAL_web_QUERY_STRING.="&gender=$gender";
|
||||
$VICIDIAL_web_QUERY_STRING.="&date_of_birth=$date_of_birth";
|
||||
$VICIDIAL_web_QUERY_STRING.="&alt_phone=$alt_phone";
|
||||
$VICIDIAL_web_QUERY_STRING.="&email=$email";
|
||||
$VICIDIAL_web_QUERY_STRING.="&security=$security";
|
||||
$VICIDIAL_web_QUERY_STRING.="&comments=$comments";
|
||||
$VICIDIAL_web_QUERY_STRING.="&user=$user";
|
||||
$VICIDIAL_web_QUERY_STRING.="&pass=$userpass";
|
||||
$VICIDIAL_web_QUERY_STRING.="&fronter=$fronter";
|
||||
$VICIDIAL_web_QUERY_STRING.="&closer=$user";
|
||||
$VICIDIAL_web_QUERY_STRING.="&campaign=$campaign";
|
||||
$VICIDIAL_web_QUERY_STRING.="&group=$group";
|
||||
$VICIDIAL_web_QUERY_STRING.="&channel_group=$channel_group";
|
||||
$VICIDIAL_web_QUERY_STRING.="&SQLdate=$SQLdate";
|
||||
$VICIDIAL_web_QUERY_STRING.="&epoch=$secX";
|
||||
$VICIDIAL_web_QUERY_STRING.="&uniqueid=$uniqueid";
|
||||
$VICIDIAL_web_QUERY_STRING.="&customer_zap_channel=$customer_zap_channel";
|
||||
$VICIDIAL_web_QUERY_STRING.="&server_ip=$server_ip";
|
||||
$VICIDIAL_web_QUERY_STRING.="&SIPexten=$SIPexten";
|
||||
$VICIDIAL_web_QUERY_STRING.="&session_id=$session_id";
|
||||
$VICIDIAL_web_QUERY_STRING.="&phone=$phone_number";
|
||||
$VICIDIAL_web_QUERY_STRING.="&parked_by=$lead_id";
|
||||
$VICIDIAL_web_QUERY_STRING =~ s/ /+/gi;
|
||||
$VICIDIAL_web_QUERY_STRING =~ s/\`|\~|\:|\;|\#|\'|\"|\{|\}|\(|\)|\*|\^|\%|\$|\!|\%|\r|\t|\n//gi;
|
||||
}
|
||||
@@ -0,0 +1,14 @@
|
||||
ACT|0200|0399
|
||||
NT|0800|0999
|
||||
NSW|1000|2599
|
||||
ACT|2600|2618
|
||||
NSW|2619|2899
|
||||
ACT|2900|2920
|
||||
NSW|2921|2999
|
||||
VIC|3000|3999
|
||||
QLD|4000|4999
|
||||
SA|5000|5999
|
||||
WA|6000|6999
|
||||
TAS|7000|7999
|
||||
VIC|8000|8999
|
||||
QLD|9000|9999
|
||||
@@ -0,0 +1,20 @@
|
||||
package Asterisk;
|
||||
|
||||
require 5.004;
|
||||
|
||||
$VERSION = '0.08';
|
||||
|
||||
sub version { $VERSION; }
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $self = {};
|
||||
$self->{configfile} = undef;
|
||||
$self->{config} = {};
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,685 @@
|
||||
package Asterisk::AGI;
|
||||
|
||||
require 5.004;
|
||||
|
||||
use Asterisk;
|
||||
|
||||
@ISA = ( 'Asterisk' );
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Asterisk::AGI - Simple Asterisk Gateway Interface Class
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Asterisk::AGI;
|
||||
|
||||
$AGI = new Asterisk::AGI;
|
||||
|
||||
# pull AGI variables into %input
|
||||
|
||||
%input = $AGI->ReadParse();
|
||||
|
||||
# say the number 1984
|
||||
|
||||
$AGI->say_number(1984);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module should make it easier to write scripts that interact with the
|
||||
asterisk open source pbx via AGI (asterisk gateway interface)
|
||||
|
||||
=head1 AGI COMMANDS
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $self = {};
|
||||
$self->{'callback'} = undef;
|
||||
$self->{'status'} = undef;
|
||||
$self->{'lastresponse'} = undef;
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub ReadParse {
|
||||
my ($self, $fh) = @_;
|
||||
|
||||
my %input = ();
|
||||
|
||||
$fh = \*STDIN if (!$fh);
|
||||
|
||||
while (<$fh>) {
|
||||
chomp;
|
||||
last unless length($_);
|
||||
if (/^agi_(\w+)\:\s+(.*)$/) {
|
||||
$input{$1} = $2;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
if (defined($DEBUG)&&($DEBUG>0)) {
|
||||
print STDERR "AGI Environment Dump:\n";
|
||||
foreach $i (sort keys %input) {
|
||||
print STDERR " -- $i = $input{$i}\n";
|
||||
}
|
||||
}
|
||||
|
||||
return %input;
|
||||
}
|
||||
|
||||
sub setcallback {
|
||||
my ($self, $function) = @_;
|
||||
|
||||
if (defined($function) && ref($function) eq 'CODE') {
|
||||
$self->{'callback'} = $function;
|
||||
}
|
||||
}
|
||||
|
||||
sub callback {
|
||||
my ($self, $result) = @_;
|
||||
|
||||
if (defined($self->{'callback'}) && ref($self->{'callback'}) eq 'CODE') {
|
||||
&{$self->{'callback'}}($result);
|
||||
}
|
||||
}
|
||||
|
||||
sub execute {
|
||||
my ($self, $command) = @_;
|
||||
|
||||
$self->_execcommand($command);
|
||||
my $res = $self->_readresponse();
|
||||
|
||||
return $self->_checkresult($res);
|
||||
}
|
||||
|
||||
sub _execcommand {
|
||||
my ($self, $command, $fh) = @_;
|
||||
|
||||
$fh = \*STDOUT if (!$fh);
|
||||
|
||||
select ((select ($fh), $| = 1)[0]);
|
||||
|
||||
return -1 if (!defined($command));
|
||||
|
||||
return print $fh "$command\n";
|
||||
}
|
||||
|
||||
sub _readresponse {
|
||||
my ($self, $fh) = @_;
|
||||
|
||||
my $response = undef;
|
||||
$fh = \*STDIN if (!$fh);
|
||||
$response = <$fh> || return '200 result=-1 (noresponse)';
|
||||
chomp($response);
|
||||
return $response;
|
||||
}
|
||||
|
||||
sub _checkresult {
|
||||
my ($self, $response) = @_;
|
||||
|
||||
return undef if (!defined($response));
|
||||
my $result = undef;
|
||||
|
||||
$self->_lastresponse($response);
|
||||
if ($response =~ /^200/) {
|
||||
if ($response =~ /result=(-?[\d*#]+)/) {
|
||||
$result = $1;
|
||||
}
|
||||
} elsif ($response =~ /\(noresponse\)/) {
|
||||
$self->_status('noresponse');
|
||||
} else {
|
||||
print STDERR "Unexpected result '$response'\n" if (defined($DEBUG) && $DEBUG);
|
||||
}
|
||||
print STDERR "_checkresult($response) = $result\n" if (defined($DEBUG) && $DEBUG>3);
|
||||
|
||||
return $result;
|
||||
}
|
||||
|
||||
sub _status {
|
||||
my ($self, $status) = @_;
|
||||
|
||||
if (defined($status)) {
|
||||
$self->{'status'} = $status;
|
||||
} else {
|
||||
return $self->{'status'};
|
||||
}
|
||||
}
|
||||
|
||||
sub _lastresponse {
|
||||
my ($self, $response) = @_;
|
||||
|
||||
if (defined($response)) {
|
||||
$self->{'lastresponse'} = $response;
|
||||
} else {
|
||||
return $self->{'lastresponse'};
|
||||
}
|
||||
}
|
||||
|
||||
=over 4
|
||||
|
||||
=item $AGI->stream_file($filename, $digits)
|
||||
|
||||
Executes AGI Command "STREAM FILE $filename $digits"
|
||||
|
||||
This command instructs Asterisk to play the given sound file and listen for the given dtmf digits. The
|
||||
fileextension must not be used in the filename because Asterisk will find the most appropriate file
|
||||
type.
|
||||
|
||||
Example: $AGI->stream_file('demo-echotest', '0123');
|
||||
|
||||
Returns: -1 on error or hangup,
|
||||
0 if playback completes without a digit being pressed,
|
||||
or the ASCII numerical value of the digit if a digit was pressed
|
||||
|
||||
=cut
|
||||
|
||||
sub stream_file {
|
||||
my ($self, $filename, $digits) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
|
||||
$digits = '""' if (!defined($digits));
|
||||
|
||||
return -1 if (!defined($filename));
|
||||
$ret = $self->execute("STREAM FILE $filename $digits");
|
||||
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $AGI->send_text($text)
|
||||
|
||||
Executes AGI Command "SEND TEXT "$text"
|
||||
|
||||
Sends the given text on a channel. Most channels do not support the transmission of text.
|
||||
|
||||
Example: $AGI->send_text('You've got mail!');
|
||||
|
||||
Returns: -1 on error or hangup,
|
||||
0 if the text was sent or if the channel does not support text transmission.
|
||||
|
||||
=cut
|
||||
|
||||
sub send_text {
|
||||
my ($self, $text) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
|
||||
return $ret if (!defined($text));
|
||||
$ret = $self->execute("SEND TEXT \"$text\"");
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $AGI->send_image($image)
|
||||
|
||||
Executes AGI Command "SEND IMAGE $image
|
||||
|
||||
Sends the given image on a channel. Most channels do not support the transmission of images.
|
||||
|
||||
Example: $AGI->send_image('image.png');
|
||||
|
||||
Returns: -1 on error or hangup,
|
||||
0 if the image was sent or if the channel does not support image transmission.
|
||||
|
||||
=cut
|
||||
|
||||
sub send_image {
|
||||
my ($self, $image) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
return -1 if (!defined($image));
|
||||
|
||||
$ret = $self->execute("SEND IMAGE $image");
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $AGI->say_number($number, $digits)
|
||||
|
||||
Executes AGI Command "SAY NUMBER $number $digits"
|
||||
|
||||
Says the given $number, returning early if any of the $digits are received.
|
||||
|
||||
Example: $AGI->say_number('98765');
|
||||
|
||||
Returns: -1 on error or hangup,
|
||||
0 if playback completes without a digit being pressed,
|
||||
or the ASCII numerical value of the digit of one was pressed.
|
||||
|
||||
=cut
|
||||
|
||||
sub say_number {
|
||||
my ($self, $number, $digits) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
|
||||
$digits = '""' if (!defined($digits));
|
||||
|
||||
return -1 if (!defined($number));
|
||||
$number =~ s/\D//g;
|
||||
$ret = $self->execute("SAY NUMBER $number $digits");
|
||||
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $AGI->say_digits($number, $digits)
|
||||
|
||||
Executes AGI Command "SAY DIGITS $number $digits"
|
||||
|
||||
Says the given digit string $number, returning early if any of the $digits are received.
|
||||
|
||||
Example: $AGI->say_digits('8675309');
|
||||
|
||||
Returns: -1 on error or hangup,
|
||||
0 if playback completes without a digit being pressed,
|
||||
or the ASCII numerical value of the digit of one was pressed.
|
||||
|
||||
=cut
|
||||
|
||||
sub say_digits {
|
||||
my ($self, $number, $digits) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
$digits = '""' if (!defined($digits));
|
||||
|
||||
return -1 if (!defined($number));
|
||||
$number =~ s/\D//g;
|
||||
$ret = $self->execute("SAY DIGITS $number $digits");
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $AGI->answer()
|
||||
|
||||
Executes AGI Command "ANSWER"
|
||||
|
||||
Answers channel if not already in answer state
|
||||
|
||||
Example: $AGI->answer();
|
||||
|
||||
Returns: -1 on channel failure, or
|
||||
0 if successful
|
||||
|
||||
=cut
|
||||
|
||||
sub answer {
|
||||
my ($self) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
$ret = $self->execute('ANSWER');
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
|
||||
}
|
||||
|
||||
=item $AGI->get_data($filename, $timeout, $maxdigits)
|
||||
|
||||
Executes AGI Command "GET DATA $filename $timeout $maxdigits"
|
||||
|
||||
Streams $filename and returns when $maxdigits have been received or
|
||||
when $timeout has been reached. Timeout is specified in ms
|
||||
|
||||
Example: $AGI->get_data('demo-welcome', 15000, 5);
|
||||
|
||||
=cut
|
||||
|
||||
sub get_data {
|
||||
my ($self, $filename, $timeout, $maxdigits) = @_;
|
||||
|
||||
my $ret = undef;
|
||||
|
||||
return -1 if (!defined($filename));
|
||||
$ret = $self->execute("GET DATA $filename $timeout $maxdigits");
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
=item $AGI->set_callerid($number)
|
||||
|
||||
Executes AGI Command "SET CALLERID $number"
|
||||
|
||||
Changes the callerid of the current channel to <number>
|
||||
|
||||
Example: $AGI->set_callerid('9995551212');
|
||||
|
||||
Returns: Always returns 1
|
||||
|
||||
=cut
|
||||
|
||||
sub set_callerid {
|
||||
my ($self, $number) = @_;
|
||||
|
||||
return if (!defined($number));
|
||||
return $self->execute("SET CALLERID $number");
|
||||
}
|
||||
|
||||
=item $AGI->set_context($context)
|
||||
|
||||
Executes AGI Command "SET CONTEXT $context"
|
||||
|
||||
Changes the context for continuation upon exiting the agi application
|
||||
|
||||
Example: $AGI->set_context('dialout');
|
||||
|
||||
Returns: Always returns 0
|
||||
|
||||
=cut
|
||||
|
||||
sub set_context {
|
||||
my ($self, $context) = @_;
|
||||
|
||||
return -1 if (!defined($context));
|
||||
return $self->execute("SET CONTEXT $context");
|
||||
}
|
||||
|
||||
=item $AGI->set_extension($extension)
|
||||
|
||||
Executes AGI Command "SET EXTENSION $extension"
|
||||
|
||||
Changes the extension for continuation upon exiting the agi application
|
||||
|
||||
Example: $AGI->set_extension('7');
|
||||
|
||||
Returns: Always returns 0
|
||||
|
||||
=cut
|
||||
|
||||
sub set_extension {
|
||||
my ($self, $extension) = @_;
|
||||
|
||||
return -1 if (!defined($extension));
|
||||
return $self->execute("SET EXTENSION $extension");
|
||||
}
|
||||
|
||||
=item $AGI->set_priority($priority)
|
||||
|
||||
Executes AGI Command "SET PRIORITY $priority"
|
||||
|
||||
Changes the priority for continuation upon exiting the agi application
|
||||
|
||||
Example: $AGI->set_priority(1);
|
||||
|
||||
Returns: Always returns 0
|
||||
|
||||
=cut
|
||||
|
||||
sub set_priority {
|
||||
my ($self, $priority) = @_;
|
||||
|
||||
return -1 if (!defined($priority));
|
||||
return $self->execute("SET PRIORITY $priority");
|
||||
}
|
||||
|
||||
sub receive_char {
|
||||
my ($self, $timeout) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
#wait forever if timeout is not set. is this the prefered default?
|
||||
$timeout = 0 if (!defined($timeout));
|
||||
$ret = $self->execute("RECEIVE CHAR $timeout");
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
|
||||
}
|
||||
|
||||
sub tdd_mode {
|
||||
my ($self, $mode) = @_;
|
||||
|
||||
return 0 if (!defined($mode));
|
||||
return $self->execute("TDD MODE $mode");
|
||||
}
|
||||
|
||||
|
||||
sub wait_for_digit {
|
||||
my ($self, $timeout) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
$timeout = -1 if (!defined($timeout));
|
||||
$ret = $self->execute("WAIT FOR DIGIT $timeout");
|
||||
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub record_file {
|
||||
my ($self, $filename, $format, $digits, $timeout, $beep) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
|
||||
return -1 if (!defined($filename));
|
||||
$digits = '""' if (!defined($digits));
|
||||
$ret = $self->execute("RECORD FILE $filename $format $digits $timeout");
|
||||
|
||||
$self->callback($ret) if ($ret == -1);
|
||||
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub set_autohangup {
|
||||
my ($self, $time) = @_;
|
||||
|
||||
$time = 0 if (!defined($time));
|
||||
return $self->execute("SET AUTOHANGUP $time");
|
||||
}
|
||||
|
||||
=item $AGI->hangup($channel)
|
||||
|
||||
Executes AGI Command "HANGUP $channel"
|
||||
|
||||
Hangs up the passed $channel, or the current channel if $channel is not passed.
|
||||
It is left to the AGI script to exit properly, otherwise you could end up with zombies.
|
||||
|
||||
Example: $AGI->hangup();
|
||||
|
||||
Returns: Always returns 1
|
||||
|
||||
=cut
|
||||
|
||||
sub hangup {
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
if ($channel) {
|
||||
return $self->execute("HANGUP $channel");
|
||||
} else {
|
||||
return $self->execute("HANGUP");
|
||||
}
|
||||
}
|
||||
|
||||
=item $AGI->exec($app, $options)
|
||||
|
||||
Executes AGI Command "EXEC $app $options"
|
||||
|
||||
The most powerful AGI command. Executes the given application passing the given options.
|
||||
|
||||
Example: $AGI->exec('Dial', 'Zap/g2/8005551212');
|
||||
|
||||
Returns: -2 on failure to find application, or
|
||||
whatever the given application returns
|
||||
|
||||
=cut
|
||||
|
||||
sub exec {
|
||||
my ($self, $app, $options) = @_;
|
||||
return -1 if (!defined($app));
|
||||
$options = '""' if (!defined($options));
|
||||
return $self->execute("EXEC $app $options");
|
||||
}
|
||||
|
||||
sub channel_status {
|
||||
my ($self, $channel) = @_;
|
||||
|
||||
return $self->execute("CHANNEL STATUS $channel");
|
||||
}
|
||||
|
||||
=item $AGI->set_variable($variable, $value)
|
||||
|
||||
Executes AGI Command "SET VARIABLE $variable $value"
|
||||
|
||||
Sets the channel variable <variablename> to <value>
|
||||
|
||||
Example: $AGI->set_variable('status', 'authorized');
|
||||
|
||||
Returns: Always returns 1
|
||||
|
||||
=cut
|
||||
|
||||
sub set_variable {
|
||||
my ($self, $variable, $value) = @_;
|
||||
|
||||
return $self->execute("SET VARIABLE $variable $value");
|
||||
}
|
||||
|
||||
=item $AGI->get_variable($variable)
|
||||
|
||||
Executes AGI Command "GET VARIABLE $variablename"
|
||||
|
||||
Gets the channel variable <variablename>
|
||||
|
||||
Example: $AGI->get_variable('status');
|
||||
|
||||
Returns: The value of the variable, or undef if variable does not exist
|
||||
|
||||
=cut
|
||||
|
||||
sub get_variable {
|
||||
my ($self, $variable) = @_;
|
||||
|
||||
my $result = undef;
|
||||
|
||||
if ($self->execute("GET VARIABLE $variable")) {
|
||||
my $tempresult = $self->_lastresponse();
|
||||
if ($tempresult =~ /\((.*)\)/) {
|
||||
$result = $1;
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
=item $AGI->verbose($message, $level)
|
||||
|
||||
Executes AGI Command "VERBOSE $message $level"
|
||||
|
||||
Logs $message with verboselevel $level
|
||||
|
||||
Example: $AGI->verbose("System Crashed\n", 1);
|
||||
|
||||
Returns: Always returns 1
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
sub verbose {
|
||||
my ($self, $message, $level) = @_;
|
||||
|
||||
return $self->execute("VERBOSE \"$message\" $level");
|
||||
}
|
||||
|
||||
=item $AGI->database_get($family, $key)
|
||||
|
||||
Executes AGI Command "DATABASE GET $family $key"
|
||||
|
||||
Example: $var = $AGI->database_get('test', 'status');
|
||||
|
||||
Returns: The value of the variable, or undef if variable does not exist
|
||||
|
||||
=cut
|
||||
|
||||
sub database_get {
|
||||
my ($self, $family, $key) = @_;
|
||||
|
||||
my $result = undef;
|
||||
|
||||
if ($self->execute("DATABASE GET $family $key")) {
|
||||
my $tempresult = $self->_lastresponse();
|
||||
if ($tempresult =~ /\((.*)\)/) {
|
||||
$result = $1;
|
||||
}
|
||||
}
|
||||
return $result;
|
||||
}
|
||||
|
||||
=item $AGI->database_put($family, $key, $value)
|
||||
|
||||
Executes AGI Command "DATABASE PUT $family $key $value"
|
||||
|
||||
Set/modifes database entry <family>/<key> to <value>
|
||||
|
||||
Example: $AGI->database_put('test', 'status', 'authorized');
|
||||
|
||||
Returns: 1 on success, 0 otherwise
|
||||
|
||||
=cut
|
||||
|
||||
sub database_put {
|
||||
my ($self, $family, $key, $value) = @_;
|
||||
|
||||
return $self->execute("DATABASE PUT $family $key $value");
|
||||
}
|
||||
|
||||
=item $AGI->database_del($family, $key)
|
||||
|
||||
Executes AGI Command "DATABASE DEL $family $key"
|
||||
|
||||
Removes database entry <family>/<key>
|
||||
|
||||
Example: $AGI->database_del('test', 'status');
|
||||
|
||||
Returns: 1 on success, 0 otherwise
|
||||
|
||||
=cut
|
||||
|
||||
sub database_del {
|
||||
my ($self, $family, $key) = @_;
|
||||
|
||||
return $self->execute("DATABASE DEL $family $key");
|
||||
}
|
||||
|
||||
=item $AGI->database_deltree($family, $key)
|
||||
|
||||
Executes AGI Command "DATABASE DELTREE $family $key"
|
||||
|
||||
Deletes a family or specific keytree within a family in the Asterisk database
|
||||
|
||||
Example: $AGI->database_deltree('test', 'status');
|
||||
Example: $AGI->database_deltree('test');
|
||||
|
||||
Returns: 1 on success, 0 otherwise
|
||||
|
||||
=cut
|
||||
|
||||
sub database_deltree {
|
||||
my ($self, $family, $key) = @_;
|
||||
|
||||
return $self->execute("DATABASE DELTREE $family $key");
|
||||
}
|
||||
|
||||
sub noop {
|
||||
my ($self) = @_;
|
||||
|
||||
return $self->execute("NOOP");
|
||||
}
|
||||
|
||||
sub set_music {
|
||||
my ($self, $mode, $class) = @_;
|
||||
|
||||
return $self->execute("SET MUSIC $mode $class");
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=back
|
||||
@@ -0,0 +1,412 @@
|
||||
package Asterisk::Manager;
|
||||
|
||||
require 5.004;
|
||||
|
||||
use Asterisk;
|
||||
use IO::Socket;
|
||||
use Digest::MD5;
|
||||
|
||||
#use strict;
|
||||
#use warnings;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Asterisk::Manager - Asterisk Manager Interface
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Asterisk::Manager;
|
||||
|
||||
my $astman = new Asterisk::Manager;
|
||||
|
||||
$astman->user('username');
|
||||
|
||||
$astman->secret('test');
|
||||
|
||||
$astman->host('localhost');
|
||||
|
||||
$astman->connect || die "Could not connect to " . $astman->host . "!\n";
|
||||
|
||||
$astman->disconnect;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides a simple interface to the asterisk manager interface.
|
||||
|
||||
=cut
|
||||
|
||||
my $EOL = "\r\n";
|
||||
my $BLANK = $EOL x 2;
|
||||
|
||||
my $VERSION = '0.01';
|
||||
|
||||
sub version { $VERSION; }
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
|
||||
my $self = {};
|
||||
$self->{_CONNFD} = undef;
|
||||
$self->{_PROTOVERS} = undef;
|
||||
$self->{_ERRORSTR} = undef;
|
||||
$self->{_HOST} = 'localhost';
|
||||
$self->{_PORT} = 5038;
|
||||
$self->{_USER} = undef;
|
||||
$self->{_SECRET} = undef;
|
||||
$self->{_EVENTCB} = {};
|
||||
$self->{_DEBUG} = 0;
|
||||
$self->{_CONNECTED} = 0;
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
sub user {
|
||||
my ($self, $user) = @_;
|
||||
|
||||
if ($user) {
|
||||
$self->{_USER} = $user;
|
||||
}
|
||||
|
||||
return $self->{_USER};
|
||||
}
|
||||
|
||||
sub secret {
|
||||
my ($self, $secret) = @_;
|
||||
|
||||
if ($secret) {
|
||||
$self->{_SECRET} = $secret;
|
||||
}
|
||||
|
||||
return $self->{_SECRET};
|
||||
}
|
||||
|
||||
sub host {
|
||||
my ($self, $host) = @_;
|
||||
|
||||
if ($host) {
|
||||
$self->{_HOST} = $host;
|
||||
}
|
||||
|
||||
return $self->{_HOST};
|
||||
}
|
||||
|
||||
sub port {
|
||||
my ($self, $port) = @_;
|
||||
|
||||
if ($port) {
|
||||
$self->{_PORT} = $port;
|
||||
}
|
||||
|
||||
return $self->{_PORT};
|
||||
}
|
||||
|
||||
sub connected {
|
||||
my ($self, $connected) = @_;
|
||||
|
||||
if (defined($connected)) {
|
||||
$self->{_CONNECTED} = $connected;
|
||||
}
|
||||
|
||||
return $self->{_CONNECTED};
|
||||
}
|
||||
|
||||
sub error {
|
||||
my ($self, $error) = @_;
|
||||
|
||||
if ($error) {
|
||||
$self->{_ERRORSTR} = $error;
|
||||
}
|
||||
|
||||
return $self->{_ERRORSTR};
|
||||
}
|
||||
|
||||
sub debug {
|
||||
my ($self, $debug) = @_;
|
||||
|
||||
if ($debug) {
|
||||
$self->{_DEBUG} = $debug;
|
||||
}
|
||||
|
||||
return $self->{_DEBUG};
|
||||
}
|
||||
|
||||
sub connfd {
|
||||
my ($self, $connfd) = @_;
|
||||
|
||||
if ($connfd) {
|
||||
$self->{_CONNFD} = $connfd;
|
||||
}
|
||||
|
||||
return $self->{_CONNFD};
|
||||
}
|
||||
|
||||
sub read_response {
|
||||
my ($self, $connfd) = @_;
|
||||
|
||||
my @response;
|
||||
|
||||
if (!$connfd) {
|
||||
$connfd = $self->connfd;
|
||||
}
|
||||
|
||||
while (my $line = <$connfd>) {
|
||||
last if ($line eq $EOL);
|
||||
|
||||
if (wantarray) {
|
||||
$line =~ s/$EOL//g;
|
||||
push(@response, $line) if $line;
|
||||
} else {
|
||||
$response[0] .= $line;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
return wantarray ? @response : $response[0];
|
||||
}
|
||||
|
||||
sub connect {
|
||||
my ($self) = @_;
|
||||
|
||||
my $host = $self->host;
|
||||
my $port = $self->port;
|
||||
my $user = $self->user;
|
||||
my $secret = $self->secret;
|
||||
my %resp;
|
||||
|
||||
my $conn = new IO::Socket::INET( Proto => 'tcp',
|
||||
PeerAddr => $host,
|
||||
PeerPort => $port
|
||||
);
|
||||
if (!$conn) {
|
||||
$self->error("Connection refused ($host:$port)\n");
|
||||
return undef;
|
||||
}
|
||||
|
||||
$conn->autoflush(1);
|
||||
|
||||
my $input = <$conn>;
|
||||
$input =~ s/$EOL//g;
|
||||
|
||||
my ($manager, $version) = split('/', $input);
|
||||
|
||||
if ($manager !~ /Asterisk Call Manager/) {
|
||||
return $self->error("Unknown Protocol\n");
|
||||
}
|
||||
|
||||
$self->{_PROTOVERS} = $version;
|
||||
$self->connfd($conn);
|
||||
|
||||
# check if the remote host supports MD5 Challenge authentication
|
||||
my %authresp = $self->sendcommand( Action => 'Challenge',
|
||||
AuthType => 'MD5'
|
||||
);
|
||||
|
||||
if (($authresp{Response} eq 'Success')) {
|
||||
# do md5 login
|
||||
my $md5 = new Digest::MD5;
|
||||
$md5->add($authresp{Challenge});
|
||||
$md5->add($secret);
|
||||
my $digest = $md5->hexdigest;
|
||||
%resp = $self->sendcommand( Action => 'Login',
|
||||
AuthType => 'MD5',
|
||||
Username => $user,
|
||||
Key => $digest
|
||||
);
|
||||
} else {
|
||||
# do plain text login
|
||||
%resp = $self->sendcommand( Action => 'Login',
|
||||
Username => $user,
|
||||
Secret => $secret
|
||||
);
|
||||
|
||||
}
|
||||
|
||||
if ( ($resp{Response} ne 'Success') && ($resp{Message} ne 'Authentication accepted') ) {
|
||||
$self->error("Authentication failed for user $user\n");
|
||||
return undef;
|
||||
}
|
||||
|
||||
$self->connected(1);
|
||||
|
||||
return $conn;
|
||||
}
|
||||
|
||||
sub astman_h2s {
|
||||
my ($self, %thash) = @_;
|
||||
|
||||
my $tstring = '';
|
||||
|
||||
foreach my $key (keys %thash) {
|
||||
$tstring .= $key . ': ' . $thash{$key} . ${EOL};
|
||||
}
|
||||
|
||||
return $tstring;
|
||||
}
|
||||
|
||||
sub astman_s2h {
|
||||
my ($self, $tstring) = @_;
|
||||
|
||||
my %thash;
|
||||
|
||||
foreach my $line (split(/$EOL/, $tstring)) {
|
||||
if ($line =~ /(\w*):\s*(\w*)/) {
|
||||
$thash{$1} = $2;
|
||||
}
|
||||
}
|
||||
|
||||
return %thash;
|
||||
}
|
||||
|
||||
#$want is how you want the data returned
|
||||
#$want = 0 (default) returns the results in a hash
|
||||
#$want = 1 returns the results in a large string
|
||||
#$want = 2 returns the results in an array
|
||||
sub sendcommand {
|
||||
my ($self, %command, $want) = @_;
|
||||
|
||||
if (!defined($want)) {
|
||||
$want = 0;
|
||||
}
|
||||
|
||||
my $conn = $self->connfd || return;
|
||||
my $cstring = $self->astman_h2s(%command);
|
||||
|
||||
$conn->send("$cstring$EOL");
|
||||
|
||||
if ($want == 1) {
|
||||
my $response = $self->read_response($conn);
|
||||
return $response;
|
||||
}
|
||||
|
||||
my @resp = $self->read_response($conn);
|
||||
|
||||
if ($want == 2) {
|
||||
return @resp;
|
||||
} else {
|
||||
return map { split(': ', $_) } @resp;
|
||||
}
|
||||
}
|
||||
|
||||
sub setcallback {
|
||||
my ($self, $event, $function) = @_;
|
||||
|
||||
if (defined($function) && ref($function) eq 'CODE') {
|
||||
$self->{_EVENTCB}{$event} = $function;
|
||||
}
|
||||
}
|
||||
|
||||
sub eventcallback {
|
||||
my ($self, %resp) = @_;
|
||||
|
||||
my $callback;
|
||||
my $event = $resp{Event};
|
||||
|
||||
return if (!$event);
|
||||
|
||||
if (defined($self->{_EVENTCB}{$event})) {
|
||||
$callback = $self->{_EVENTCB}{$event};
|
||||
} elsif (defined($self->{_EVENTCB}{DEFAULT})) {
|
||||
$callback = $self->{_EVENTCB}{DEFAULT};
|
||||
} else {
|
||||
return;
|
||||
}
|
||||
|
||||
return &{$callback}(%resp);
|
||||
}
|
||||
|
||||
sub eventloop {
|
||||
my ($self) = @_;
|
||||
|
||||
while (1) {
|
||||
$self->handleevent;
|
||||
}
|
||||
}
|
||||
|
||||
sub handleevent {
|
||||
my ($self) = @_;
|
||||
|
||||
my %resp = map { split(': ', $_); } $self->read_response;
|
||||
$self->eventcallback(%resp);
|
||||
|
||||
return %resp;
|
||||
}
|
||||
|
||||
sub action {
|
||||
my ($self, $command, $wanthash) = @_;
|
||||
|
||||
return if (!$command);
|
||||
|
||||
my $conn = $self->connfd || return;
|
||||
|
||||
print $conn "Action: $command" . $BLANK;
|
||||
my @resp = $self->read_response($conn);
|
||||
|
||||
if ($wanthash) {
|
||||
return map { split(': ', $_) } @resp;
|
||||
} elsif (wantarray) {
|
||||
return @resp;
|
||||
} else {
|
||||
return $resp[0];
|
||||
}
|
||||
}
|
||||
|
||||
sub command {
|
||||
my ($self, $command) = @_;
|
||||
|
||||
return if (!$command);
|
||||
|
||||
return $self->sendcommand('Action' => 'Command',
|
||||
'Command' => $command, 1 );
|
||||
}
|
||||
|
||||
sub monitor {
|
||||
my ($self, $channel, $file) = @_;
|
||||
|
||||
return if (!$channel);
|
||||
|
||||
return $self->sendcommand('Action' => 'Monitor',
|
||||
'Channel' => $channel,
|
||||
'File' => $file, 1 );
|
||||
}
|
||||
|
||||
sub changemonitor {
|
||||
my ($self, $channel, $file) = @_;
|
||||
|
||||
return if (!$channel);
|
||||
|
||||
return $self->sendcommand('Action' => 'ChangeMonitor',
|
||||
'Channel' => $channel,
|
||||
'File' => $file, 1 );
|
||||
}
|
||||
|
||||
sub stopmonitor {
|
||||
my ($self, $channel, $file) = @_;
|
||||
|
||||
return if (!$channel);
|
||||
|
||||
return $self->sendcommand('Action' => 'StopMonitor',
|
||||
'Channel' => $channel,
|
||||
'File' => $file, 1 );
|
||||
}
|
||||
|
||||
|
||||
sub disconnect {
|
||||
my ($self) = @_;
|
||||
|
||||
my $conn = $self->connfd;
|
||||
|
||||
my %resp = $self->sendcommand('Action' => 'Logoff');
|
||||
|
||||
|
||||
if ($resp{Response} eq 'Goodbye') {
|
||||
$self->{_CONNFD} = undef;
|
||||
$self->connected(0);
|
||||
return 1;
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,110 @@
|
||||
package Asterisk::Outgoing;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Asterisk::Outgoing - Create outgoing call queue file
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Asterisk::Outgoing;
|
||||
|
||||
my $out = new Asterisk::Outgoing;
|
||||
|
||||
$out->setvariable('Channel', 'Zap/1/');
|
||||
|
||||
$out->setvariable('MaxRetries', 0);
|
||||
|
||||
$out->setvariable('RetryTime', 60);
|
||||
|
||||
$out->setvariable('WaitTime', 60);
|
||||
|
||||
$out->setvariable('Application', 'Playback');
|
||||
|
||||
$out->setvariable('Data', 'beep');
|
||||
|
||||
$out->create_outgoing;
|
||||
|
||||
=cut
|
||||
|
||||
require 5.004;
|
||||
|
||||
use Fcntl ':flock';
|
||||
use Asterisk;
|
||||
@ISA = ('Asterisk');
|
||||
|
||||
$VERSION = '0.01';
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $self = {};
|
||||
$self->{OUTDIR} = '/var/spool/asterisk/outgoing';
|
||||
$self->{OUTTIME} = undef;
|
||||
$self->{OUTVARS} = {};
|
||||
$self->{ALLOWEDVARS} = [ 'channel', 'maxretries', 'retrytime', 'waittime', 'context', 'extension', 'priority', 'application', 'data', 'callerid' ];
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub outdir {
|
||||
my ($self, $dir) = @_;
|
||||
|
||||
if (defined($dir)) {
|
||||
$self->{OUTDIR} = $dir;
|
||||
}
|
||||
|
||||
return $self->{OUTDIR};
|
||||
}
|
||||
|
||||
sub outtime {
|
||||
my ($self, $time) = @_;
|
||||
|
||||
if (defined($time)) {
|
||||
$self->{OUTTIME} = $time;
|
||||
} elsif (!defined($self->{OUTTIME})) {
|
||||
$self->{OUTTIME} = time();
|
||||
}
|
||||
|
||||
return $self->{OUTTIME};
|
||||
}
|
||||
|
||||
sub checkvariable {
|
||||
my ($self, $var) = @_;
|
||||
|
||||
my $ret = 0;
|
||||
|
||||
foreach $allowed (@{$self->{ALLOWEDVARS}}) {
|
||||
if ($allowed =~ /$var/i) {
|
||||
$ret = 1;
|
||||
}
|
||||
}
|
||||
return $ret;
|
||||
}
|
||||
|
||||
sub setvariable {
|
||||
my ($self, $var, $value) = @_;
|
||||
|
||||
if ($self->checkvariable($var)) {
|
||||
$self->{OUTVARS}{$var} = $value;
|
||||
}
|
||||
}
|
||||
|
||||
sub create_outgoing {
|
||||
my ($self) = @_;
|
||||
|
||||
my $time = $self->outtime();
|
||||
|
||||
my $outdir = $self->outdir();
|
||||
my $filename = $outdir . '/' . $time . '.outgoing';
|
||||
open(OUTFILE, ">$filename") || return 0;
|
||||
flock(OUTFILE, LOCK_EX);
|
||||
utime($time, $time, $filename);
|
||||
foreach my $var (keys %{$self->{OUTVARS}}) {
|
||||
print OUTFILE "$var: " . $self->{OUTVARS}{$var} . "\n";
|
||||
}
|
||||
flock(OUTFILE, LOCK_UN);
|
||||
close(OUTFILE);
|
||||
utime($time, $time, $filename);
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,61 @@
|
||||
package Asterisk::QCall;
|
||||
|
||||
require 5.004;
|
||||
|
||||
use Fcntl ':flock';
|
||||
use Asterisk;
|
||||
|
||||
$VERSION = '0.01';
|
||||
|
||||
sub version { $VERSION; }
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $self = {};
|
||||
$self->{QUEUEDIR} = '/var/spool/asterisk/qcall';
|
||||
$self->{QUEUETIME} = undef;
|
||||
bless $self, ref $class || $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
sub queuedir {
|
||||
my ($self, $dir) = @_;
|
||||
|
||||
if (defined($dir)) {
|
||||
$self->{QUEUEDIR} = $dir;
|
||||
}
|
||||
|
||||
return $self->{QUEUEDIR};
|
||||
}
|
||||
|
||||
sub queuetime {
|
||||
my ($self, $time) = @_;
|
||||
|
||||
if (defined($time)) {
|
||||
$self->{QUEUETIME} = $time;
|
||||
} elsif (!defined($self->{QUEUETIME})) {
|
||||
$self->{QUEUETIME} = time();
|
||||
}
|
||||
|
||||
return $self->{QUEUETIME};
|
||||
}
|
||||
|
||||
sub create_qcall {
|
||||
my ($self, $dialstring, $callerid, $extension, $maxsecs, $identifier, $response) = @_;
|
||||
|
||||
my $time = $self->queuetime();
|
||||
|
||||
my $queuedir = $self->queuedir();
|
||||
my $filename = $queuedir . '/' . $time . '.queue';
|
||||
open(QFILE, ">$filename") || return 0;
|
||||
flock(QFILE, LOCK_EX);
|
||||
print QFILE "$dialstring $callerid $extension $maxsecs $identifier $response";
|
||||
flock(QFILE, LOCK_UN);
|
||||
close(QFILE);
|
||||
my $ret = utime($time, $time, $filename);
|
||||
return 1;
|
||||
}
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,261 @@
|
||||
package Asterisk::Voicemail;
|
||||
|
||||
require 5.004;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Asterisk::Voicemail - Stuff to deal with asterisk voicemail
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
This is not completed yet
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
description
|
||||
|
||||
=cut
|
||||
|
||||
use Asterisk;
|
||||
|
||||
@ISA = ( 'Asterisk' );
|
||||
|
||||
$VERSION = '0.01';
|
||||
|
||||
$DEBUG = 5;
|
||||
|
||||
sub version { $VERSION; }
|
||||
|
||||
sub new {
|
||||
my ($class, %args) = @_;
|
||||
my $self = {};
|
||||
bless $self, ref $class || $class;
|
||||
# while (my ($key,$value) = each %args) { $self->set($key,$value); }
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub DESTROY { }
|
||||
|
||||
sub spooldirectory {
|
||||
my ($self, $directory) = @_;
|
||||
|
||||
if (defined($directory)) {
|
||||
$self->{'spooldirectory'} = $directory;
|
||||
} else {
|
||||
$self->{'spooldirectory'} = '/var/spool/asterisk/vm' if (!defined($self->{'spooldirectory'}));
|
||||
}
|
||||
|
||||
return $self->{'spooldirectory'};
|
||||
}
|
||||
|
||||
sub sounddirectory {
|
||||
my ($self, $directory) = @_;
|
||||
|
||||
if (defined($directory)) {
|
||||
$self->{'sounddirectory'} = $directory;
|
||||
} else {
|
||||
$self->{'sounddirectory'} = '/var/lib/asterisk/sounds' if (!defined($self->{'sounddirectory'}));
|
||||
}
|
||||
|
||||
return $self->{'sounddirectory'};
|
||||
}
|
||||
|
||||
sub serveremail {
|
||||
my ($self, $email) = @_;
|
||||
|
||||
$self->{'serveremail'} = $email if (defined($email));
|
||||
|
||||
return $self->{'serveremail'};
|
||||
}
|
||||
|
||||
sub format {
|
||||
my ($self, @formats) = @_;
|
||||
|
||||
if (@formats) {
|
||||
$self->{'formats'} = @formats;
|
||||
}
|
||||
|
||||
return $self->{'formats'};
|
||||
}
|
||||
|
||||
sub vmbox {
|
||||
my ($self, $vmbox, $vmpass, $vmfn, $vmemail) = @_;
|
||||
|
||||
if (defined($vmbox) && (defined($vmpass) || defined($vmfn) || defined($vmemail)) ) {
|
||||
$self->{'vmbox'}{$vmbox}{'pass'} = $vmpass if (defined($vmpass));
|
||||
$self->{'vmbox'}{$vmbox}{'fn'} = $vmfn if (defined($vmfn));
|
||||
$self->{'vmbox'}{$vmbox}{'email'} = $vmemail if (defined($vmemail));
|
||||
} elsif (defined($vmbox)) {
|
||||
return ($self->{'vmbox'}{$vmbox}{'pass'},
|
||||
$self->{'vmbox'}{$vmbox}{'fn'},
|
||||
$self->{'vmbox'}{$vmbox}{'email'} );
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub getfolders {
|
||||
my ($self, $vmbox) = @_;
|
||||
|
||||
my @folders = ();
|
||||
|
||||
my $spool = $self->spooldirectory();
|
||||
|
||||
foreach $file (<$spool/$vmbox/*>) {
|
||||
if ( -d $file ) {
|
||||
$file =~ s/$spool\/$vmbox\///;
|
||||
push(@folders, $file);
|
||||
}
|
||||
}
|
||||
return @folders;
|
||||
}
|
||||
|
||||
sub configfile {
|
||||
my ($self, $configfile) = @_;
|
||||
|
||||
if (defined($configfile)) {
|
||||
$self->{'configfile'} = $configfile;
|
||||
} else {
|
||||
$self->{'configfile'} = '/etc/asterisk/voicemail.conf' if (!defined($self->{'configfile'}));
|
||||
}
|
||||
|
||||
return $self->{'configfile'};
|
||||
}
|
||||
|
||||
sub readconfig {
|
||||
my ($self) = @_;
|
||||
|
||||
my $context = '';
|
||||
my $line = '';
|
||||
|
||||
my $configfile = $self->configfile();
|
||||
|
||||
open(CF, "<$configfile") || die "Error loading $configfile: $!\n";
|
||||
while ($line = <CF>) {
|
||||
chop($line);
|
||||
|
||||
$line =~ s/;.*$//;
|
||||
$line =~ s/\s*$//;
|
||||
|
||||
if ($line =~ /^;/) {
|
||||
next;
|
||||
} elsif ($line =~ /^\s*$/) {
|
||||
next;
|
||||
} elsif ($line =~ /^\[(\w+)\]$/) {
|
||||
$context = $1;
|
||||
print STDERR "Context: $context\n" if ($DEBUG>3);
|
||||
} elsif ($line =~ /^format\s*[=>]+\s*(.*)/) {
|
||||
my $formats = $1;
|
||||
$self->format(split(/|/, $formats));
|
||||
} elsif ($line =~ /^serveremail\s*[=>]+\s*(.*)/) {
|
||||
$self->serveremail($1);
|
||||
} elsif ($line =~ /^(\d+)\s*[=>]+\s*(.*)/) {
|
||||
my $vmbox = $1;
|
||||
my $vmstr = $2;
|
||||
my ($vmpass, $vmfn, $vmemail) = split(/,/, $vmstr);
|
||||
print STDERR "VM BOX ($vmbox)\n" if ($DEBUG>3);
|
||||
$self->vmbox($vmbox, $vmpass, $vmfn, $vmstr);
|
||||
} else {
|
||||
print STDERR "Unknown line: $line\n" if ($DEBUG);
|
||||
}
|
||||
}
|
||||
|
||||
close(CF);
|
||||
}
|
||||
|
||||
sub appendsoundfile {
|
||||
my ($self, $source, $dest) = @_;
|
||||
|
||||
open(IN, "<$source") || return 0;
|
||||
open(OUT, ">>$dest") || return 0;
|
||||
while (<IN>) {
|
||||
print OUT $_;
|
||||
}
|
||||
close(IN);
|
||||
close(OUT);
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub validmailbox {
|
||||
my ($self, $vmbox) = @_;
|
||||
|
||||
return 1 if ($self->vmbox($vmbox));
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub msgcount {
|
||||
my ($self, $vmbox, $folder) = @_;
|
||||
|
||||
my $count = 0;
|
||||
|
||||
return $count if (!defined($vmbox) || !defined($folder));
|
||||
|
||||
my $spool = $self->spooldirectory() . '/' . $vmbox . '/' . $folder;
|
||||
|
||||
if (opendir(DIR, $spool)) {
|
||||
my @msgs = grep(/^msg.*\.txt$/, readdir(DIR));
|
||||
$count = $#msgs+1;
|
||||
closedir(DIR);
|
||||
}
|
||||
return $count;
|
||||
}
|
||||
|
||||
sub msgcountstr {
|
||||
my ($self, $vmbox, $folder) = @_;
|
||||
|
||||
my $count = $self->msgcount($vmbox, $folder);
|
||||
|
||||
if ($count > 1) {
|
||||
return "$count messages";
|
||||
} elsif ($count > 0) {
|
||||
return "$count message";
|
||||
} else {
|
||||
return "no messages";
|
||||
}
|
||||
}
|
||||
|
||||
sub createdefaultmailbox {
|
||||
my ($self, $vmbox) = @_;
|
||||
|
||||
my $spool = $self->spooldirectory();
|
||||
my $sounddir = $self->sounddirectory();
|
||||
|
||||
my $vmdir = "$spool/$vmbox";
|
||||
|
||||
|
||||
if ( -d $vmdir ) {
|
||||
print STDERR "Directory already exists: $vmdir\n" if ($DEBUG);
|
||||
} else {
|
||||
mkdir($vmdir, 0755) || return 0;
|
||||
mkdir("$vmdir/INBOX", 0755) || return 0;
|
||||
}
|
||||
|
||||
$self->appendsoundfile("$sounddir/vm-theperson.gsm", "$vmdir/unavail.gsm");
|
||||
$self->appendsoundfile("$sounddir/vm-theperson.gsm", "$vmdir/busy.gsm");
|
||||
$self->appendsoundfile("$sounddir/vm-extension.gsm", "$vmdir/greet.gsm");
|
||||
|
||||
foreach $chr (split(//, $vmbox)) {
|
||||
$self->appendsoundfile("$sounddir/digits/$chr.gsm", "$vmdir/unavail.gsm");
|
||||
$self->appendsoundfile("$sounddir/digits/$chr.gsm", "$vmdir/busy.gsm");
|
||||
$self->appendsoundfile("$sounddir/digits/$chr.gsm", "$vmdir/greet.gsm");
|
||||
}
|
||||
|
||||
$self->appendsoundfile("$sounddir/vm-isunavail.gsm", "$vmdir/unavail.gsm");
|
||||
$self->appendsoundfile("$sounddir/vm-isonphone.gsm", "$vmdir/busy.gsm");
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub messages {
|
||||
my ($self, $messages, $folder) = @_;
|
||||
|
||||
my $path = $self->spooldirectory() . '/' . $mailbox . '/' . $folder;
|
||||
if (opendir(DIR, $path)) {
|
||||
my @msgs = sort grep(/^msg....\.txt$/, readdir(DIR));
|
||||
closedir(DIR);
|
||||
return map { s/^msg(....)\.txt$/$1/; $_ } @msgs;
|
||||
}
|
||||
return ();
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,266 @@
|
||||
package Net::HTTP;
|
||||
|
||||
# $Id: HTTP.pm,v 1.43 2002/12/26 09:13:53 gisle Exp $
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = "1.00";
|
||||
eval { require IO::Socket::INET } || require IO::Socket;
|
||||
require Net::HTTP::Methods;
|
||||
|
||||
@ISA=qw(IO::Socket::INET Net::HTTP::Methods);
|
||||
|
||||
sub configure {
|
||||
my($self, $cnf) = @_;
|
||||
$self->http_configure($cnf);
|
||||
}
|
||||
|
||||
sub http_connect {
|
||||
my($self, $cnf) = @_;
|
||||
$self->SUPER::configure($cnf);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Net::HTTP - Low-level HTTP connection (client)
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Net::HTTP;
|
||||
my $s = Net::HTTP->new(Host => "www.perl.com) || die $@;
|
||||
$s->write_request(GET => "/", 'User-Agent' => "Mozilla/5.0");
|
||||
my($code, $mess, %h) = $s->read_response_headers;
|
||||
|
||||
while (1) {
|
||||
my $buf;
|
||||
my $n = $s->read_entity_body($buf, 1024);
|
||||
die "read failed: $!" unless defined $n;
|
||||
last unless $n;
|
||||
print $buf;
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Net::HTTP> class is a low-level HTTP client. An instance of the
|
||||
C<Net::HTTP> class represents a connection to an HTTP server. The
|
||||
HTTP protocol is described in RFC 2616. The C<Net::HTTP> class
|
||||
support C<HTTP/1.0> and C<HTTP/1.1>.
|
||||
|
||||
C<Net::HTTP> is a sub-class of C<IO::Socket::INET>. You can mix the
|
||||
methods described below with reading and writing from the socket
|
||||
directly. This is not necessary a good idea, unless you know what you
|
||||
are doing.
|
||||
|
||||
The following methods are provided (in addition to those of
|
||||
C<IO::Socket::INET>):
|
||||
|
||||
=over
|
||||
|
||||
=item $s = Net::HTTP->new( %options )
|
||||
|
||||
The C<Net::HTTP> constructor method takes the same options as
|
||||
C<IO::Socket::INET>'s as well as these:
|
||||
|
||||
Host: Initial host attribute value
|
||||
KeepAlive: Initial keep_alive attribute value
|
||||
SendTE: Initial send_te attribute_value
|
||||
HTTPVersion: Initial http_version attribute value
|
||||
PeerHTTPVersion: Initial peer_http_version attribute value
|
||||
MaxLineLength: Initial max_line_length attribute value
|
||||
MaxHeaderLines: Initial max_header_lines attribute value
|
||||
|
||||
The C<Host> option is also the default for C<IO::Socket::INET>'s
|
||||
C<PeerAddr>. The C<PeerPort> defaults to 80 if not provided.
|
||||
|
||||
The C<Listen> option provided by C<IO::Socket::INET>'s constructor
|
||||
method is not allowed.
|
||||
|
||||
If unable to connect to the given HTTP server then the constructor
|
||||
returns C<undef> and $@ contains the reason. After a successful
|
||||
connect, a C<Net:HTTP> object is returned.
|
||||
|
||||
=item $s->host
|
||||
|
||||
Get/set the default value of the C<Host> header to send. The $host
|
||||
should not be set to an empty string (or C<undef>).
|
||||
|
||||
=item $s->keep_alive
|
||||
|
||||
Get/set the I<keep-alive> value. If this value is TRUE then the
|
||||
request will be sent with headers indicating that the server should try
|
||||
to keep the connection open so that multiple requests can be sent.
|
||||
|
||||
The actual headers set will depend on the value of the C<http_version>
|
||||
and C<peer_http_version> attributes.
|
||||
|
||||
=item $s->send_te
|
||||
|
||||
Get/set the a value indicating if the request will be sent with a "TE"
|
||||
header to indicate the transfer encodings that the server can chose to
|
||||
use. If the C<Compress::Zlib> module is installed then this will
|
||||
annouce that this client accept both the I<deflate> and I<gzip>
|
||||
encodings.
|
||||
|
||||
=item $s->http_version
|
||||
|
||||
Get/set the HTTP version number that this client should announce.
|
||||
This value can only be set to "1.0" or "1.1". The default is "1.1".
|
||||
|
||||
=item $s->peer_http_version
|
||||
|
||||
Get/set the protocol version number of our peer. This value will
|
||||
initially be "1.0", but will be updated by a successful
|
||||
read_response_headers() method call.
|
||||
|
||||
=item $s->max_line_length
|
||||
|
||||
Get/set a limit on the length of response line and response header
|
||||
lines. The default is 4096. A value of 0 means no limit.
|
||||
|
||||
=item $s->max_header_length
|
||||
|
||||
Get/set a limit on the number of headers lines that a response can
|
||||
have. The default is 128. A value of 0 means no limit.
|
||||
|
||||
=item $s->format_request($method, $uri, %headers, [$content])
|
||||
|
||||
Format a request message and return it as a string. If the headers do
|
||||
not include a C<Host> header, then a header is inserted with the value
|
||||
of the C<host> attribute. Headers like C<Connection> and
|
||||
C<Keep-Alive> might also be added depending on the status of the
|
||||
C<keep_alive> attribute.
|
||||
|
||||
If $content is given (and it is non-empty), then a C<Content-Length>
|
||||
header is automatically added unless it was already present.
|
||||
|
||||
=item $s->write_request($method, $uri, %headers, [$content])
|
||||
|
||||
Format and send a request message. Arguments are the same as for
|
||||
format_request(). Returns true if successful.
|
||||
|
||||
=item $s->format_chunk( $data )
|
||||
|
||||
Returns the string to be written for the given chunk of data.
|
||||
|
||||
=item $s->write_chunk($data)
|
||||
|
||||
Will write a new chunk of request entity body data. This method
|
||||
should only be used if the C<Transfer-Encoding> header with a value of
|
||||
C<chunked> was sent in the request. Note, writing zero-length data is
|
||||
a no-op. Use the write_chunk_eof() method to signal end of entity
|
||||
body data.
|
||||
|
||||
Returns true if successful.
|
||||
|
||||
=item $s->format_chunk_eof( %trailers )
|
||||
|
||||
Returns the string to be written for signaling EOF when a
|
||||
C<Transfer-Encoding> of C<chunked> is used.
|
||||
|
||||
=item $s->write_chunk_eof( %trailers )
|
||||
|
||||
Will write eof marker for chunked data and optional trailers. Note
|
||||
that trailers should not really be used unless is was signaled
|
||||
with a C<Trailer> header.
|
||||
|
||||
Returns true if successful.
|
||||
|
||||
=item ($code, $mess, %headers) = $s->read_response_headers( %opts )
|
||||
|
||||
Read response headers from server and return it. The $code is the 3
|
||||
digit HTTP status code (see L<HTTP::Status>) and $mess is the textual
|
||||
message that came with it. Headers are then returned as key/value
|
||||
pairs. Since key letter casing is not normalized and the same key can
|
||||
even occur multiple times, assigning these values directly to a hash
|
||||
is not wise. Only the $code is returned if this method is called in
|
||||
scalar context.
|
||||
|
||||
As a side effect this method updates the 'peer_http_version'
|
||||
attribute.
|
||||
|
||||
Options might be passed in as key/value pairs. There are currently
|
||||
only two options supported; C<laxed> and C<junk_out>.
|
||||
|
||||
The C<laxed> option will make read_response_headers() more forgiving
|
||||
towards servers that have not learned how to speak HTTP properly. The
|
||||
C<laxed> option is a boolean flag, and is enabled by passing in a TRUE
|
||||
value. The C<junk_out> option can be used to capture bad header lines
|
||||
when C<laxed> is enabled. The value should be an array reference.
|
||||
Bad header lines will be pushed onto the array.
|
||||
|
||||
The C<laxed> option must be specified in order to communicate with
|
||||
pre-HTTP/1.0 servers that don't describe the response outcome or the
|
||||
data they send back with a header block. For these servers
|
||||
peer_http_version is set to "0.9" and this method returns (200,
|
||||
"Assumed OK").
|
||||
|
||||
The method will raise an exception (die) if the server does not speak
|
||||
proper HTTP or if the C<max_line_length> or C<max_header_length>
|
||||
limits are reached. If the C<laxed> option is turned on and
|
||||
C<max_line_length> and C<max_header_length> checks are turned off,
|
||||
then no exception will be raised and this method will always
|
||||
return a response code.
|
||||
|
||||
=item $n = $s->read_entity_body($buf, $size);
|
||||
|
||||
Reads chunks of the entity body content. Basically the same interface
|
||||
as for read() and sysread(), but the buffer offset argument is not
|
||||
supported yet. This method should only be called after a successful
|
||||
read_response_headers() call.
|
||||
|
||||
The return value will be C<undef> on read errors, 0 on EOF, -1 if no data
|
||||
could be returned this time, otherwise the number of bytes assgined
|
||||
to $buf. The $buf set to "" when the return value is -1.
|
||||
|
||||
This method will raise exceptions (die) if the server does not speak
|
||||
proper HTTP. This can only happen when reading chunked data.
|
||||
|
||||
=item %headers = $s->get_trailers
|
||||
|
||||
After read_entity_body() has returned 0 to indicate end of the entity
|
||||
body, you might call this method to pick up any trailers.
|
||||
|
||||
=item $s->_rbuf
|
||||
|
||||
Get/set the read buffer content. The read_response_headers() and
|
||||
read_entity_body() methods use an internal buffer which they will look
|
||||
for data before they actually sysread more from the socket itself. If
|
||||
they read too much, the remaining data will be left in this buffer.
|
||||
|
||||
=item $s->_rbuf_length
|
||||
|
||||
Returns the number of bytes in the read buffer. This should always be
|
||||
the same as:
|
||||
|
||||
length($s->_rbuf)
|
||||
|
||||
but might be more efficient.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
The read_response_headers() and read_entity_body() will invoke the
|
||||
sysread() method when they need more data. Subclasses might want to
|
||||
override this method to contol how reading takes place.
|
||||
|
||||
The object itself is a glob. Subclasses should avoid using hash key
|
||||
names prefixed with C<http_> and C<io_>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<LWP>, L<IO::Socket::INET>, L<Net::HTTP::NB>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001-2003 Gisle Aas.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,520 @@
|
||||
package Net::HTTP::Methods;
|
||||
|
||||
# $Id: Methods.pm,v 1.12 2002/12/26 09:13:55 gisle Exp $
|
||||
|
||||
require 5.005; # 4-arg substr
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION);
|
||||
|
||||
$VERSION = "1.00";
|
||||
|
||||
my $CRLF = "\015\012"; # "\r\n" is not portable
|
||||
|
||||
sub new {
|
||||
my($class, %cnf) = @_;
|
||||
require Symbol;
|
||||
my $self = bless Symbol::gensym(), $class;
|
||||
return $self->http_configure(\%cnf);
|
||||
}
|
||||
|
||||
sub http_configure {
|
||||
my($self, $cnf) = @_;
|
||||
|
||||
die "Listen option not allowed" if $cnf->{Listen};
|
||||
my $host = delete $cnf->{Host};
|
||||
my $peer = $cnf->{PeerAddr} || $cnf->{PeerHost};
|
||||
if ($host) {
|
||||
$cnf->{PeerAddr} = $host unless $peer;
|
||||
}
|
||||
else {
|
||||
$host = $peer;
|
||||
$host =~ s/:.*//;
|
||||
}
|
||||
$cnf->{PeerPort} = $self->http_default_port unless $cnf->{PeerPort};
|
||||
$cnf->{Proto} = 'tcp';
|
||||
|
||||
my $keep_alive = delete $cnf->{KeepAlive};
|
||||
my $http_version = delete $cnf->{HTTPVersion};
|
||||
$http_version = "1.1" unless defined $http_version;
|
||||
my $peer_http_version = delete $cnf->{PeerHTTPVersion};
|
||||
$peer_http_version = "1.0" unless defined $peer_http_version;
|
||||
my $send_te = delete $cnf->{SendTE};
|
||||
my $max_line_length = delete $cnf->{MaxLineLength};
|
||||
$max_line_length = 4*1024 unless defined $max_line_length;
|
||||
my $max_header_lines = delete $cnf->{MaxHeaderLines};
|
||||
$max_header_lines = 128 unless defined $max_header_lines;
|
||||
|
||||
return undef unless $self->http_connect($cnf);
|
||||
|
||||
unless ($host =~ /:/) {
|
||||
my $p = $self->peerport;
|
||||
$host .= ":$p";
|
||||
}
|
||||
$self->host($host);
|
||||
$self->keep_alive($keep_alive);
|
||||
$self->send_te($send_te);
|
||||
$self->http_version($http_version);
|
||||
$self->peer_http_version($peer_http_version);
|
||||
$self->max_line_length($max_line_length);
|
||||
$self->max_header_lines($max_header_lines);
|
||||
|
||||
${*$self}{'http_buf'} = "";
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub http_default_port {
|
||||
80;
|
||||
}
|
||||
|
||||
# set up property accessors
|
||||
for my $method (qw(host keep_alive send_te max_line_length max_header_lines peer_http_version)) {
|
||||
my $prop_name = "http_" . $method;
|
||||
no strict 'refs';
|
||||
*$method = sub {
|
||||
my $self = shift;
|
||||
my $old = ${*$self}{$prop_name};
|
||||
${*$self}{$prop_name} = shift if @_;
|
||||
return $old;
|
||||
};
|
||||
}
|
||||
|
||||
# we want this one to be a bit smarter
|
||||
sub http_version {
|
||||
my $self = shift;
|
||||
my $old = ${*$self}{'http_version'};
|
||||
if (@_) {
|
||||
my $v = shift;
|
||||
$v = "1.0" if $v eq "1"; # float
|
||||
unless ($v eq "1.0" or $v eq "1.1") {
|
||||
require Carp;
|
||||
Carp::croak("Unsupported HTTP version '$v'");
|
||||
}
|
||||
${*$self}{'http_version'} = $v;
|
||||
}
|
||||
$old;
|
||||
}
|
||||
|
||||
sub format_request {
|
||||
my $self = shift;
|
||||
my $method = shift;
|
||||
my $uri = shift;
|
||||
|
||||
my $content = (@_ % 2) ? pop : "";
|
||||
|
||||
for ($method, $uri) {
|
||||
require Carp;
|
||||
Carp::croak("Bad method or uri") if /\s/ || !length;
|
||||
}
|
||||
|
||||
push(@{${*$self}{'http_request_method'}}, $method);
|
||||
my $ver = ${*$self}{'http_version'};
|
||||
my $peer_ver = ${*$self}{'http_peer_http_version'} || "1.0";
|
||||
|
||||
my @h;
|
||||
my @connection;
|
||||
my %given = (host => 0, "content-length" => 0, "te" => 0);
|
||||
while (@_) {
|
||||
my($k, $v) = splice(@_, 0, 2);
|
||||
my $lc_k = lc($k);
|
||||
if ($lc_k eq "connection") {
|
||||
push(@connection, split(/\s*,\s*/, $v));
|
||||
next;
|
||||
}
|
||||
if (exists $given{$lc_k}) {
|
||||
$given{$lc_k}++;
|
||||
}
|
||||
push(@h, "$k: $v");
|
||||
}
|
||||
|
||||
if (length($content) && !$given{'content-length'}) {
|
||||
push(@h, "Content-Length: " . length($content));
|
||||
}
|
||||
|
||||
my @h2;
|
||||
if ($given{te}) {
|
||||
push(@connection, "TE") unless grep lc($_) eq "te", @connection;
|
||||
}
|
||||
elsif ($self->send_te && zlib_ok()) {
|
||||
# gzip is less wanted since the Compress::Zlib interface for
|
||||
# it does not really allow chunked decoding to take place easily.
|
||||
push(@h2, "TE: deflate,gzip;q=0.3");
|
||||
push(@connection, "TE");
|
||||
}
|
||||
|
||||
unless (grep lc($_) eq "close", @connection) {
|
||||
if ($self->keep_alive) {
|
||||
if ($peer_ver eq "1.0") {
|
||||
# from looking at Netscape's headers
|
||||
push(@h2, "Keep-Alive: 300");
|
||||
unshift(@connection, "Keep-Alive");
|
||||
}
|
||||
}
|
||||
else {
|
||||
push(@connection, "close") if $ver ge "1.1";
|
||||
}
|
||||
}
|
||||
push(@h2, "Connection: " . join(", ", @connection)) if @connection;
|
||||
push(@h2, "Host: ${*$self}{'http_host'}") unless $given{host};
|
||||
|
||||
return join($CRLF, "$method $uri HTTP/$ver", @h2, @h, "", $content);
|
||||
}
|
||||
|
||||
|
||||
sub write_request {
|
||||
my $self = shift;
|
||||
$self->print($self->format_request(@_));
|
||||
}
|
||||
|
||||
sub format_chunk {
|
||||
my $self = shift;
|
||||
return $_[0] unless defined($_[0]) && length($_[0]);
|
||||
return sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF;
|
||||
}
|
||||
|
||||
sub write_chunk {
|
||||
my $self = shift;
|
||||
return 1 unless defined($_[0]) && length($_[0]);
|
||||
$self->print(sprintf("%x", length($_[0])) . $CRLF . $_[0] . $CRLF);
|
||||
}
|
||||
|
||||
sub format_chunk_eof {
|
||||
my $self = shift;
|
||||
my @h;
|
||||
while (@_) {
|
||||
push(@h, sprintf "%s: %s$CRLF", splice(@_, 0, 2));
|
||||
}
|
||||
return join("", "0$CRLF", @h, $CRLF);
|
||||
}
|
||||
|
||||
sub write_chunk_eof {
|
||||
my $self = shift;
|
||||
$self->print($self->format_chunk_eof(@_));
|
||||
}
|
||||
|
||||
|
||||
sub my_read {
|
||||
die if @_ > 3;
|
||||
my $self = shift;
|
||||
my $len = $_[1];
|
||||
for (${*$self}{'http_buf'}) {
|
||||
if (length) {
|
||||
$_[0] = substr($_, 0, $len, "");
|
||||
return length($_[0]);
|
||||
}
|
||||
else {
|
||||
return $self->sysread($_[0], $len);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub my_readline {
|
||||
my $self = shift;
|
||||
for (${*$self}{'http_buf'}) {
|
||||
my $max_line_length = ${*$self}{'http_max_line_length'};
|
||||
my $pos;
|
||||
while (1) {
|
||||
# find line ending
|
||||
$pos = index($_, "\012");
|
||||
last if $pos >= 0;
|
||||
die "Line too long (limit is $max_line_length)"
|
||||
if $max_line_length && length($_) > $max_line_length;
|
||||
|
||||
# need to read more data to find a line ending
|
||||
my $n = $self->sysread($_, 1024, length);
|
||||
if (!$n) {
|
||||
return undef unless length;
|
||||
return substr($_, 0, length, "");
|
||||
}
|
||||
}
|
||||
die "Line too long ($pos; limit is $max_line_length)"
|
||||
if $max_line_length && $pos > $max_line_length;
|
||||
|
||||
my $line = substr($_, 0, $pos+1, "");
|
||||
$line =~ s/(\015?\012)\z// || die "Assert";
|
||||
return wantarray ? ($line, $1) : $line;
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
sub _rbuf {
|
||||
my $self = shift;
|
||||
if (@_) {
|
||||
for (${*$self}{'http_buf'}) {
|
||||
my $old;
|
||||
$old = $_ if defined wantarray;
|
||||
$_ = shift;
|
||||
return $old;
|
||||
}
|
||||
}
|
||||
else {
|
||||
return ${*$self}{'http_buf'};
|
||||
}
|
||||
}
|
||||
|
||||
sub _rbuf_length {
|
||||
my $self = shift;
|
||||
return length ${*$self}{'http_buf'};
|
||||
}
|
||||
|
||||
|
||||
sub _read_header_lines {
|
||||
my $self = shift;
|
||||
my $junk_out = shift;
|
||||
|
||||
my @headers;
|
||||
my $line_count = 0;
|
||||
my $max_header_lines = ${*$self}{'http_max_header_lines'};
|
||||
while (my $line = my_readline($self)) {
|
||||
if ($line =~ /^(\S+)\s*:\s*(.*)/s) {
|
||||
push(@headers, $1, $2);
|
||||
}
|
||||
elsif (@headers && $line =~ s/^\s+//) {
|
||||
$headers[-1] .= " " . $line;
|
||||
}
|
||||
elsif ($junk_out) {
|
||||
push(@$junk_out, $line);
|
||||
}
|
||||
else {
|
||||
die "Bad header: '$line'\n";
|
||||
}
|
||||
if ($max_header_lines) {
|
||||
$line_count++;
|
||||
if ($line_count >= $max_header_lines) {
|
||||
die "Too many header lines (limit is $max_header_lines)";
|
||||
}
|
||||
}
|
||||
}
|
||||
return @headers;
|
||||
}
|
||||
|
||||
|
||||
sub read_response_headers {
|
||||
my($self, %opt) = @_;
|
||||
my $laxed = $opt{laxed};
|
||||
|
||||
my($status, $eol) = my_readline($self);
|
||||
unless (defined $status) {
|
||||
die "EOF instead of response status line" unless $laxed;
|
||||
# assume HTTP/0.9
|
||||
${*$self}{'http_peer_http_version'} = "0.9";
|
||||
${*$self}{'http_status'} = "200";
|
||||
return 200 unless wantarray;
|
||||
return (200, "EOF");
|
||||
}
|
||||
|
||||
my($peer_ver, $code, $message) = split(/\s+/, $status, 3);
|
||||
if (!$peer_ver || $peer_ver !~ s,^HTTP/,, || $code !~ /^[1-5]\d\d$/) {
|
||||
die "Bad response status line: '$status'" unless $laxed;
|
||||
# assume HTTP/0.9
|
||||
${*$self}{'http_peer_http_version'} = "0.9";
|
||||
${*$self}{'http_status'} = "200";
|
||||
substr(${*$self}{'http_buf'}, 0, 0) = $status . $eol;
|
||||
return 200 unless wantarray;
|
||||
return (200, "Assumed OK");
|
||||
};
|
||||
|
||||
${*$self}{'http_peer_http_version'} = $peer_ver;
|
||||
${*$self}{'http_status'} = $code;
|
||||
|
||||
my $junk_out;
|
||||
if ($laxed) {
|
||||
$junk_out = $opt{junk_out} || [];
|
||||
}
|
||||
my @headers = $self->_read_header_lines($junk_out);
|
||||
|
||||
# pick out headers that read_entity_body might need
|
||||
my @te;
|
||||
my $content_length;
|
||||
for (my $i = 0; $i < @headers; $i += 2) {
|
||||
my $h = lc($headers[$i]);
|
||||
if ($h eq 'transfer-encoding') {
|
||||
push(@te, $headers[$i+1]);
|
||||
}
|
||||
elsif ($h eq 'content-length') {
|
||||
$content_length = $headers[$i+1];
|
||||
}
|
||||
}
|
||||
${*$self}{'http_te'} = join(",", @te);
|
||||
${*$self}{'http_content_length'} = $content_length;
|
||||
${*$self}{'http_first_body'}++;
|
||||
delete ${*$self}{'http_trailers'};
|
||||
return $code unless wantarray;
|
||||
return ($code, $message, @headers);
|
||||
}
|
||||
|
||||
|
||||
sub read_entity_body {
|
||||
my $self = shift;
|
||||
my $buf_ref = \$_[0];
|
||||
my $size = $_[1];
|
||||
die "Offset not supported yet" if $_[2];
|
||||
|
||||
my $chunked;
|
||||
my $bytes;
|
||||
|
||||
if (${*$self}{'http_first_body'}) {
|
||||
${*$self}{'http_first_body'} = 0;
|
||||
delete ${*$self}{'http_chunked'};
|
||||
delete ${*$self}{'http_bytes'};
|
||||
my $method = shift(@{${*$self}{'http_request_method'}});
|
||||
my $status = ${*$self}{'http_status'};
|
||||
if ($method eq "HEAD" || $status =~ /^(?:1|[23]04)/) {
|
||||
# these responses are always empty
|
||||
$bytes = 0;
|
||||
}
|
||||
elsif (my $te = ${*$self}{'http_te'}) {
|
||||
my @te = split(/\s*,\s*/, lc($te));
|
||||
die "Chunked must be last Transfer-Encoding '$te'"
|
||||
unless pop(@te) eq "chunked";
|
||||
|
||||
for (@te) {
|
||||
if ($_ eq "deflate" && zlib_ok()) {
|
||||
#require Compress::Zlib;
|
||||
my $i = Compress::Zlib::inflateInit();
|
||||
die "Can't make inflator" unless $i;
|
||||
$_ = sub { scalar($i->inflate($_[0])) }
|
||||
}
|
||||
elsif ($_ eq "gzip" && zlib_ok()) {
|
||||
#require Compress::Zlib;
|
||||
my @buf;
|
||||
$_ = sub {
|
||||
push(@buf, $_[0]);
|
||||
return Compress::Zlib::memGunzip(join("", @buf)) if $_[1];
|
||||
return "";
|
||||
};
|
||||
}
|
||||
elsif ($_ eq "identity") {
|
||||
$_ = sub { $_[0] };
|
||||
}
|
||||
else {
|
||||
die "Can't handle transfer encoding '$te'";
|
||||
}
|
||||
}
|
||||
|
||||
@te = reverse(@te);
|
||||
|
||||
${*$self}{'http_te2'} = @te ? \@te : "";
|
||||
$chunked = -1;
|
||||
}
|
||||
elsif (defined(my $content_length = ${*$self}{'http_content_length'})) {
|
||||
$bytes = $content_length;
|
||||
}
|
||||
else {
|
||||
# XXX Multi-Part types are self delimiting, but RFC 2616 says we
|
||||
# only has to deal with 'multipart/byteranges'
|
||||
|
||||
# Read until EOF
|
||||
}
|
||||
}
|
||||
else {
|
||||
$chunked = ${*$self}{'http_chunked'};
|
||||
$bytes = ${*$self}{'http_bytes'};
|
||||
}
|
||||
|
||||
if (defined $chunked) {
|
||||
# The state encoded in $chunked is:
|
||||
# $chunked == 0: read CRLF after chunk, then chunk header
|
||||
# $chunked == -1: read chunk header
|
||||
# $chunked > 0: bytes left in current chunk to read
|
||||
|
||||
if ($chunked <= 0) {
|
||||
my $line = my_readline($self);
|
||||
if ($chunked == 0) {
|
||||
die "Missing newline after chunk data: '$line'" unless $line eq "";
|
||||
$line = my_readline($self);
|
||||
}
|
||||
my $chunk_len = $line;
|
||||
$chunk_len =~ s/;.*//; # ignore potential chunk parameters
|
||||
unless ($chunk_len =~ /^([\da-fA-F]+)\s*$/) {
|
||||
die "Bad chunk-size in HTTP response: $line";
|
||||
}
|
||||
$chunked = hex($1);
|
||||
if ($chunked == 0) {
|
||||
${*$self}{'http_trailers'} = [$self->_read_header_lines];
|
||||
$$buf_ref = "";
|
||||
|
||||
my $n = 0;
|
||||
if (my $transforms = delete ${*$self}{'http_te2'}) {
|
||||
for (@$transforms) {
|
||||
$$buf_ref = &$_($$buf_ref, 1);
|
||||
}
|
||||
$n = length($$buf_ref);
|
||||
}
|
||||
|
||||
# in case somebody tries to read more, make sure we continue
|
||||
# to return EOF
|
||||
delete ${*$self}{'http_chunked'};
|
||||
${*$self}{'http_bytes'} = 0;
|
||||
|
||||
return $n;
|
||||
}
|
||||
}
|
||||
|
||||
my $n = $chunked;
|
||||
$n = $size if $size && $size < $n;
|
||||
$n = my_read($self, $$buf_ref, $n);
|
||||
return undef unless defined $n;
|
||||
|
||||
${*$self}{'http_chunked'} = $chunked - $n;
|
||||
|
||||
if ($n > 0) {
|
||||
if (my $transforms = ${*$self}{'http_te2'}) {
|
||||
for (@$transforms) {
|
||||
$$buf_ref = &$_($$buf_ref, 0);
|
||||
}
|
||||
$n = length($$buf_ref);
|
||||
$n = -1 if $n == 0;
|
||||
}
|
||||
}
|
||||
return $n;
|
||||
}
|
||||
elsif (defined $bytes) {
|
||||
unless ($bytes) {
|
||||
$$buf_ref = "";
|
||||
return 0;
|
||||
}
|
||||
my $n = $bytes;
|
||||
$n = $size if $size && $size < $n;
|
||||
$n = my_read($self, $$buf_ref, $n);
|
||||
return undef unless defined $n;
|
||||
${*$self}{'http_bytes'} = $bytes - $n;
|
||||
return $n;
|
||||
}
|
||||
else {
|
||||
# read until eof
|
||||
$size ||= 8*1024;
|
||||
return my_read($self, $$buf_ref, $size);
|
||||
}
|
||||
}
|
||||
|
||||
sub get_trailers {
|
||||
my $self = shift;
|
||||
@{${*$self}{'http_trailers'} || []};
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
my $zlib_ok;
|
||||
|
||||
sub zlib_ok {
|
||||
return $zlib_ok if defined $zlib_ok;
|
||||
|
||||
# Try to load Compress::Zlib.
|
||||
local $@;
|
||||
local $SIG{__DIE__};
|
||||
$zlib_ok = 0;
|
||||
|
||||
eval {
|
||||
require Compress::Zlib;
|
||||
Compress::Zlib->VERSION(1.10);
|
||||
$zlib_ok++;
|
||||
};
|
||||
|
||||
return $zlib_ok;
|
||||
}
|
||||
|
||||
} # BEGIN
|
||||
|
||||
1;
|
||||
@@ -0,0 +1,106 @@
|
||||
package Net::HTTP::NB;
|
||||
|
||||
# $Id: NB.pm,v 1.5 2001/08/28 03:03:42 gisle Exp $
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
|
||||
$VERSION = "0.02";
|
||||
require Net::HTTP;
|
||||
@ISA=qw(Net::HTTP);
|
||||
|
||||
sub sysread {
|
||||
my $self = $_[0];
|
||||
if (${*$self}{'httpnb_read_count'}++) {
|
||||
${*$self}{'http_buf'} = ${*$self}{'httpnb_save'};
|
||||
die "Multi-read\n";
|
||||
}
|
||||
my $buf;
|
||||
my $offset = $_[3] || 0;
|
||||
my $n = sysread($self, $_[1], $_[2], $offset);
|
||||
${*$self}{'httpnb_save'} .= substr($_[1], $offset);
|
||||
return $n;
|
||||
}
|
||||
|
||||
sub read_response_headers {
|
||||
my $self = shift;
|
||||
${*$self}{'httpnb_read_count'} = 0;
|
||||
${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
|
||||
my @h = eval { $self->SUPER::read_response_headers(@_) };
|
||||
if ($@) {
|
||||
return if $@ eq "Multi-read\n";
|
||||
die;
|
||||
}
|
||||
return @h;
|
||||
}
|
||||
|
||||
sub read_entity_body {
|
||||
my $self = shift;
|
||||
${*$self}{'httpnb_read_count'} = 0;
|
||||
${*$self}{'httpnb_save'} = ${*$self}{'http_buf'};
|
||||
# XXX I'm not so sure this does the correct thing in case of
|
||||
# transfer-encoding tranforms
|
||||
my $n = eval { $self->SUPER::read_entity_body(@_); };
|
||||
if ($@) {
|
||||
$_[0] = "";
|
||||
return -1;
|
||||
}
|
||||
return $n;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Net::HTTP::NB - Non-blocking HTTP client
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Net::HTTP::NB;
|
||||
my $s = Net::HTTP::NB->new(Host => "www.perl.com) || die $@;
|
||||
$s->write_request(GET => "/");
|
||||
|
||||
use IO::Select;
|
||||
my $sel = IO::Select->new($s);
|
||||
|
||||
READ_HEADER: {
|
||||
die "Header timeout" unless $sel->can_read(10);
|
||||
my($code, $mess, %h) = $s->read_response_headers;
|
||||
redo READ_HEADER unless $code;
|
||||
}
|
||||
|
||||
while (1) {
|
||||
die "Body timeout" unless $sel->can_read(10);
|
||||
my $buf;
|
||||
my $n = $s->read_entity_body($buf, 1024);
|
||||
last unless $n;
|
||||
print $buf;
|
||||
}
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Same interface as C<Net::HTTP> but it will never try multiple reads
|
||||
when the read_response_headers() or read_entity_body() methods are
|
||||
invoked. This make it possible to multiplex multiple Net::HTTP::NB
|
||||
using select without risk blocking.
|
||||
|
||||
If read_response_headers() did not see enough data to complete the
|
||||
headers an empty list is returned.
|
||||
|
||||
If read_entity_body() did not see new entity data in its read
|
||||
the value -1 is returned.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Net::HTTP>
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001 Gisle Aas.
|
||||
|
||||
This library is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
=cut
|
||||
@@ -0,0 +1,55 @@
|
||||
package Net::HTTPS;
|
||||
|
||||
# $Id: HTTPS.pm,v 1.3 2002/12/23 18:16:29 gisle Exp $
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION $SSL_SOCKET_CLASS @ISA);
|
||||
|
||||
$VERSION = "1.00";
|
||||
|
||||
# Figure out which SSL implementation to use
|
||||
if ($IO::Socket::SSL::VERSION) {
|
||||
$SSL_SOCKET_CLASS = "IO::Socket::SSL"; # it was already loaded
|
||||
}
|
||||
else {
|
||||
eval { require Net::SSL; }; # from Crypt-SSLeay
|
||||
if ($@) {
|
||||
my $old_errsv = $@;
|
||||
eval {
|
||||
require IO::Socket::SSL;
|
||||
};
|
||||
if ($@) {
|
||||
$old_errsv =~ s/\s\(\@INC contains:.*\)/)/g;
|
||||
die $old_errsv . $@;
|
||||
}
|
||||
$SSL_SOCKET_CLASS = "IO::Socket::SSL";
|
||||
}
|
||||
else {
|
||||
$SSL_SOCKET_CLASS = "Net::SSL";
|
||||
}
|
||||
}
|
||||
|
||||
require Net::HTTP::Methods;
|
||||
|
||||
@ISA=($SSL_SOCKET_CLASS, 'Net::HTTP::Methods');
|
||||
|
||||
sub configure {
|
||||
my($self, $cnf) = @_;
|
||||
$self->http_configure($cnf);
|
||||
}
|
||||
|
||||
sub http_connect {
|
||||
my($self, $cnf) = @_;
|
||||
$self->SUPER::configure($cnf);
|
||||
}
|
||||
|
||||
sub http_default_port {
|
||||
443;
|
||||
}
|
||||
|
||||
# The underlying SSLeay classes fails to work if the socket is
|
||||
# placed in non-blocking mode. This override of the blocking
|
||||
# method makes sure it stays the way it was created.
|
||||
sub blocking { } # noop
|
||||
|
||||
1;
|
||||
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,255 @@
|
||||
package Net::SSH;
|
||||
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA @EXPORT_OK $ssh $equalspace $DEBUG @ssh_options);
|
||||
use Exporter;
|
||||
use IO::File;
|
||||
use IPC::Open2;
|
||||
use IPC::Open3;
|
||||
|
||||
@ISA = qw(Exporter);
|
||||
@EXPORT_OK = qw( ssh issh ssh_cmd sshopen2 sshopen3 );
|
||||
$VERSION = '0.07';
|
||||
|
||||
$DEBUG = 0;
|
||||
|
||||
$ssh = "ssh";
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Net::SSH - Perl extension for secure shell
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Net::SSH qw(ssh issh sshopen2 sshopen3);
|
||||
|
||||
ssh('user@hostname', $command);
|
||||
|
||||
issh('user@hostname', $command);
|
||||
|
||||
ssh_cmd('user@hostname', $command);
|
||||
ssh_cmd( {
|
||||
user => 'user',
|
||||
host => 'host.name',
|
||||
command => 'command',
|
||||
args => [ '-arg1', '-arg2' ],
|
||||
stdin_string => "string\n",
|
||||
} );
|
||||
|
||||
sshopen2('user@hostname', $reader, $writer, $command);
|
||||
|
||||
sshopen3('user@hostname', $writer, $reader, $error, $command);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Simple wrappers around ssh commands.
|
||||
|
||||
For an all-perl implementation that does not require the system B<ssh> command,
|
||||
see L<Net::SSH::Perl> instead.
|
||||
|
||||
=head1 SUBROUTINES
|
||||
|
||||
=over 4
|
||||
|
||||
=item ssh [USER@]HOST, COMMAND [, ARGS ... ]
|
||||
|
||||
Calls ssh in batch mode.
|
||||
|
||||
=cut
|
||||
|
||||
sub ssh {
|
||||
my($host, @command) = @_;
|
||||
@ssh_options = &_ssh_options unless @ssh_options;
|
||||
my @cmd = ($ssh, @ssh_options, $host, @command);
|
||||
warn "[Net::SSH::ssh] executing ". join(' ', @cmd). "\n"
|
||||
if $DEBUG;
|
||||
system(@cmd);
|
||||
}
|
||||
|
||||
=item issh [USER@]HOST, COMMAND [, ARGS ... ]
|
||||
|
||||
Prints the ssh command to be executed, waits for the user to confirm, and
|
||||
(optionally) executes the command.
|
||||
|
||||
=cut
|
||||
|
||||
sub issh {
|
||||
my($host, @command) = @_;
|
||||
my @cmd = ($ssh, $host, @command);
|
||||
print join(' ', @cmd), "\n";
|
||||
if ( &_yesno ) {
|
||||
system(@cmd);
|
||||
}
|
||||
}
|
||||
|
||||
=item ssh_cmd [USER@]HOST, COMMAND [, ARGS ... ]
|
||||
|
||||
=item ssh_cmd OPTIONS_HASHREF
|
||||
|
||||
Calls ssh in batch mode. Throws a fatal error if data occurs on the command's
|
||||
STDERR. Returns any data from the command's STDOUT.
|
||||
|
||||
If using the hashref-style of passing arguments, possible keys are:
|
||||
|
||||
user (optional)
|
||||
host (requried)
|
||||
command (required)
|
||||
args (optional, arrayref)
|
||||
stdin_string (optional) - written to the command's STDIN
|
||||
|
||||
=cut
|
||||
|
||||
sub ssh_cmd {
|
||||
my($host, $stdin_string, @command);
|
||||
if ( ref($_[0]) ) {
|
||||
my $opt = shift;
|
||||
$host = $opt->{host};
|
||||
$host = $opt->{user}. '@'. $host if exists $opt->{user};
|
||||
@command = ( $opt->{command} );
|
||||
push @command, @{ $opt->{args} } if exists $opt->{args};
|
||||
$stdin_string = $opt->{stdin_string};
|
||||
} else {
|
||||
($host, @command) = @_;
|
||||
undef $stdin_string;
|
||||
}
|
||||
|
||||
my $reader = IO::File->new();
|
||||
my $writer = IO::File->new();
|
||||
my $error = IO::File->new();
|
||||
|
||||
sshopen3( $host, $writer, $reader, $error, @command ) or die $!;
|
||||
|
||||
print $writer $stdin_string if defined $stdin_string;
|
||||
close $writer;
|
||||
|
||||
local $/ = undef;
|
||||
my $output_stream = <$reader>;
|
||||
my $error_stream = <$error>;
|
||||
|
||||
if ( length $error_stream ) {
|
||||
die "[Net:SSH::ssh_cmd] STDERR $error_stream";
|
||||
}
|
||||
|
||||
return $output_stream;
|
||||
|
||||
}
|
||||
|
||||
=item sshopen2 [USER@]HOST, READER, WRITER, COMMAND [, ARGS ... ]
|
||||
|
||||
Connects the supplied filehandles to the ssh process (in batch mode).
|
||||
|
||||
=cut
|
||||
|
||||
sub sshopen2 {
|
||||
my($host, $reader, $writer, @command) = @_;
|
||||
@ssh_options = &_ssh_options unless @ssh_options;
|
||||
open2($reader, $writer, $ssh, @ssh_options, $host, @command);
|
||||
}
|
||||
|
||||
=item sshopen3 HOST, WRITER, READER, ERROR, COMMAND [, ARGS ... ]
|
||||
|
||||
Connects the supplied filehandles to the ssh process (in batch mode).
|
||||
|
||||
=cut
|
||||
|
||||
sub sshopen3 {
|
||||
my($host, $writer, $reader, $error, @command) = @_;
|
||||
@ssh_options = &_ssh_options unless @ssh_options;
|
||||
open3($writer, $reader, $error, $ssh, @ssh_options, $host, @command);
|
||||
}
|
||||
|
||||
sub _yesno {
|
||||
print "Proceed [y/N]:";
|
||||
my $x = scalar(<STDIN>);
|
||||
$x =~ /^y/i;
|
||||
}
|
||||
|
||||
sub _ssh_options {
|
||||
my $reader = IO::File->new();
|
||||
my $writer = IO::File->new();
|
||||
my $error = IO::File->new();
|
||||
open3($writer, $reader, $error, $ssh, '-V');
|
||||
my $ssh_version = <$error>;
|
||||
chomp($ssh_version);
|
||||
if ( $ssh_version =~ /.*OpenSSH[-|_](\w+)\./ && $1 == 1 ) {
|
||||
$equalspace = " ";
|
||||
} else {
|
||||
$equalspace = "=";
|
||||
}
|
||||
my @options = ( '-o', 'BatchMode'.$equalspace.'yes' );
|
||||
if ( $ssh_version =~ /.*OpenSSH[-|_](\w+)\./ && $1 > 1 ) {
|
||||
unshift @options, '-T';
|
||||
}
|
||||
@options;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
use Net::SSH qw(sshopen2);
|
||||
use strict;
|
||||
|
||||
my $user = "username";
|
||||
my $host = "hostname";
|
||||
my $cmd = "command";
|
||||
|
||||
sshopen2("$user\@$host", *READER, *WRITER, "$cmd") || die "ssh: $!";
|
||||
|
||||
while (<READER>) {
|
||||
chomp();
|
||||
print "$_\n";
|
||||
}
|
||||
|
||||
close(READER);
|
||||
close(WRITER);
|
||||
|
||||
=head1 FREQUENTLY ASKED QUESTIONS
|
||||
|
||||
Q: How do you supply a password to connect with ssh within a perl script
|
||||
using the Net::SSH module?
|
||||
|
||||
A: You don't. Use RSA or DSA keys. See the ssh-keygen(1) manpage.
|
||||
|
||||
Q: My script is "leaking" ssh processes.
|
||||
|
||||
A: See L<perlfaq8/"How do I avoid zombies on a Unix system">, L<IPC::Open2>,
|
||||
L<IPC::Open3> and L<perlfunc/waitpid>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Ivan Kohler <ivan-netssh_pod@420.am>
|
||||
|
||||
John Harrison <japh@in-ta.net> contributed an example for the documentation.
|
||||
|
||||
Martin Langhoff <martin@cwa.co.nz> contributed the ssh_cmd command, and
|
||||
Jeff Finucane <jeff@cmh.net> updated it and took care of the 0.04 release.
|
||||
|
||||
Anthony Awtrey <tony@awtrey.com> contributed a fix for those still using
|
||||
OpenSSH v1.
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright (c) 2002 Ivan Kohler.
|
||||
Copyright (c) 2002 Freeside Internet Services, LLC
|
||||
All rights reserved.
|
||||
This program is free software; you can redistribute it and/or modify it under
|
||||
the same terms as Perl itself.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Not OO.
|
||||
|
||||
Look at IPC::Session (also fsh)
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
For an all-perl implementation that does not require the system B<ssh> command,
|
||||
see L<Net::SSH::Perl> instead.
|
||||
|
||||
ssh-keygen(1), ssh(1), L<IO::File>, L<IPC::Open2>, L<IPC::Open3>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
File diff suppressed because it is too large
Load Diff
@@ -0,0 +1,359 @@
|
||||
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
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep);
|
||||
|
||||
$VERSION = '1.59';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($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 };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
usleep ($microseconds);
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the C<usleep>,
|
||||
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()>, and C<select()>, you don't get
|
||||
C<Time::HiRes::usleep()> 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 unportable, 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. (There is no
|
||||
separate interface to call C<nanosleep()>; just use C<Time::HiRes::sleep()>
|
||||
or C<Time::HiRes::usleep()> with small enough values.)
|
||||
|
||||
Unless using C<nanosleep> for 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 specified. Returns the number
|
||||
of microseconds actually slept. Can sleep for more than one second,
|
||||
unlike the C<usleep> system call. See also C<Time::HiRes::sleep()> below.
|
||||
|
||||
=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.
|
||||
|
||||
=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.
|
||||
|
||||
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 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.
|
||||
|
||||
=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 operating system and Perl release combinations
|
||||
C<SIGALRM> restarts C<select()>, instead of interuping 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()>.
|
||||
|
||||
=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 a
|
||||
timer, 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 behavior. 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()>.
|
||||
|
||||
=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);
|
||||
|
||||
=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 (*)(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 VMS have
|
||||
emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)();
|
||||
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.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002,2003,2004 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
|
||||
@@ -0,0 +1,369 @@
|
||||
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
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep);
|
||||
|
||||
$VERSION = '1.65';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($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 };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
usleep ($microseconds);
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the
|
||||
C<usleep>, 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()>, and
|
||||
C<select()>, you don't get C<Time::HiRes::usleep()> 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. (There is no separate interface to call
|
||||
C<nanosleep()>; just use C<Time::HiRes::sleep()> or
|
||||
C<Time::HiRes::usleep()> with small enough values.)
|
||||
|
||||
Unless using C<nanosleep> for 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 specified. Returns the number
|
||||
of microseconds actually slept. Can sleep for more than one second,
|
||||
unlike the C<usleep> system call. See also C<Time::HiRes::sleep()> below.
|
||||
|
||||
=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 are 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.
|
||||
|
||||
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 are 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 are 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 behavior. 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()>.
|
||||
|
||||
=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);
|
||||
|
||||
=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 (*)(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 VMS have
|
||||
emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)();
|
||||
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.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002,2003,2004 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
|
||||
@@ -0,0 +1,351 @@
|
||||
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
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep);
|
||||
|
||||
$VERSION = '1.55';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($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 };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
usleep ($microseconds);
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the C<usleep>,
|
||||
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()>, and C<select()>, you don't get
|
||||
C<Time::HiRes::usleep()> 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 unportable, 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. (There is no
|
||||
separate interface to call C<nanosleep()>; just use C<Time::HiRes::sleep()>
|
||||
or C<Time::HiRes::usleep()> with small enough values.)
|
||||
|
||||
Unless using C<nanosleep> for 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 specified. Returns the number
|
||||
of microseconds actually slept. Can sleep for more than one second,
|
||||
unlike the C<usleep> system call. See also C<Time::HiRes::sleep()> below.
|
||||
|
||||
=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.
|
||||
|
||||
=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.
|
||||
|
||||
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 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.
|
||||
|
||||
=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 operating system and Perl release combinations
|
||||
C<SIGALRM> restarts C<select()>, instead of interuping 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()>.
|
||||
|
||||
=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 a
|
||||
timer, 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 behavior. 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()>.
|
||||
|
||||
=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);
|
||||
|
||||
=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 (*)(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 VMS have
|
||||
emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)();
|
||||
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()>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002,2003,2004 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
|
||||
@@ -0,0 +1,289 @@
|
||||
package Time::Local;
|
||||
|
||||
require Exporter;
|
||||
use Carp;
|
||||
use Config;
|
||||
use strict;
|
||||
use integer;
|
||||
|
||||
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK );
|
||||
$VERSION = '1.07';
|
||||
@ISA = qw( Exporter );
|
||||
@EXPORT = qw( timegm timelocal );
|
||||
@EXPORT_OK = qw( timegm_nocheck timelocal_nocheck );
|
||||
|
||||
my @MonthDays = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31);
|
||||
|
||||
# Determine breakpoint for rolling century
|
||||
my $ThisYear = (localtime())[5];
|
||||
my $Breakpoint = ($ThisYear + 50) % 100;
|
||||
my $NextCentury = $ThisYear - $ThisYear % 100;
|
||||
$NextCentury += 100 if $Breakpoint < 50;
|
||||
my $Century = $NextCentury - 100;
|
||||
my $SecOff = 0;
|
||||
|
||||
my (%Options, %Cheat);
|
||||
|
||||
my $MaxInt = ((1<<(8 * $Config{intsize} - 2))-1)*2 + 1;
|
||||
my $MaxDay = int(($MaxInt-43200)/86400)-1;
|
||||
|
||||
# Determine the EPOC day for this machine
|
||||
my $Epoc = 0;
|
||||
if ($^O eq 'vos') {
|
||||
# work around posix-977 -- VOS doesn't handle dates in
|
||||
# the range 1970-1980.
|
||||
$Epoc = _daygm((0, 0, 0, 1, 0, 70, 4, 0));
|
||||
}
|
||||
elsif ($^O eq 'MacOS') {
|
||||
no integer;
|
||||
|
||||
$MaxDay *=2 if $^O eq 'MacOS'; # time_t unsigned ... quick hack?
|
||||
# MacOS time() is seconds since 1 Jan 1904, localtime
|
||||
# so we need to calculate an offset to apply later
|
||||
$Epoc = 693901;
|
||||
$SecOff = timelocal(localtime(0)) - timelocal(gmtime(0));
|
||||
$Epoc += _daygm(gmtime(0));
|
||||
}
|
||||
else {
|
||||
$Epoc = _daygm(gmtime(0));
|
||||
}
|
||||
|
||||
%Cheat=(); # clear the cache as epoc has changed
|
||||
|
||||
sub _daygm {
|
||||
$_[3] + ($Cheat{pack("ss",@_[4,5])} ||= do {
|
||||
my $month = ($_[4] + 10) % 12;
|
||||
my $year = $_[5] + 1900 - $month/10;
|
||||
365*$year + $year/4 - $year/100 + $year/400 + ($month*306 + 5)/10 - $Epoc
|
||||
});
|
||||
}
|
||||
|
||||
|
||||
sub _timegm {
|
||||
my $sec = $SecOff + $_[0] + 60 * $_[1] + 3600 * $_[2];
|
||||
|
||||
no integer;
|
||||
|
||||
$sec + 86400 * &_daygm;
|
||||
}
|
||||
|
||||
|
||||
sub timegm {
|
||||
my ($sec,$min,$hour,$mday,$month,$year) = @_;
|
||||
|
||||
if ($year >= 1000) {
|
||||
$year -= 1900;
|
||||
}
|
||||
elsif ($year < 100 and $year >= 0) {
|
||||
$year += ($year > $Breakpoint) ? $Century : $NextCentury;
|
||||
}
|
||||
|
||||
unless ($Options{no_range_check}) {
|
||||
if (abs($year) >= 0x7fff) {
|
||||
$year += 1900;
|
||||
croak "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
|
||||
}
|
||||
|
||||
croak "Month '$month' out of range 0..11" if $month > 11 or $month < 0;
|
||||
|
||||
my $md = $MonthDays[$month];
|
||||
++$md unless $month != 1 or $year % 4 or !($year % 400);
|
||||
|
||||
croak "Day '$mday' out of range 1..$md" if $mday > $md or $mday < 1;
|
||||
croak "Hour '$hour' out of range 0..23" if $hour > 23 or $hour < 0;
|
||||
croak "Minute '$min' out of range 0..59" if $min > 59 or $min < 0;
|
||||
croak "Second '$sec' out of range 0..59" if $sec > 59 or $sec < 0;
|
||||
}
|
||||
|
||||
my $days = _daygm(undef, undef, undef, $mday, $month, $year);
|
||||
|
||||
unless ($Options{no_range_check} or abs($days) < $MaxDay) {
|
||||
$year += 1900;
|
||||
croak "Cannot handle date ($sec, $min, $hour, $mday, $month, $year)";
|
||||
}
|
||||
|
||||
$sec += $SecOff + 60*$min + 3600*$hour;
|
||||
|
||||
no integer;
|
||||
|
||||
$sec + 86400*$days;
|
||||
}
|
||||
|
||||
|
||||
sub timegm_nocheck {
|
||||
local $Options{no_range_check} = 1;
|
||||
&timegm;
|
||||
}
|
||||
|
||||
|
||||
sub timelocal {
|
||||
no integer;
|
||||
my $ref_t = &timegm;
|
||||
my $loc_t = _timegm(localtime($ref_t));
|
||||
|
||||
# Is there a timezone offset from GMT or are we done
|
||||
my $zone_off = $ref_t - $loc_t
|
||||
or return $loc_t;
|
||||
|
||||
# Adjust for timezone
|
||||
$loc_t = $ref_t + $zone_off;
|
||||
|
||||
# Are we close to a DST change or are we done
|
||||
my $dst_off = $ref_t - _timegm(localtime($loc_t))
|
||||
or return $loc_t;
|
||||
|
||||
# Adjust for DST change
|
||||
$loc_t += $dst_off;
|
||||
|
||||
# for a negative offset from GMT, and if the original date
|
||||
# was a non-extent gap in a forward DST jump, we should
|
||||
# now have the wrong answer - undo the DST adjust;
|
||||
|
||||
return $loc_t if $zone_off <= 0;
|
||||
|
||||
my ($s,$m,$h) = localtime($loc_t);
|
||||
$loc_t -= $dst_off if $s != $_[0] || $m != $_[1] || $h != $_[2];
|
||||
|
||||
$loc_t;
|
||||
}
|
||||
|
||||
|
||||
sub timelocal_nocheck {
|
||||
local $Options{no_range_check} = 1;
|
||||
&timelocal;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Time::Local - efficiently compute time from local and GMT time
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
$time = timelocal($sec,$min,$hour,$mday,$mon,$year);
|
||||
$time = timegm($sec,$min,$hour,$mday,$mon,$year);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These routines are the inverse of built-in perl functions localtime()
|
||||
and gmtime(). They accept a date as a six-element array, and return
|
||||
the corresponding time(2) value in seconds since the system epoch
|
||||
(Midnight, January 1, 1970 UTC on Unix, for example). This value can
|
||||
be positive or negative, though POSIX only requires support for
|
||||
positive values, so dates before the system's epoch may not work on
|
||||
all operating systems.
|
||||
|
||||
It is worth drawing particular attention to the expected ranges for
|
||||
the values provided. The value for the day of the month is the actual day
|
||||
(ie 1..31), while the month is the number of months since January (0..11).
|
||||
This is consistent with the values returned from localtime() and gmtime().
|
||||
|
||||
The timelocal() and timegm() functions perform range checking on the
|
||||
input $sec, $min, $hour, $mday, and $mon values by default. If you'd
|
||||
rather they didn't, you can explicitly import the timelocal_nocheck()
|
||||
and timegm_nocheck() functions.
|
||||
|
||||
use Time::Local 'timelocal_nocheck';
|
||||
|
||||
{
|
||||
# The 365th day of 1999
|
||||
print scalar localtime timelocal_nocheck 0,0,0,365,0,99;
|
||||
|
||||
# The twenty thousandth day since 1970
|
||||
print scalar localtime timelocal_nocheck 0,0,0,20000,0,70;
|
||||
|
||||
# And even the 10,000,000th second since 1999!
|
||||
print scalar localtime timelocal_nocheck 10000000,0,0,1,0,99;
|
||||
}
|
||||
|
||||
Your mileage may vary when trying these with minutes and hours,
|
||||
and it doesn't work at all for months.
|
||||
|
||||
Strictly speaking, the year should also be specified in a form consistent
|
||||
with localtime(), i.e. the offset from 1900.
|
||||
In order to make the interpretation of the year easier for humans,
|
||||
however, who are more accustomed to seeing years as two-digit or four-digit
|
||||
values, the following conventions are followed:
|
||||
|
||||
=over 4
|
||||
|
||||
=item *
|
||||
|
||||
Years greater than 999 are interpreted as being the actual year,
|
||||
rather than the offset from 1900. Thus, 1963 would indicate the year
|
||||
Martin Luther King won the Nobel prize, not the year 2863.
|
||||
|
||||
=item *
|
||||
|
||||
Years in the range 100..999 are interpreted as offset from 1900,
|
||||
so that 112 indicates 2012. This rule also applies to years less than zero
|
||||
(but see note below regarding date range).
|
||||
|
||||
=item *
|
||||
|
||||
Years in the range 0..99 are interpreted as shorthand for years in the
|
||||
rolling "current century," defined as 50 years on either side of the current
|
||||
year. Thus, today, in 1999, 0 would refer to 2000, and 45 to 2045,
|
||||
but 55 would refer to 1955. Twenty years from now, 55 would instead refer
|
||||
to 2055. This is messy, but matches the way people currently think about
|
||||
two digit dates. Whenever possible, use an absolute four digit year instead.
|
||||
|
||||
=back
|
||||
|
||||
The scheme above allows interpretation of a wide range of dates, particularly
|
||||
if 4-digit years are used.
|
||||
|
||||
Please note, however, that the range of dates that can be actually be handled
|
||||
depends on the size of an integer (time_t) on a given platform.
|
||||
Currently, this is 32 bits for most systems, yielding an approximate range
|
||||
from Dec 1901 to Jan 2038.
|
||||
|
||||
Both timelocal() and timegm() croak if given dates outside the supported
|
||||
range.
|
||||
|
||||
=head1 IMPLEMENTATION
|
||||
|
||||
These routines are quite efficient and yet are always guaranteed to agree
|
||||
with localtime() and gmtime(). We manage this by caching the start times
|
||||
of any months we've seen before. If we know the start time of the month,
|
||||
we can always calculate any time within the month. The start times
|
||||
are calculated using a mathematical formula. Unlike other algorithms
|
||||
that do multiple calls to gmtime().
|
||||
|
||||
timelocal() is implemented using the same cache. We just assume that we're
|
||||
translating a GMT time, and then fudge it when we're done for the timezone
|
||||
and daylight savings arguments. Note that the timezone is evaluated for
|
||||
each date because countries occasionally change their official timezones.
|
||||
Assuming that localtime() corrects for these changes, this routine will
|
||||
also be correct.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
The whole scheme for interpreting two-digit years can be considered a bug.
|
||||
|
||||
The proclivity to croak() is probably a bug.
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Support for this module is provided via the perl5-porters@perl.org
|
||||
email list. See http://lists.perl.org/ for more details.
|
||||
|
||||
Please submit bugs using the RT system at bugs.perl.org, the perlbug
|
||||
script, or as a last resort, to the perl5-porters@perl.org list.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module is based on a Perl 4 library, timelocal.pl, that was
|
||||
included with Perl 4.036, and was most likely written by Tom
|
||||
Christiansen.
|
||||
|
||||
The current version was written by Graham Barr.
|
||||
|
||||
It is now being maintained separately from the Perl core by Dave
|
||||
Rolsky, <autarch@urth.org>.
|
||||
|
||||
=cut
|
||||
|
||||
@@ -0,0 +1,351 @@
|
||||
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
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep);
|
||||
|
||||
$VERSION = '1.55';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($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 };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
usleep ($microseconds);
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the C<usleep>,
|
||||
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()>, and C<select()>, you don't get
|
||||
C<Time::HiRes::usleep()> 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 unportable, 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. (There is no
|
||||
separate interface to call C<nanosleep()>; just use C<Time::HiRes::sleep()>
|
||||
or C<Time::HiRes::usleep()> with small enough values.)
|
||||
|
||||
Unless using C<nanosleep> for 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 specified. Returns the number
|
||||
of microseconds actually slept. Can sleep for more than one second,
|
||||
unlike the C<usleep> system call. See also C<Time::HiRes::sleep()> below.
|
||||
|
||||
=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.
|
||||
|
||||
=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.
|
||||
|
||||
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 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.
|
||||
|
||||
=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 operating system and Perl release combinations
|
||||
C<SIGALRM> restarts C<select()>, instead of interuping 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()>.
|
||||
|
||||
=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 a
|
||||
timer, 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 behavior. 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()>.
|
||||
|
||||
=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);
|
||||
|
||||
=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 (*)(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 VMS have
|
||||
emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)();
|
||||
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()>.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002,2003,2004 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
|
||||
@@ -0,0 +1,359 @@
|
||||
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
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep);
|
||||
|
||||
$VERSION = '1.59';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($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 };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
usleep ($microseconds);
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the C<usleep>,
|
||||
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()>, and C<select()>, you don't get
|
||||
C<Time::HiRes::usleep()> 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 unportable, 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. (There is no
|
||||
separate interface to call C<nanosleep()>; just use C<Time::HiRes::sleep()>
|
||||
or C<Time::HiRes::usleep()> with small enough values.)
|
||||
|
||||
Unless using C<nanosleep> for 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 specified. Returns the number
|
||||
of microseconds actually slept. Can sleep for more than one second,
|
||||
unlike the C<usleep> system call. See also C<Time::HiRes::sleep()> below.
|
||||
|
||||
=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.
|
||||
|
||||
=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.
|
||||
|
||||
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 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.
|
||||
|
||||
=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 operating system and Perl release combinations
|
||||
C<SIGALRM> restarts C<select()>, instead of interuping 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()>.
|
||||
|
||||
=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 a
|
||||
timer, 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 behavior. 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()>.
|
||||
|
||||
=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);
|
||||
|
||||
=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 (*)(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 VMS have
|
||||
emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)();
|
||||
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.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002,2003,2004 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
|
||||
@@ -0,0 +1,369 @@
|
||||
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
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep);
|
||||
|
||||
$VERSION = '1.65';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($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 };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
usleep ($microseconds);
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the
|
||||
C<usleep>, 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()>, and
|
||||
C<select()>, you don't get C<Time::HiRes::usleep()> 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. (There is no separate interface to call
|
||||
C<nanosleep()>; just use C<Time::HiRes::sleep()> or
|
||||
C<Time::HiRes::usleep()> with small enough values.)
|
||||
|
||||
Unless using C<nanosleep> for 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 specified. Returns the number
|
||||
of microseconds actually slept. Can sleep for more than one second,
|
||||
unlike the C<usleep> system call. See also C<Time::HiRes::sleep()> below.
|
||||
|
||||
=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 are 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.
|
||||
|
||||
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 are 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 are 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 behavior. 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()>.
|
||||
|
||||
=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);
|
||||
|
||||
=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 (*)(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 VMS have
|
||||
emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)();
|
||||
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.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002,2003,2004 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
|
||||
@@ -0,0 +1,359 @@
|
||||
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
|
||||
ITIMER_REAL ITIMER_VIRTUAL ITIMER_PROF ITIMER_REALPROF
|
||||
d_usleep d_ualarm d_gettimeofday d_getitimer d_setitimer
|
||||
d_nanosleep);
|
||||
|
||||
$VERSION = '1.59';
|
||||
$XS_VERSION = $VERSION;
|
||||
$VERSION = eval $VERSION;
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $constname;
|
||||
($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 };
|
||||
}
|
||||
goto &$AUTOLOAD;
|
||||
}
|
||||
|
||||
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 );
|
||||
|
||||
usleep ($microseconds);
|
||||
|
||||
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);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The C<Time::HiRes> module implements a Perl interface to the C<usleep>,
|
||||
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()>, and C<select()>, you don't get
|
||||
C<Time::HiRes::usleep()> 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 unportable, 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. (There is no
|
||||
separate interface to call C<nanosleep()>; just use C<Time::HiRes::sleep()>
|
||||
or C<Time::HiRes::usleep()> with small enough values.)
|
||||
|
||||
Unless using C<nanosleep> for 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 specified. Returns the number
|
||||
of microseconds actually slept. Can sleep for more than one second,
|
||||
unlike the C<usleep> system call. See also C<Time::HiRes::sleep()> below.
|
||||
|
||||
=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.
|
||||
|
||||
=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.
|
||||
|
||||
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 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.
|
||||
|
||||
=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 operating system and Perl release combinations
|
||||
C<SIGALRM> restarts C<select()>, instead of interuping 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()>.
|
||||
|
||||
=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 a
|
||||
timer, 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 behavior. 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()>.
|
||||
|
||||
=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);
|
||||
|
||||
=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 (*)(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 VMS have
|
||||
emulations for it.)
|
||||
|
||||
Here is an example of using C<NVtime> from C:
|
||||
|
||||
double (*myNVtime)();
|
||||
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.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
D. Wegscheid <wegscd@whirlpool.com>
|
||||
R. Schertler <roderick@argon.org>
|
||||
J. Hietaniemi <jhi@iki.fi>
|
||||
G. Aas <gisle@aas.no>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
Copyright (c) 1996-2002 Douglas E. Wegscheid. All rights reserved.
|
||||
|
||||
Copyright (c) 2002,2003,2004 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
|
||||
@@ -0,0 +1,90 @@
|
||||
package Time::gmtime;
|
||||
use strict;
|
||||
use 5.006_001;
|
||||
|
||||
use Time::tm;
|
||||
|
||||
our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
|
||||
BEGIN {
|
||||
use Exporter ();
|
||||
@ISA = qw(Exporter Time::tm);
|
||||
@EXPORT = qw(gmtime gmctime);
|
||||
@EXPORT_OK = qw(
|
||||
$tm_sec $tm_min $tm_hour $tm_mday
|
||||
$tm_mon $tm_year $tm_wday $tm_yday
|
||||
$tm_isdst
|
||||
);
|
||||
%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
|
||||
$VERSION = 1.02;
|
||||
}
|
||||
use vars @EXPORT_OK;
|
||||
|
||||
sub populate (@) {
|
||||
return unless @_;
|
||||
my $tmob = Time::tm->new();
|
||||
@$tmob = (
|
||||
$tm_sec, $tm_min, $tm_hour, $tm_mday,
|
||||
$tm_mon, $tm_year, $tm_wday, $tm_yday,
|
||||
$tm_isdst )
|
||||
= @_;
|
||||
return $tmob;
|
||||
}
|
||||
|
||||
sub gmtime (;$) { populate CORE::gmtime(@_ ? shift : time)}
|
||||
sub gmctime (;$) { scalar CORE::gmtime(@_ ? shift : time)}
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Time::gmtime - by-name interface to Perl's built-in gmtime() function
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Time::gmtime;
|
||||
$gm = gmtime();
|
||||
printf "The day in Greenwich is %s\n",
|
||||
(qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm->wday() ];
|
||||
|
||||
use Time::gmtime w(:FIELDS;
|
||||
printf "The day in Greenwich is %s\n",
|
||||
(qw(Sun Mon Tue Wed Thu Fri Sat Sun))[ gm_wday() ];
|
||||
|
||||
$now = gmctime();
|
||||
|
||||
use Time::gmtime;
|
||||
use File::stat;
|
||||
$date_string = gmctime(stat($file)->mtime);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module's default exports override the core gmtime() function,
|
||||
replacing it with a version that returns "Time::tm" objects.
|
||||
This object has methods that return the similarly named structure field
|
||||
name from the C's tm structure from F<time.h>; namely sec, min, hour,
|
||||
mday, mon, year, wday, yday, and isdst.
|
||||
|
||||
You may also import all the structure fields directly into your namespace
|
||||
as regular variables using the :FIELDS import tag. (Note that this
|
||||
still overrides your core functions.) Access these fields as variables
|
||||
named with a preceding C<tm_> in front their method names. Thus,
|
||||
C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import the fields.
|
||||
|
||||
The gmctime() function provides a way of getting at the
|
||||
scalar sense of the original CORE::gmtime() function.
|
||||
|
||||
To access this functionality without the core overrides,
|
||||
pass the C<use> an empty import list, and then access
|
||||
function functions with their full qualified names.
|
||||
On the other hand, the built-ins are still available
|
||||
via the C<CORE::> pseudo-package.
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
While this class is currently implemented using the Class::Struct
|
||||
module to build a struct-like class, you shouldn't rely upon this.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen
|
||||
@@ -0,0 +1,86 @@
|
||||
package Time::localtime;
|
||||
use strict;
|
||||
use 5.006_001;
|
||||
|
||||
use Time::tm;
|
||||
|
||||
our(@ISA, @EXPORT, @EXPORT_OK, %EXPORT_TAGS, $VERSION);
|
||||
BEGIN {
|
||||
use Exporter ();
|
||||
@ISA = qw(Exporter Time::tm);
|
||||
@EXPORT = qw(localtime ctime);
|
||||
@EXPORT_OK = qw(
|
||||
$tm_sec $tm_min $tm_hour $tm_mday
|
||||
$tm_mon $tm_year $tm_wday $tm_yday
|
||||
$tm_isdst
|
||||
);
|
||||
%EXPORT_TAGS = ( FIELDS => [ @EXPORT_OK, @EXPORT ] );
|
||||
$VERSION = 1.02;
|
||||
}
|
||||
use vars @EXPORT_OK;
|
||||
|
||||
sub populate (@) {
|
||||
return unless @_;
|
||||
my $tmob = Time::tm->new();
|
||||
@$tmob = (
|
||||
$tm_sec, $tm_min, $tm_hour, $tm_mday,
|
||||
$tm_mon, $tm_year, $tm_wday, $tm_yday,
|
||||
$tm_isdst )
|
||||
= @_;
|
||||
return $tmob;
|
||||
}
|
||||
|
||||
sub localtime (;$) { populate CORE::localtime(@_ ? shift : time)}
|
||||
sub ctime (;$) { scalar CORE::localtime(@_ ? shift : time) }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Time::localtime - by-name interface to Perl's built-in localtime() function
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Time::localtime;
|
||||
printf "Year is %d\n", localtime->year() + 1900;
|
||||
|
||||
$now = ctime();
|
||||
|
||||
use Time::localtime;
|
||||
use File::stat;
|
||||
$date_string = ctime(stat($file)->mtime);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module's default exports override the core localtime() function,
|
||||
replacing it with a version that returns "Time::tm" objects.
|
||||
This object has methods that return the similarly named structure field
|
||||
name from the C's tm structure from F<time.h>; namely sec, min, hour,
|
||||
mday, mon, year, wday, yday, and isdst.
|
||||
|
||||
You may also import all the structure fields directly into your namespace
|
||||
as regular variables using the :FIELDS import tag. (Note that this still
|
||||
overrides your core functions.) Access these fields as
|
||||
variables named with a preceding C<tm_> in front their method names.
|
||||
Thus, C<$tm_obj-E<gt>mday()> corresponds to $tm_mday if you import
|
||||
the fields.
|
||||
|
||||
The ctime() function provides a way of getting at the
|
||||
scalar sense of the original CORE::localtime() function.
|
||||
|
||||
To access this functionality without the core overrides,
|
||||
pass the C<use> an empty import list, and then access
|
||||
function functions with their full qualified names.
|
||||
On the other hand, the built-ins are still available
|
||||
via the C<CORE::> pseudo-package.
|
||||
|
||||
=head1 NOTE
|
||||
|
||||
While this class is currently implemented using the Class::Struct
|
||||
module to build a struct-like class, you shouldn't rely upon this.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen
|
||||
@@ -0,0 +1,33 @@
|
||||
package Time::tm;
|
||||
use strict;
|
||||
|
||||
our $VERSION = '1.00';
|
||||
|
||||
use Class::Struct qw(struct);
|
||||
struct('Time::tm' => [
|
||||
map { $_ => '$' } qw{ sec min hour mday mon year wday yday isdst }
|
||||
]);
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Time::tm - internal object used by Time::gmtime and Time::localtime
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Don't use this module directly.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is used internally as a base class by Time::localtime And
|
||||
Time::gmtime functions. It creates a Time::tm struct object which is
|
||||
addressable just like's C's tm structure from F<time.h>; namely with sec,
|
||||
min, hour, mday, mon, year, wday, yday, and isdst.
|
||||
|
||||
This class is an internal interface only.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Tom Christiansen
|
||||
@@ -0,0 +1,51 @@
|
||||
MA|01000|02799
|
||||
RI|02800|02999
|
||||
NH|03000|03899
|
||||
ME|03900|04999
|
||||
VT|05000|05999
|
||||
CT|06000|06999
|
||||
NJ|07000|08999
|
||||
NY|10000|14999
|
||||
PA|15000|19699
|
||||
DE|19700|19999
|
||||
DC|20000|20599
|
||||
MD|20600|21999
|
||||
VA|22000|24699
|
||||
WV|24700|26999
|
||||
NC|27000|28999
|
||||
SC|29000|29999
|
||||
GA|30000|31999
|
||||
FL|32000|34999
|
||||
AL|35000|36999
|
||||
TN|37000|38599
|
||||
MS|38600|39999
|
||||
KY|40000|42999
|
||||
OH|43000|45999
|
||||
IN|46000|47999
|
||||
MI|48000|49999
|
||||
IA|50000|52999
|
||||
WI|53000|54999
|
||||
MN|55000|56999
|
||||
SD|57000|57999
|
||||
ND|58000|58999
|
||||
MT|59000|59999
|
||||
IL|60000|62999
|
||||
MO|63000|65999
|
||||
KS|66000|67999
|
||||
NE|68000|69999
|
||||
LA|70000|71599
|
||||
AR|71600|72999
|
||||
OK|73000|74999
|
||||
TX|75000|79999
|
||||
CO|80000|81999
|
||||
WY|82000|83199
|
||||
ID|83200|83999
|
||||
UT|84000|84999
|
||||
AZ|85000|86999
|
||||
NM|87000|88899
|
||||
NV|88900|89999
|
||||
CA|90000|96699
|
||||
HI|96700|96999
|
||||
OR|97000|97999
|
||||
WA|98000|99499
|
||||
AK|99500|99999
|
||||
Binary file not shown.
|
After Width: | Height: | Size: 9.9 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 311 B |
Binary file not shown.
|
After Width: | Height: | Size: 1.8 KiB |
Binary file not shown.
|
After Width: | Height: | Size: 240 B |
Binary file not shown.
|
After Width: | Height: | Size: 230 B |
Binary file not shown.
|
After Width: | Height: | Size: 520 B |
Reference in New Issue
Block a user