Skip to content

P
pbxm-perl-lib-el8
Commit 971eb4d6 authored by root's avatar root
Browse files
Options

major update

parent 3ad4d3dc
Hide whitespace changes
Inline Side-by-side
Showing with 3532 additions and 1228 deletions
build/patch/SSLeay.xs 0 → 100644
View file @ 971eb4d6
/*
* $Id: SSLeay.xs,v 1.2 2000/05/10 16:37:25 ben Exp $
* Copyright 1998 Gisle Aas.
*
* This library is free software; you can redistribute it and/or
* modify it under the same terms as Perl itself.
*/
#ifdef __cplusplus
extern "C" {
#endif
#include "EXTERN.h"
#include "perl.h"
/* CRYPT_SSLEAY_free() will not be #defined to be free() now that we're no
* longer supporting pre-2000 OpenSSL.
#define NO_XSLOCKS
*/
#include "XSUB.h"
/* build problem under openssl 0.9.6 and some builds of perl 5.8.x */
#ifndef PERL5
#define PERL5 1
#endif
/* Makefile.PL no longer generates the following header file
* #include "crypt_ssleay_version.h"
* Among other things, Makefile.PL used to determine whether
* to use #include<openssl/ssl.h> or #include<ssl.h> and
* whether to use OPENSSL_free or free etc, but such distinctions
* ceased to matter pre-2000. Crypt::SSLeay no longer supports
* pre-2000 OpenSSL */
#include <openssl/ssl.h>
#include <openssl/crypto.h>
#include <openssl/err.h>
#include <openssl/rand.h>
#include <openssl/pkcs12.h>
#define CRYPT_SSLEAY_free OPENSSL_free
#undef Free /* undo namespace pollution from crypto.h */
#ifdef __cplusplus
}
#endif
#if SSLEAY_VERSION_NUMBER >= 0x0900
#define CRYPT_SSL_CLIENT_METHOD SSLv3_client_method()
#else
#define CRYPT_SSL_CLIENT_METHOD SSLv2_client_method()
#endif
static void InfoCallback(const SSL *s,int where,int ret)
{
const char *str;
int w;
w = where & ~SSL_ST_MASK;
if(w & SSL_ST_CONNECT)
str="SSL_connect";
else if(w & SSL_ST_ACCEPT)
str="SSL_accept";
else
str="undefined";
if(where & SSL_CB_LOOP) {
fprintf(stderr,"%s:%s\n",str,SSL_state_string_long(s));
}
else if(where & SSL_CB_ALERT) {
str=(where & SSL_CB_READ)?"read":"write";
fprintf(stderr,"SSL3 alert %s:%s:%s\n",str,
SSL_alert_type_string_long(ret),
SSL_alert_desc_string_long(ret));
}
else if(where & SSL_CB_EXIT) {
if(ret == 0)
fprintf(stderr,"%s:failed in %s\n",str,SSL_state_string_long(s));
else if (ret < 0)
fprintf(stderr,"%s:error in %s\n",str,SSL_state_string_long(s));
}
}
MODULE = Crypt::SSLeay PACKAGE = Crypt::SSLeay
PROTOTYPES: DISABLE
MODULE = Crypt::SSLeay PACKAGE = Crypt::SSLeay::Err PREFIX = ERR_
#define CRYPT_SSLEAY_ERR_BUFSIZE 1024
const char *
ERR_get_error_string()
PREINIT:
unsigned long code;
char buf[ CRYPT_SSLEAY_ERR_BUFSIZE ];
CODE:
if ((code = ERR_get_error()) == 0) {
RETVAL = NULL;
}
else {
/* www.openssl.org/docs/crypto/ERR_error_string.html */
ERR_error_string_n(code, buf, CRYPT_SSLEAY_ERR_BUFSIZE);
RETVAL = buf;
}
OUTPUT:
RETVAL
MODULE = Crypt::SSLeay PACKAGE = Crypt::SSLeay::CTX PREFIX = SSL_CTX_
#define CRYPT_SSLEAY_RAND_BUFSIZE 1024
SSL_CTX*
SSL_CTX_new(packname, ssl_version)
SV* packname
int ssl_version
CODE:
SSL_CTX* ctx;
static int bNotFirstTime;
char buf[ CRYPT_SSLEAY_RAND_BUFSIZE ];
if(!bNotFirstTime) {
OpenSSL_add_all_algorithms();
SSL_load_error_strings();
ERR_load_crypto_strings();
SSL_library_init();
bNotFirstTime = 1;
}
/**** Code from Devin Heitmueller, 10/3/2002 ****/
/**** Use /dev/urandom to seed if available ****/
/* ASU: 2014/04/23 It looks like it is OK to leave
* this in. See following thread:
* http://security.stackexchange.com/questions/56469/
*/
if (RAND_load_file("/dev/urandom", CRYPT_SSLEAY_RAND_BUFSIZE)
!= CRYPT_SSLEAY_RAND_BUFSIZE)
{
/* Couldn't read /dev/urandom, just seed off
* of the stack variable (the old way)
*/
RAND_seed(buf, CRYPT_SSLEAY_RAND_BUFSIZE);
}
if(ssl_version == 23) {
ctx = SSL_CTX_new(SSLv23_client_method());
}
else if(ssl_version == 3) {
ctx = SSL_CTX_new(TLS_client_method());
}
else {
+#if !defined OPENSSL_NO_SSL2 && OPENSSL_VERSION_NUMBER < 0x10100000L
/* v2 is the default */
ctx = SSL_CTX_new(SSLv2_client_method());
#else
/* v3 is the default */
ctx = SSL_CTX_new(TLS_client_method());
#endif
}
SSL_CTX_set_options(ctx,SSL_OP_ALL|0);
SSL_CTX_set_default_verify_paths(ctx);
SSL_CTX_set_verify(ctx, SSL_VERIFY_NONE, NULL);
RETVAL = ctx;
OUTPUT:
RETVAL
void
SSL_CTX_free(ctx)
SSL_CTX* ctx
int
SSL_CTX_set_cipher_list(ctx, ciphers)
SSL_CTX* ctx
char* ciphers
int
SSL_CTX_use_certificate_file(ctx, filename, mode)
SSL_CTX* ctx
char* filename
int mode
int
SSL_CTX_use_PrivateKey_file(ctx, filename ,mode)
SSL_CTX* ctx
char* filename
int mode
int
SSL_CTX_use_pkcs12_file(ctx, filename, password)
SSL_CTX* ctx
const char *filename
const char *password
PREINIT:
FILE *fp;
EVP_PKEY *pkey;
X509 *cert;
STACK_OF(X509) *ca = NULL;
PKCS12 *p12;
CODE:
if ((fp = fopen(filename, "rb"))) {
p12 = d2i_PKCS12_fp(fp, NULL);
fclose (fp);
if (p12) {
if(PKCS12_parse(p12, password, &pkey, &cert, &ca)) {
if (pkey) {
RETVAL = SSL_CTX_use_PrivateKey(ctx, pkey);
EVP_PKEY_free(pkey);
}
if (cert) {
RETVAL = SSL_CTX_use_certificate(ctx, cert);
X509_free(cert);
}
}
PKCS12_free(p12);
}
}
OUTPUT:
RETVAL
int
SSL_CTX_check_private_key(ctx)
SSL_CTX* ctx
SV*
SSL_CTX_set_verify(ctx)
SSL_CTX* ctx
PREINIT:
char* CAfile;
char* CAdir;
CODE:
CAfile=getenv("HTTPS_CA_FILE");
CAdir =getenv("HTTPS_CA_DIR");
if(!CAfile && !CAdir) {
SSL_CTX_set_verify(ctx, SSL_VERIFY_NONE, NULL);
RETVAL = newSViv(0);
}
else {
SSL_CTX_load_verify_locations(ctx,CAfile,CAdir);
SSL_CTX_set_verify(ctx, SSL_VERIFY_PEER, NULL);
RETVAL = newSViv(1);
}
OUTPUT:
RETVAL
MODULE = Crypt::SSLeay PACKAGE = Crypt::SSLeay::Conn PREFIX = SSL_
SSL*
SSL_new(packname, ctx, debug, ...)
SV* packname
SSL_CTX* ctx
SV* debug
PREINIT:
SSL* ssl;
CODE:
ssl = SSL_new(ctx);
SSL_set_connect_state(ssl);
/* The set mode is necessary so the SSL connection can
* survive a renegotiated cipher that results from
* modssl VerifyClient config changing between
* VirtualHost & some other config block. At modssl
* this would be a [trace] ssl message:
* "Changed client verification type will force renegotiation"
* -- jc 6/28/2001
*/
#ifdef SSL_MODE_AUTO_RETRY
SSL_set_mode(ssl, SSL_MODE_AUTO_RETRY);
#endif
RETVAL = ssl;
if(SvTRUE(debug)) {
SSL_set_info_callback(RETVAL,InfoCallback);
}
if (items > 2) {
PerlIO* io = IoIFP(sv_2io(ST(3)));
#ifdef _WIN32
SSL_set_fd(RETVAL, _get_osfhandle(PerlIO_fileno(io)));
#else
SSL_set_fd(RETVAL, PerlIO_fileno(io));
#endif
}
OUTPUT:
RETVAL
void
SSL_free(ssl)
SSL* ssl
int
SSL_pending(ssl)
SSL* ssl
int
SSL_set_fd(ssl,fd)
SSL* ssl
int fd
int
SSL_connect(ssl)
SSL* ssl
int
SSL_accept(ssl)
SSL* ssl
SV*
SSL_write(ssl, buf, ...)
SSL* ssl
PREINIT:
STRLEN blen;
int len;
int offset = 0;
int keep_trying_to_write = 1;
INPUT:
char* buf = SvPV(ST(1), blen);
CODE:
if (items > 2) {
len = SvOK(ST(2)) ? SvIV(ST(2)) : blen;
if (items > 3) {
offset = SvIV(ST(3));
if (offset < 0) {
if (-offset > blen)
croak("Offset outside string");
offset += blen;
}
else if (offset >= blen && blen > 0)
croak("Offset outside string");
}
if (len > blen - offset)
len = blen - offset;
}
else {
len = blen;
}
/* try to handle incomplete writes properly
* see RT bug #64054 and RT bug #78695
* 2012/08/02: Stop trying to distinguish between good & bad
* zero returns from underlying SSL_read/SSL_write
*/
while (keep_trying_to_write)
{
int n = SSL_write(ssl, buf+offset, len);
int x = SSL_get_error(ssl, n);
if ( n >= 0 )
{
keep_trying_to_write = 0;
RETVAL = newSViv(n);
}
else
{
if
(
(x != SSL_ERROR_WANT_READ) &&
(x != SSL_ERROR_WANT_WRITE)
)
{
keep_trying_to_write = 0;
RETVAL = &PL_sv_undef;
}
}
}
OUTPUT:
RETVAL
SV*
SSL_read(ssl, buf, len,...)
SSL* ssl
int len
PREINIT:
char *buf;
STRLEN blen;
int offset = 0;
int keep_trying_to_read = 1;
INPUT:
SV* sv = ST(1);
CODE:
buf = SvPV_force(sv, blen);
if (items > 3) {
offset = SvIV(ST(3));
if (offset < 0) {
if (-offset > blen)
croak("Offset outside string");
offset += blen;
}
/* this is not a very efficient method of appending
* (offset - blen) NUL bytes, but it will probably
* seldom happen.
*/
while (offset > blen) {
sv_catpvn(sv, "\0", 1);
blen++;
}
}
if (len < 0)
croak("Negative length");
SvGROW(sv, offset + len + 1);
buf = SvPVX(sv); /* it might have been relocated */
/* try to handle incomplete writes properly
* see RT bug #64054 and RT bug #78695
* 2012/08/02: Stop trying to distinguish between good & bad
* zero returns from underlying SSL_read/SSL_write
*/
while (keep_trying_to_read) {
int n = SSL_read(ssl, buf+offset, len);
int x = SSL_get_error(ssl, n);
if ( n >= 0 )
{
SvCUR_set(sv, offset + n);
buf[offset + n] = '\0';
keep_trying_to_read = 0;
RETVAL = newSViv(n);
}
else
{
if
(
(x != SSL_ERROR_WANT_READ) &&
(x != SSL_ERROR_WANT_WRITE)
)
{
keep_trying_to_read = 0;
RETVAL = &PL_sv_undef;
}
}
}
OUTPUT:
RETVAL
X509*
SSL_get_peer_certificate(ssl)
SSL* ssl
SV*
SSL_get_verify_result(ssl)
SSL* ssl
CODE:
RETVAL = newSViv((SSL_get_verify_result(ssl) == X509_V_OK) ? 1 : 0);
OUTPUT:
RETVAL
#define CRYPT_SSLEAY_SHARED_CIPHERS_BUFSIZE 512
char*
SSL_get_shared_ciphers(ssl)
SSL* ssl
PREINIT:
char buf[ CRYPT_SSLEAY_SHARED_CIPHERS_BUFSIZE ];
CODE:
RETVAL = SSL_get_shared_ciphers(
ssl, buf, CRYPT_SSLEAY_SHARED_CIPHERS_BUFSIZE
);
OUTPUT:
RETVAL
char*
SSL_get_cipher(ssl)
SSL* ssl
CODE:
RETVAL = (char*) SSL_get_cipher(ssl);
OUTPUT:
RETVAL
#if OPENSSL_VERSION_NUMBER >= 0x0090806fL && !defined(OPENSSL_NO_TLSEXT)
void
SSL_set_tlsext_host_name(ssl, name)
SSL *ssl
const char *name
#endif
MODULE = Crypt::SSLeay PACKAGE = Crypt::SSLeay::X509 PREFIX = X509_
void
X509_free(cert)
X509* cert
SV*
subject_name(cert)
X509* cert
PREINIT:
char* str;
CODE:
str = X509_NAME_oneline(X509_get_subject_name(cert), NULL, 0);
RETVAL = newSVpv(str, 0);
CRYPT_SSLEAY_free(str);
OUTPUT:
RETVAL
SV*
issuer_name(cert)
X509* cert
PREINIT:
char* str;
CODE:
str = X509_NAME_oneline(X509_get_issuer_name(cert), NULL, 0);
RETVAL = newSVpv(str, 0);
CRYPT_SSLEAY_free(str);
OUTPUT:
RETVAL
char *
get_notBeforeString(cert)
X509* cert
CODE:
RETVAL = (char *)X509_get_notBefore(cert)->data;
OUTPUT:
RETVAL
char *
get_notAfterString(cert)
X509* cert
CODE:
RETVAL = (char *)X509_get_notAfter(cert)->data;
OUTPUT:
RETVAL
MODULE = Crypt::SSLeay PACKAGE = Crypt::SSLeay::Version PREFIX = VERSION_
const char *
VERSION_openssl_version()
CODE:
RETVAL = SSLeay_version(SSLEAY_VERSION);
OUTPUT:
RETVAL
long
VERSION_openssl_version_number()
CODE:
RETVAL = OPENSSL_VERSION_NUMBER;
OUTPUT:
RETVAL
const char *
VERSION_openssl_cflags()
CODE:
RETVAL = SSLeay_version(SSLEAY_CFLAGS);
OUTPUT:
RETVAL
const char *
VERSION_openssl_platform()
CODE:
RETVAL = SSLeay_version(SSLEAY_PLATFORM);
OUTPUT:
RETVAL
const char *
VERSION_openssl_built_on()
CODE:
RETVAL = SSLeay_version(SSLEAY_BUILT_ON);
OUTPUT:
RETVAL
const char *
VERSION_openssl_dir()
CODE:
RETVAL = SSLeay_version(SSLEAY_DIR);
OUTPUT:
RETVAL
build/perl_modules_req.txt
View file @ 971eb4d6
IPC::Shareable 1.13
Crypt::SSLeay 0.72
Crypt::OpenSSL::Guess
Crypt::OpenSSL::Random
Crypt::OpenSSL::Bignum
Crypt::OpenSSL::RSA
AnyEvent 7.17
Path::Class Path::Class
ExtUtils::CBuilder ExtUtils::CBuilder
Imager::File::PNG 0.99|--configure-args="--libpath=/opt/thirdlane/perl_lib/local/usr/lib --incpath=/opt/thirdlane/perl_lib/local/usr/include" Imager::File::PNG 0.99|--configure-args="--libpath=/opt/thirdlane/perl_lib/local/usr/lib --incpath=/opt/thirdlane/perl_lib/local/usr/include"
AnyEvent 7.17|--notest|--force
Module::CoreList Module::CoreList
Filter::Crypto::CryptFile 2.09 Filter::Crypto::CryptFile 2.09
Crypt::OpenSSL::Guess
Net::SSLeay Net::SSLeay
CryptX 0.044 CryptX 0.044
Crypt::Blowfish Crypt::Blowfish
...@@ -14,10 +19,7 @@ Crypt::Password 0.28|--notest|--force ...@@ -14,10 +19,7 @@ Crypt::Password 0.28|--notest|--force
Crypt::Primes 0.50 Crypt::Primes 0.50
Crypt::RC4 2.02 Crypt::RC4 2.02
Crypt::Random 1.25 Crypt::Random 1.25
Crypt::OpenSSL::RSA
Crypt::OpenSSL::Bignum
UUID 0.28 UUID 0.28
Crypt::SSLeay
Compress::Raw::Zlib 2.087|--notest|--force Compress::Raw::Zlib 2.087|--notest|--force
DBD::mysql DBD::mysql
Convert::ASN1 0.27 Convert::ASN1 0.27
...@@ -45,7 +47,6 @@ Text::QRCode 0.05 ...@@ -45,7 +47,6 @@ Text::QRCode 0.05
HTML::QRCode 0.01 HTML::QRCode 0.01
Imager::QRCode 0.035 Imager::QRCode 0.035
Async::Interrupt 1.25 Async::Interrupt 1.25
IPC::Shareable 0.61
B::Lint 1.20|--notest|--force B::Lint 1.20|--notest|--force
B::FindAmpersand 0.04|--notest|--force B::FindAmpersand 0.04|--notest|--force
Devel::SawAmpersand 0.33|--notest|--force Devel::SawAmpersand 0.33|--notest|--force
...@@ -108,7 +109,6 @@ CPAN::Meta::Requirements 2.140 ...@@ -108,7 +109,6 @@ CPAN::Meta::Requirements 2.140
CPAN::DistnameInfo 0.12 CPAN::DistnameInfo 0.12
YAML::Tiny 1.70 YAML::Tiny 1.70
File::Copy::Recursive 0.38 File::Copy::Recursive 0.38
AnyEvent 7.04
AnyEvent::DBI 2.2 AnyEvent::DBI 2.2
AnyEvent::HTTP 2.15 AnyEvent::HTTP 2.15
App::cpanminus 1.5021 App::cpanminus 1.5021
......
build/test_net_ssleay.pl 0 → 100755
View file @ 971eb4d6
#!/usr/bin/env perl
use Net::SSLeay qw(die_now die_if_ssl_error get_https post_https sslcat make_headers make_form);
Net::SSLeay::load_error_strings();
Net::SSLeay::SSLeay_add_ssl_algorithms(); # Important!
Net::SSLeay::ENGINE_load_builtin_engines(); # If you want built-in engines
Net::SSLeay::ENGINE_register_all_complete(); # If you want built-in engines
Net::SSLeay::randomize();
($page) = get_https('www.bacus.pt', 443, '/'); # Case 1
opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/Shareable.pm
View file @ 971eb4d6
package IPC::Shareable; package IPC::Shareable;
require 5.00503; use warnings;
use strict; use strict;
require 5.00503;
use Carp qw(croak confess carp);
use Data::Dumper;
use IPC::Semaphore; use IPC::Semaphore;
use IPC::Shareable::SharedMem; use IPC::Shareable::SharedMem;
use IPC::SysV qw( use IPC::SysV qw(
IPC_PRIVATE IPC_PRIVATE
IPC_CREAT IPC_CREAT
IPC_EXCL IPC_EXCL
IPC_NOWAIT IPC_NOWAIT
SEM_UNDO SEM_UNDO
); );
use Storable 0.6 qw( use JSON qw(-convert_blessed_universally);
freeze
thaw
);
use Scalar::Util; use Scalar::Util;
use String::CRC32;
use Storable 0.6 qw(freeze thaw);
our $VERSION = '1.13';
use constant {
LOCK_SH => 1,
LOCK_EX => 2,
LOCK_NB => 4,
LOCK_UN => 8,
DEBUGGING => ($ENV{SHAREABLE_DEBUG} or 0),
use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS ); SHM_BUFSIZ => 65536,
SEM_MARKER => 0,
SHM_EXISTS => 1,
$VERSION = 0.61; SHMMAX_BYTES => 1073741824, # 1 GB
use constant LOCK_SH => 1; # Perl sends in a double as opposed to an integer to shmat(), and on some
use constant LOCK_EX => 2; # systems, this causes the IPC system to round down to the maximum integer
use constant LOCK_NB => 4; # size of 0x80000000 we correct that when generating keys with CRC32
use constant LOCK_UN => 8;
MAX_KEY_INT_SIZE => 0x80000000,
EXCLUSIVE_CHECK_LIMIT => 10, # Number of times we'll check for existing segs
};
require Exporter; require Exporter;
@ISA = 'Exporter'; our @ISA = 'Exporter';
@EXPORT = (); our @EXPORT_OK = qw(LOCK_EX LOCK_SH LOCK_NB LOCK_UN);
@EXPORT_OK = qw(LOCK_EX LOCK_SH LOCK_NB LOCK_UN); our %EXPORT_TAGS = (
%EXPORT_TAGS = ( all => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )],
all => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )], lock => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )],
lock => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )], flock => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )],
'flock' => [qw( LOCK_EX LOCK_SH LOCK_NB LOCK_UN )],
); );
Exporter::export_ok_tags('all', 'lock', 'flock'); Exporter::export_ok_tags('all', 'lock', 'flock');
use constant DEBUGGING => ($ENV{SHAREABLE_DEBUG} or 0);
use constant SHM_BUFSIZ => 65536;
use constant SEM_MARKER => 0;
use constant SHM_EXISTS => 1;
# Locking scheme copied from IPC::ShareLite -- ltl # Locking scheme copied from IPC::ShareLite -- ltl
my %semop_args = ( my %semop_args = (
(LOCK_EX), (LOCK_EX),
[ [
1, 0, 0, # wait for readers to finish 1, 0, 0, # wait for readers to finish
2, 0, 0, # wait for writers to finish 2, 0, 0, # wait for writers to finish
2, 1, SEM_UNDO, # assert write lock 2, 1, SEM_UNDO, # assert write lock
], ],
(LOCK_EX|LOCK_NB), (LOCK_EX|LOCK_NB),
[ [
1, 0, IPC_NOWAIT, # wait for readers to finish 1, 0, IPC_NOWAIT, # wait for readers to finish
2, 0, IPC_NOWAIT, # wait for writers to finish 2, 0, IPC_NOWAIT, # wait for writers to finish
2, 1, (SEM_UNDO | IPC_NOWAIT), # assert write lock 2, 1, (SEM_UNDO | IPC_NOWAIT), # assert write lock
], ],
(LOCK_EX|LOCK_UN), (LOCK_EX|LOCK_UN),
[ [
2, -1, (SEM_UNDO | IPC_NOWAIT), 2, -1, (SEM_UNDO | IPC_NOWAIT),
], ],
(LOCK_SH), (LOCK_SH),
[ [
2, 0, 0, # wait for writers to finish 2, 0, 0, # wait for writers to finish
1, 1, SEM_UNDO, # assert shared read lock 1, 1, SEM_UNDO, # assert shared read lock
], ],
(LOCK_SH|LOCK_NB), (LOCK_SH|LOCK_NB),
[ [
2, 0, IPC_NOWAIT, # wait for writers to finish 2, 0, IPC_NOWAIT, # wait for writers to finish
1, 1, (SEM_UNDO | IPC_NOWAIT), # assert shared read lock 1, 1, (SEM_UNDO | IPC_NOWAIT), # assert shared read lock
], ],
(LOCK_SH|LOCK_UN), (LOCK_SH|LOCK_UN),
[ [
1, -1, (SEM_UNDO | IPC_NOWAIT), # remove shared read lock 1, -1, (SEM_UNDO | IPC_NOWAIT), # remove shared read lock
], ],
); );
my %Def_Opts = ( my %default_options = (
key => IPC_PRIVATE, key => IPC_PRIVATE,
create => '', create => 0,
exclusive => '', exclusive => 0,
destroy => '', destroy => 0,
mode => 0666, mode => 0666,
size => SHM_BUFSIZ, size => SHM_BUFSIZ,
); protected => 0,
limit => 1,
# XXX Perl seems to garbage collect nested referents before we're done with them graceful => 0,
# XXX This cache holds a reference to things until END() is called warn => 0,
tidy => 0,
serializer => 'storable',
);
my %Global_Reg; my %global_register;
my %Proc_Reg; my %process_register;
my %used_ids;
sub _trace; sub _trace;
sub _debug; sub _debug;
###############################################################################
# Debug mark
# --- Public methods
sub shlock {
_trace @_ if DEBUGGING;
my ($self, $typelock) = @_;
($typelock = LOCK_EX) unless defined $typelock;
return $self->shunlock if ($typelock & LOCK_UN);
return 1 if ($self->{_lock} & $typelock);
# If they have a different lock than they want, release it first
$self->shunlock if ($self->{_lock});
my $sem = $self->{_sem};
_debug "Attempting type=", $typelock, " lock on", $self->{_shm},
"via", $sem->id if DEBUGGING;
my $return_val = $sem->op(@{ $semop_args{$typelock} });
if ($return_val) {
$self->{_lock} = $typelock;
_debug "Got lock on", $self->{_shm}, "via", $sem->id if DEBUGGING;
$self->{_data} = _thaw($self->{_shm}),
} else {
_debug "Failed lock on", $self->{_shm}, "via", $sem->id if DEBUGGING;
}
return $return_val;
}
sub shunlock {
_trace @_ if DEBUGGING;
my $self = shift;
return 1 unless $self->{_lock};
if ($self->{_was_changed}) {
defined _freeze($self->{_shm} => $self->{_data}) or do {
require Carp;
Carp::croak "Could not write to shared memory: $!\n";
};
$self->{_was_changed} = 0;
}
my $sem = $self->{_sem};
_debug "Freeing lock on", $self->{_shm}, "via", $sem->id if DEBUGGING;
my $typelock = $self->{_lock} | LOCK_UN;
$typelock ^= LOCK_NB if ($typelock & LOCK_NB);
$sem->op(@{ $semop_args{$typelock} });
$self->{_lock} = 0;
_debug "Lock on", $self->{_shm}, "via", $sem->id, "freed" if DEBUGGING;
1;
}
# --- "Magic" methods # --- "Magic" methods
sub TIESCALAR { sub TIESCALAR {
_trace @_ if DEBUGGING; return _tie('SCALAR', @_);
return _tie(SCALAR => @_);
} }
sub TIEARRAY { sub TIEARRAY {
_trace @_ if DEBUGGING; return _tie('ARRAY', @_);
return _tie(ARRAY => @_); }
}
sub TIEHASH { sub TIEHASH {
_trace @_ if DEBUGGING; return _tie('HASH', @_);
return _tie(HASH => @_);
} }
sub STORE { sub STORE {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
if (! exists $global_register{$knot->seg->id}) {
my $sid = $self->{_shm}->{_id}; $global_register{$knot->seg->id} = $knot;
}
$Global_Reg{$self->{_shm}->id} ||= $self;
$knot->{_data} = $knot->_decode($knot->seg) unless ($knot->{_lock});
$self->{_data} = _thaw($self->{_shm}) unless ($self->{_lock});
TYPE: { if ($knot->{_type} eq 'HASH') {
if ($self->{_type} eq 'SCALAR') { my ($key, $val) = @_;
my $val = shift; _mg_tie($knot, $val, $key) if $knot->_need_tie($val, $key);
_mg_tie($self => $val) if _need_tie($val); $knot->{_data}{$key} = $val;
$self->{_data} = \$val; }
last TYPE; elsif ($knot->{_type} eq 'ARRAY') {
} my ($i, $val) = @_;
if ($self->{_type} eq 'ARRAY') { _mg_tie($knot, $val, $i) if $knot->_need_tie($val, $i);
my $i = shift; $knot->{_data}[$i] = $val;
my $val = shift; }
_mg_tie($self => $val) if _need_tie($val); elsif ($knot->{_type} eq 'SCALAR') {
$self->{_data}->[$i] = $val; my ($val) = @_;
last TYPE; _mg_tie($knot, $val) if $knot->_need_tie($val);
} $knot->{_data} = \$val;
if ($self->{_type} eq 'HASH') { }
my $key = shift; else {
my $val = shift; croak "Variables of type $knot->{_type} not supported";
_mg_tie($self => $val) if _need_tie($val); }
$self->{_data}->{$key} = $val;
last TYPE; if ($knot->{_lock} & LOCK_EX) {
} $knot->{_was_changed} = 1;
require Carp;
Carp::croak "Variables of type $self->{_type} not supported";
}
if ($self->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!\n";
Carp::croak "Could not write to shared memory: $!\n"; }
};
} }
return 1; return 1;
} }
sub FETCH { sub FETCH {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
$Global_Reg{$self->{_shm}->id} ||= $self; if (! exists $global_register{$knot->seg->id}) {
$global_register{$knot->seg->id} = $knot;
}
my $data; my $data;
if ($self->{_lock} || $self->{_iterating}) { if ($knot->{_lock} || $knot->{_iterating}) {
$self->{_iterating} = ''; # In case we break out $knot->{_iterating} = 0; # In case we break out
$data = $self->{_data}; $data = $knot->{_data};
} else { } else {
$data = _thaw($self->{_shm}); $data = $knot->_decode($knot->seg);
$self->{_data} = $data; $knot->{_data} = $data;
} }
my $val; my $val;
TYPE: {
if ($self->{_type} eq 'SCALAR') { if ($knot->{_type} eq 'HASH') {
if (defined $data) { if (defined $data) {
$val = $$data; my $key = shift;
last TYPE; $val = $data->{$key};
} else { } else {
return; return;
} }
} }
if ($self->{_type} eq 'ARRAY') { elsif ($knot->{_type} eq 'ARRAY') {
if (defined $data) { if (defined $data) {
my $i = shift; my $i = shift;
$val = $data->[$i]; $val = $data->[$i];
last TYPE; } else {
} else { return;
return; }
} }
} elsif ($knot->{_type} eq 'SCALAR') {
if ($self->{_type} eq 'HASH') { if (defined $data) {
if (defined $data) { $val = $$data;
my $key = shift; } else {
$val = $data->{$key}; return;
last TYPE; }
} else { }
return; else {
} croak "Variables of type $knot->{_type} not supported";
} }
require Carp;
Carp::croak "Variables of type $self->{_type} not supported";
}
if (my $inner = _is_kid($val)) { if (my $inner = _is_kid($val)) {
my $s = $inner->{_shm}; my $s = $inner->seg;
$inner->{_data} = _thaw($s); $inner->{_data} = $knot->_decode($s);
} }
return $val; return $val;
} }
sub CLEAR { sub CLEAR {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
if ($self->{_type} eq 'ARRAY') { if ($knot->{_type} eq 'HASH') {
$self->{_data} = [ ]; $knot->{_data} = { };
} elsif ($self->{_type} eq 'HASH') { }
$self->{_data} = { }; elsif ($knot->{_type} eq 'ARRAY') {
} else { $knot->{_data} = [ ];
require Carp; }
Carp::croak "Attempt to clear non-aggegrate";
else {
croak "Attempt to clear non-aggegrate";
} }
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!"; }
};
} }
} }
sub DELETE { sub DELETE {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
my $key = shift; my $key = shift;
$self->{_data} = _thaw($self->{_shm}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
my $val = delete $self->{_data}->{$key}; my $val = delete $knot->{_data}->{$key};
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!"; }
};
} }
return $val; return $val;
} }
sub EXISTS { sub EXISTS {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
my $key = shift; my $key = shift;
$self->{_data} = _thaw($self->{_shm}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
return exists $self->{_data}->{$key}; return exists $knot->{_data}->{$key};
} }
sub FIRSTKEY { sub FIRSTKEY {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
my $key = shift;
_debug "setting hash iterator on", $self->{_shm}->id if DEBUGGING; $knot->{_iterating} = 1;
$self->{_iterating} = 1; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
$self->{_data} = _thaw($self->{_shm}) unless $self->{_lock}; my $reset = keys %{$knot->{_data}};
my $reset = keys %{$self->{_data}}; my $first = each %{$knot->{_data}};
my $first = each %{$self->{_data}};
return $first; return $first;
} }
sub NEXTKEY { sub NEXTKEY {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
# caveat emptor if hash was changed by another process # caveat emptor if hash was changed by another process
my $next = each %{$self->{_data}}; my $next = each %{$knot->{_data}};
if (not defined $next) { if (not defined $next) {
_debug "resetting hash iterator on", $self->{_shm}->id if DEBUGGING; $knot->{_iterating} = 0;
$self->{_iterating} = '';
return; return;
} else { } else {
$self->{_iterating} = 1; $knot->{_iterating} = 1;
return $next; return $next;
} }
} }
sub EXTEND { sub EXTEND {
_trace @_ if DEBUGGING;
#XXX Noop #XXX Noop
} }
sub PUSH { sub PUSH {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
if (! exists $global_register{$knot->seg->id}) {
$global_register{$knot->seg->id} = $knot;
}
$Global_Reg{$self->{_shm}->id} ||= $self; $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
$self->{_data} = _thaw($self->{_shm}, $self->{_data}) unless $self->{_lock};
push @{$self->{_data}} => @_; push @{$knot->{_data}}, @_;
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!";
}; };
} }
} }
sub POP { sub POP {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
$self->{_data} = _thaw($self->{_shm}, $self->{_data}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
my $val = pop @{$self->{_data}}; my $val = pop @{$knot->{_data}};
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!"; }
};
} }
return $val; return $val;
} }
sub SHIFT { sub SHIFT {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
$self->{_data} = _thaw($self->{_shm}, $self->{_data}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
my $val = shift @{$self->{_data}}; my $val = shift @{$knot->{_data}};
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!"; }
};
} }
return $val; return $val;
} }
sub UNSHIFT { sub UNSHIFT {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
$self->{_data} = _thaw($self->{_shm}, $self->{_data}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
my $val = unshift @{$self->{_data}} => @_; my $val = unshift @{$knot->{_data}}, @_;
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!"; }
};
} }
return $val; return $val;
} }
sub SPLICE { sub SPLICE {
_trace @_ if DEBUGGING; my($knot, $off, $n, @av) = @_;
my($self, $off, $n, @av) = @_;
$self->{_data} = _thaw($self->{_shm}, $self->{_data}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg, $knot->{_data}) unless $knot->{_lock};
my @val = splice @{$self->{_data}}, $off, $n => @av; my @val = splice @{$knot->{_data}}, $off, $n, @av;
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!"; }
};
} }
return @val; return @val;
} }
sub FETCHSIZE { sub FETCHSIZE {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
$self->{_data} = _thaw($self->{_shm}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
return scalar(@{$self->{_data}}); return scalar(@{$knot->{_data}});
} }
sub STORESIZE { sub STORESIZE {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
my $n = shift; my $n = shift;
$self->{_data} = _thaw($self->{_shm}) unless $self->{_lock}; $knot->{_data} = $knot->_decode($knot->seg) unless $knot->{_lock};
$#{$self->{_data}} = $n - 1; $#{$knot->{_data}} = $n - 1;
if ($self->{_lock} & LOCK_EX) { if ($knot->{_lock} & LOCK_EX) {
$self->{_was_changed} = 1; $knot->{_was_changed} = 1;
} else { } else {
defined _freeze($self->{_shm} => $self->{_data}) or do { if (! defined $knot->_encode($knot->seg, $knot->{_data})){
require Carp; croak "Could not write to shared memory: $!";
Carp::croak "Could not write to shared memory: $!"; }
};
} }
return $n; return $n;
} }
# --- Public methods
sub new {
my ($class, %opts) = @_;
my $type = $opts{var} || 'HASH';
if ($type eq 'HASH') {
my $k = tie my %h, 'IPC::Shareable', \%opts;
return \%h;
}
if ($type eq 'ARRAY') {
my $k = tie my @a, 'IPC::Shareable', \%opts;
return \@a;
}
if ($type eq 'SCALAR') {
my $k = tie my $s, 'IPC::Shareable', \%opts;
return \$s;
}
}
sub global_register {
# This is a ridiculous way to do this, but if we don't call Dumper, hashes
# that are created in a separate process than the parent hash don't
# show up properly in the global register. t/81
local $SIG{__WARN__} = sub {
my ($warning) = @_;
if ($warning !~ /hash after insertion/) {
warn $warning;
}
};
Dumper \%global_register;
return \%global_register;
}
sub process_register {
return \%process_register;
}
sub attributes {
my ($knot, $attr) = @_;
my $attrs = $knot->{attributes};
if (defined $attr) {
return $knot->{attributes}{$attr};
}
else {
return $knot->{attributes};
}
}
sub ipcs {
my $count = `ipcs -m | wc -l`;
chomp $count;
return int($count);
}
sub lock {
my ($knot, $flags) = @_;
$flags = LOCK_EX if ! defined $flags;
return $knot->unlock if ($flags & LOCK_UN);
return 1 if ($knot->{_lock} & $flags);
# If they have a different lock than they want, release it first
$knot->unlock if ($knot->{_lock});
my $sem = $knot->sem;
my $return_val = $sem->op(@{ $semop_args{$flags} });
if ($return_val) {
$knot->{_lock} = $flags;
$knot->{_data} = $knot->_decode($knot->seg),
}
return $return_val;
}
sub unlock {
my $knot = shift;
return 1 unless $knot->{_lock};
if ($knot->{_was_changed}) {
if (! defined $knot->_encode($knot->seg, $knot->{_data})){
croak "Could not write to shared memory: $!\n";
}
$knot->{_was_changed} = 0;
}
my $sem = $knot->sem;
my $flags = $knot->{_lock} | LOCK_UN;
$flags ^= LOCK_NB if ($flags & LOCK_NB);
$sem->op(@{ $semop_args{$flags} });
$knot->{_lock} = 0;
1;
}
*shlock = \&lock;
*shunlock = \&unlock;
sub clean_up { sub clean_up {
_trace @_ if DEBUGGING;
my $class = shift; my $class = shift;
for my $s (values %Proc_Reg) { for my $id (keys %process_register) {
next unless $s->{_opts}->{_owner} == $$; my $s = $process_register{$id};
next unless $s->attributes('owner') == $$;
next if $s->attributes('protected');
remove($s); remove($s);
} }
} }
sub clean_up_all { sub clean_up_all {
_trace @_ if DEBUGGING;
my $class = shift; my $class = shift;
for my $s (values %Global_Reg) { my $global_register = __PACKAGE__->global_register;
for my $id (keys %$global_register) {
my $s = $global_register->{$id};
next if $s->attributes('protected');
remove($s); remove($s);
} }
} }
sub clean_up_protected {
my ($knot, $protect_key);
if (scalar @_ == 2) {
($knot, $protect_key) = @_;
}
if (scalar @_ == 1) {
($protect_key) = @_;
}
if (! defined $protect_key) {
croak "clean_up_protected() requires a \$protect_key param";
}
if ($protect_key !~ /^\d+$/) {
croak
"clean_up_protected() \$protect_key must be an integer. You sent $protect_key";
}
my $global_register = __PACKAGE__->global_register;
for my $id (keys %$global_register) {
my $s = $global_register->{$id};
my $stored_key = $s->attributes('protected');
if ($stored_key && $stored_key == $protect_key) {
remove($s);
}
}
}
sub remove { sub remove {
_trace @_ if DEBUGGING; my $knot = shift;
my $self = shift;
my $s = $self->{_shm}; my $s = $knot->seg;
my $id = $s->id; my $id = $s->id;
$s->remove or do { $s->remove or warn "Couldn't remove shared memory segment $id: $!";
require Carp;
Carp::carp "Couldn't remove shared memory segment $id: $!"; $s = $knot->sem;
};
$s->remove or warn "Couldn't remove semaphore set $id: $!";
$s = $self->{_sem};
$s->remove or do { delete $process_register{$id};
require Carp; delete $global_register{$id};
Carp::carp "Couldn't remove semaphore set $id: $!"; }
sub seg {
my ($knot) = @_;
return $knot->{_shm} if defined $knot->{_shm};
}
sub sem {
my ($knot) = @_;
return $knot->{_sem} if defined $knot->{_sem};
}
sub singleton {
# If called with IPC::Shareable::singleton() as opposed to
# IPC::Shareable->singleton(), the class isn't sent in. Check
# for this and fix it if necessary
if (! defined $_[0] || $_[0] ne __PACKAGE__) {
unshift @_, __PACKAGE__;
}
my ($class, $glue, $warn) = @_;
if (! defined $glue) {
croak "singleton() requires a GLUE parameter";
}
$warn = 0 if ! defined $warn;
tie my $lock, 'IPC::Shareable', {
key => $glue,
create => 1,
exclusive => 1,
graceful => 1,
destroy => 1,
warn => $warn
}; };
delete $Proc_Reg{$id};
delete $Global_Reg{$id}; return $$;
} }
END { END {
_trace @_ if DEBUGGING; _end();
for my $s (values %Proc_Reg) { }
shunlock($s);
next unless $s->{_opts}->{destroy}; # --- Private methods below
next unless $s->{_opts}->{_owner} == $$;
sub _encode {
my ($knot, $seg, $data) = @_;
my $serializer = $knot->attributes('serializer');
if ($serializer eq 'storable') {
return _freeze($seg, $data);
}
elsif ($serializer eq 'json'){
return _encode_json($seg, $data);
}
return undef;
}
sub _end {
for my $s (values %process_register) {
unlock($s);
next if $s->attributes('protected');
next if ! $s->attributes('destroy');
next if $s->attributes('owner') != $$;
remove($s); remove($s);
} }
} }
sub _decode {
my ($knot, $seg) = @_;
# --- Private methods below my $serializer = $knot->attributes('serializer');
if ($serializer eq 'storable') {
return _thaw($seg);
}
elsif ($serializer eq 'json'){
return _decode_json($seg);
}
return undef;
}
sub _encode_json {
my $seg = shift;
my $data = shift;
my $json = encode_json $data;
if (length($json) > $seg->size) {
croak "Length of shared data exceeds shared segment size";
}
$seg->shmwrite($json);
}
sub _decode_json {
my $seg = shift;
my $json = $seg->shmread;
return if ! $json;
# Remove \x{0} after end of string (broke JSON)
$json =~ s/\x00+//;
# my $tag = substr $json, 0, 14, '';
# if ($tag eq 'IPC::Shareable') {
my $data = decode_json $json;
if (! defined($data)){
croak "Munged shared memory segment (size exceeded?)";
}
return $data;
# } else {
# return;
# }
}
sub _freeze { sub _freeze {
_trace @_ if DEBUGGING; my $seg = shift;
my $s = shift;
my $water = shift; my $water = shift;
my $ice = freeze $water; my $ice = freeze $water;
# Could be a large string. No need to copy it. substr more efficient # Could be a large string. No need to copy it. substr more efficient
substr $ice, 0, 0, 'IPC::Shareable'; substr $ice, 0, 0, 'IPC::Shareable';
_debug "writing to shm segment ", $s->id, ": ", $ice if DEBUGGING; if (length($ice) > $seg->size) {
if (length($ice) > $s->size) { croak "Length of shared data exceeds shared segment size";
require Carp; }
Carp::croak "Length of shared data exceeds shared segment size"; $seg->shmwrite($ice);
};
$s->shmwrite($ice);
} }
sub _thaw { sub _thaw {
_trace @_ if DEBUGGING; my $seg = shift;
my $s = shift;
my $ice = $seg->shmread;
my $ice = $s->shmread; return if ! $ice;
_debug "read from shm segment ", $s->id, ": ", $ice if DEBUGGING;
my $tag = substr $ice, 0, 14, ''; my $tag = substr $ice, 0, 14, '';
if ($tag eq 'IPC::Shareable') { if ($tag eq 'IPC::Shareable') {
my $water = thaw $ice; my $water = thaw $ice;
defined($water) or do { if (! defined($water)){
require Carp; croak "Munged shared memory segment (size exceeded?)";
Carp::croak "Munged shared memory segment (size exceeded?)"; }
};
return $water; return $water;
} else { } else {
return; return;
} }
} }
sub _tie { sub _tie {
_trace @_ if DEBUGGING; my ($type, $class, $key_str, $opts);
my $type = shift;
my $class = shift;
my $opts = _parse_args(@_);
my $key = _shm_key($opts); if (scalar @_ == 4) {
my $flags = _shm_flags($opts); ($type, $class, $key_str, $opts) = @_;
my $shm_size = $opts->{size}; $opts->{key} = $key_str;
}
else {
($type, $class, $opts) = @_;
}
my $s = IPC::Shareable::SharedMem->new($key, $shm_size, $flags); $opts = _parse_args($opts);
defined $s or do {
require Carp; my $knot = bless { attributes => $opts }, $class;
Carp::croak "Could not create shared memory segment: $!\n";
}; my $key = $knot->_shm_key;
_debug "shared memory id is", $s->id if DEBUGGING; my $flags = $knot->_shm_flags;
my $shm_size = $knot->attributes('size');
if ($knot->attributes('limit') && $shm_size > SHMMAX_BYTES) {
croak
"Shared memory segment size '$shm_size' is larger than max size of " .
SHMMAX_BYTES;
}
my $seg;
if ($knot->attributes('graceful')) {
my $exclusive = eval {
$seg = IPC::Shareable::SharedMem->new($key, $shm_size, $flags);
1;
};
if (! defined $exclusive) {
if ($knot->attributes('warn')) {
my $key = lc(sprintf("0x%X", $knot->_shm_key));
warn "Process ID $$ exited due to exclusive shared memory collision at segment/semaphore key '$key'\n";
}
exit(0);
}
}
else {
$seg = IPC::Shareable::SharedMem->new($key, $shm_size, $flags);
}
if (! defined $seg) {
if ($! =~ /Cannot allocate memory/) {
croak "\nERROR: Could not create shared memory segment: $!\n\n" .
"Are you using too large a size?";
}
if ($! =~ /No space left on device/) {
croak "\nERROR: Could not create shared memory segment: $!\n\n" .
"Are you spawning too many segments in a loop?";
}
if (! $knot->attributes('create')) {
confess "ERROR: Could not acquire shared memory segment... 'create' ".
"option is not set, and the segment hasn't been created " .
"yet:\n\n $!";
}
elsif ($knot->attributes('create') && $knot->attributes('exclusive')){
croak "ERROR: Could not create shared memory segment. 'create' " .
"and 'exclusive' are set. Does the segment already exist? " .
"\n\n$!";
}
else {
croak "ERROR: Could not create shared memory segment.\n\n$!";
}
}
my $sem = IPC::Semaphore->new($key, 3, $flags); my $sem = IPC::Semaphore->new($key, 3, $flags);
defined $sem or do { if (! defined $sem){
require Carp; croak "Could not create semaphore set: $!\n";
Carp::croak "Could not create semaphore set: $!\n"; }
};
_debug "semaphore id is", $sem->id if DEBUGGING; if (! $sem->op(@{ $semop_args{(LOCK_SH)} }) ) {
croak "Could not obtain semaphore set lock: $!\n";
unless ( $sem->op(@{ $semop_args{(LOCK_SH)} }) ) { }
require Carp;
Carp::croak "Could not obtain semaphore set lock: $!\n"; %$knot = (
} %$knot,
my $sh = { _iterating => 0,
_iterating => '', _key => $key,
_key => $key, _lock => 0,
_lock => 0, _shm => $seg,
_opts => $opts, _sem => $sem,
_shm => $s, _type => $type,
_sem => $sem,
_type => $type,
_was_changed => 0, _was_changed => 0,
}; );
$sh->{_data} = _thaw($s),
my $there = $sem->getval(SEM_MARKER); $knot->{_data} = _thaw($seg);
if ($there == SHM_EXISTS) {
_debug "binding to existing segment on ", $s->id if DEBUGGING; if ($sem->getval(SEM_MARKER) != SHM_EXISTS) {
} else {
_debug "brand new segment on ", $s->id if DEBUGGING; if (! exists $global_register{$knot->seg->id}) {
$Proc_Reg{$sh->{_shm}->id} ||= $sh; $global_register{$knot->seg->id} = $knot;
$sem->setval(SEM_MARKER, SHM_EXISTS) or do { }
require Carp;
Carp::croak "Couldn't set semaphore during object creation: $!"; $process_register{$knot->seg->id} ||= $knot;
}; if (! $sem->setval(SEM_MARKER, SHM_EXISTS)){
croak "Couldn't set semaphore during object creation: $!";
}
} }
$sem->op(@{ $semop_args{(LOCK_SH|LOCK_UN)} }); $sem->op(@{ $semop_args{(LOCK_SH|LOCK_UN)} });
_debug "IPC::Shareable instance created:", $sh if DEBUGGING; return $knot;
return bless $sh => $class;
} }
sub _parse_args { sub _parse_args {
_trace @_ if DEBUGGING; my ($opts) = @_;
my($proto, $opts) = @_;
$proto = defined $proto ? $proto : 0; $opts = defined $opts ? $opts : { %default_options };
$opts = defined $opts ? $opts : { %Def_Opts };
if (ref $proto eq 'HASH') { for my $k (keys %default_options) {
$opts = $proto;
} else {
$opts->{key} = $proto;
}
for my $k (keys %Def_Opts) {
if (not defined $opts->{$k}) { if (not defined $opts->{$k}) {
$opts->{$k} = $Def_Opts{$k}; $opts->{$k} = $default_options{$k};
} elsif ($opts->{$k} eq 'no') { }
elsif ($opts->{$k} eq 'no') {
if ($^W) { if ($^W) {
require Carp; require Carp;
Carp::carp("Use of `no' in IPC::Shareable args is obsolete"); Carp::carp("Use of `no' in IPC::Shareable args is obsolete");
} }
$opts->{$k} = ''; $opts->{$k} = 0;
} }
} }
$opts->{_owner} = ($opts->{_owner} or $$); $opts->{owner} = ($opts->{owner} or $$);
$opts->{_magic} = ($opts->{_magic} or ''); $opts->{magic} = ($opts->{magic} or 0);
_debug "options are", $opts if DEBUGGING;
return $opts; return $opts;
} }
sub _shm_key { sub _shm_key {
_trace @_ if DEBUGGING; # Generates a 32-bit CRC on the key string. The $key_str parameter is used
my $hv = shift; # for testing only, for purposes of testing various key strings
my $val = ($hv->{key} or '');
my ($knot, $key_str) = @_;
if ($val eq '') {
return IPC_PRIVATE; $key_str //= ($knot->attributes('key') || '');
} elsif ($val =~ /^\d+$/) {
return $val; my $key;
} else {
# XXX This only uses the first four characters if ($key_str eq '') {
$val = pack A4 => $val; $key = IPC_PRIVATE;
$val = unpack i => $val; }
return $val; elsif ($key_str =~ /^\d+$/) {
$key = $key_str;
}
else {
$key = crc32($key_str);
}
$used_ids{$key}++;
if ($key > MAX_KEY_INT_SIZE) {
$key = $key - MAX_KEY_INT_SIZE;
if ($key == 0) {
croak "We've calculated a key which equals 0. This is a fatal error";
}
}
return $key;
}
sub _shm_key_rand {
my $key;
# Unfortunatly, the only way I know how to check if a segment exists is
# to actually create it. We must do that here, then remove it just to
# ensure the slot is available
my $verified_exclusive = 0;
my $check_count = 0;
while (! $verified_exclusive && $check_count < EXCLUSIVE_CHECK_LIMIT) {
$check_count++;
$key = _shm_key_rand_int();
next if $used_ids{$key};
my $flags;
$flags |= IPC_CREAT;
$flags |= IPC_EXCL;
my $seg;
my $shm_slot_available = eval {
$seg = IPC::Shareable::SharedMem->new($key, 1, $flags);
1;
};
if ($shm_slot_available) {
$verified_exclusive = 1;
$seg->remove if $seg;
}
}
if (! $verified_exclusive) {
croak
"_shm_key_rand() can't get an available key after $check_count tries";
} }
$used_ids{$key}++;
return $key;
}
sub _shm_key_rand_int {
srand();
return int(rand(1_000_000));
} }
sub _shm_flags { sub _shm_flags {
# --- Parses the anonymous hash passed to constructors; returns a list # --- Parses the anonymous hash passed to constructors; returns a list
# --- of args suitable for passing to shmget # --- of args suitable for passing to shmget
_trace @_ if DEBUGGING; my ($knot) = @_;
my $hv = shift;
my $flags = 0; my $flags = 0;
$flags |= IPC_CREAT if $hv->{create}; $flags |= IPC_CREAT if $knot->attributes('create');
$flags |= IPC_EXCL if $hv->{exclusive}; $flags |= IPC_EXCL if $knot->attributes('exclusive');;
$flags |= ($hv->{mode} or 0666); $flags |= ($knot->attributes('mode') or 0666);
return $flags; return $flags;
} }
sub _mg_tie { sub _mg_tie {
_trace @_ if DEBUGGING; my ($parent, $val, $identifier) = @_;
my $dad = shift;
my $val = shift;
# XXX How to generate a unique id ?
my $key; my $key;
if ($dad->{_key} == IPC_PRIVATE) {
if ($parent->{_key} == IPC_PRIVATE) {
$key = IPC_PRIVATE; $key = IPC_PRIVATE;
} else {
$key = int(rand(1_000_000));
} }
else {
$key = _shm_key_rand();
}
my %opts = ( my %opts = (
%{$dad->{_opts}}, %{ $parent->attributes },
key => $key, key => $key,
exclusive => 'yes', exclusive => 1,
create => 'yes', create => 1,
_magic => 'yes' magic => 1,
); );
# XXX I wish I didn't have to take a copy of data here and copy it back in # XXX I wish I didn't have to take a copy of data here and copy it back in
# XXX Also, have to peek inside potential objects to see their implementation # XXX Also, have to peek inside potential objects to see their implementation
my $kid; my $child;
my $type = Scalar::Util::reftype( $val ) || ''; my $type = Scalar::Util::reftype($val) || '';
if ($type eq "SCALAR") {
my $copy = $$val; if ($type eq "HASH") {
$kid = tie $$val => 'IPC::Shareable', $key, { %opts } or do {
require Carp;
Carp::croak "Could not create inner tie";
};
$$val = $copy;
} elsif ($type eq "ARRAY") {
my @copy = @$val;
$kid = tie @$val => 'IPC::Shareable', $key, { %opts } or do {
require Carp;
Carp::croak "Could not create inner tie";
};
@$val = @copy;
} elsif ($type eq "HASH") {
my %copy = %$val; my %copy = %$val;
$kid = tie %$val => 'IPC::Shareable', $key, { %opts } or do { $child = tie %$val, 'IPC::Shareable', $key, { %opts };
require Carp; croak "Could not create inner tie" if ! $child;
Carp::croak "Could not create inner tie";
}; _reset_segment($parent, $identifier) if $opts{tidy};
%$val = %copy; %$val = %copy;
} else {
require Carp;
Carp::croak "Variables of type $type not implemented";
} }
elsif ($type eq "ARRAY") {
my @copy = @$val;
$child = tie @$val, 'IPC::Shareable', $key, { %opts };
croak "Could not create inner tie" if ! $child;
return $kid; _reset_segment($parent, $identifier) if $opts{tidy};
}
@$val = @copy;
}
elsif ($type eq "SCALAR") {
my $copy = $$val;
$child = tie $$val, 'IPC::Shareable', $key, { %opts };
croak "Could not create inner tie" if ! $child;
$$val = $copy;
}
else {
croak "Variables of type $type not implemented";
}
return $child;
}
sub _is_kid { sub _is_kid {
my $data = shift or return; my $data = shift or return;
...@@ -733,34 +979,59 @@ sub _is_kid { ...@@ -733,34 +979,59 @@ sub _is_kid {
return unless $type; return unless $type;
my $obj; my $obj;
if ($type eq "HASH") { if ($type eq "HASH") {
$obj = tied %$data; $obj = tied %$data;
} elsif ($type eq "ARRAY") { }
elsif ($type eq "ARRAY") {
$obj = tied @$data; $obj = tied @$data;
} elsif ($type eq "SCALAR") { }
elsif ($type eq "SCALAR") {
$obj = tied $$data; $obj = tied $$data;
} }
if (ref $obj eq 'IPC::Shareable') { if (ref $obj eq 'IPC::Shareable') {
return $obj; return $obj;
} else {
return;
} }
}
return;
}
sub _need_tie { sub _need_tie {
my $val = shift; my ($knot, $val, $identifier) = @_;
my $type = Scalar::Util::reftype( $val ); my $type = Scalar::Util::reftype($val);
return unless $type; return 0 if ! $type;
if ($type eq "SCALAR") {
return !(tied $$val); my $need_tie;
} elsif ($type eq "ARRAY") {
return !(tied @$val); if ($type eq "HASH") {
} elsif ($type eq "HASH") { $need_tie = !(tied %$val);
return !(tied %$val); }
} else { elsif ($type eq "ARRAY") {
return; $need_tie = !(tied @$val);
}
elsif ($type eq "SCALAR") {
$need_tie = !(tied $$val);
}
return $need_tie ? 1 : 0;
}
sub _reset_segment {
my ($parent, $id) = @_;
my $parent_type = Scalar::Util::reftype($parent->{_data}) || '';
if ($parent_type eq 'HASH') {
my $data = $parent->{_data};
if (exists $data->{$id} && keys %{ $data->{$id} } && tied %{ $data->{$id} }) {
(tied %{ $parent->{_data}{$id} })->remove;
}
}
elsif ($parent_type eq 'ARRAY') {
my $data = $parent->{_data};
if (exists $data->[$id] && tied @{ $data->[$id] }) {
(tied @{ $parent->{_data}[$id] })->remove;
}
} }
} }
...@@ -774,14 +1045,13 @@ sub _trace { ...@@ -774,14 +1045,13 @@ sub _trace {
my $obj; my $obj;
if (ref eq 'IPC::Shareable') { if (ref eq 'IPC::Shareable') {
' ' . "\$_[$i] = $_: shmid: $_->{_shm}->{_id}; " . ' ' . "\$_[$i] = $_: shmid: $_->{_shm}->{_id}; " .
Data::Dumper->Dump([ $_->{_opts} ], [ 'opts' ]); Data::Dumper->Dump([ $_->attributes ], [ 'opts' ]);
} else { } else {
' ' . Data::Dumper->Dump( [ $_ ] => [ "\_[$i]" ]); ' ' . Data::Dumper->Dump( [ $_ ] => [ "\_[$i]" ]);
} }
} @_; } @_;
Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg; Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg;
} }
sub _debug { sub _debug {
require Carp; require Carp;
require Data::Dumper; require Data::Dumper;
...@@ -791,13 +1061,15 @@ sub _debug { ...@@ -791,13 +1061,15 @@ sub _debug {
my $obj; my $obj;
if (ref eq 'IPC::Shareable') { if (ref eq 'IPC::Shareable') {
' ' . "$_: shmid: $_->{_shm}->{_id}; " . ' ' . "$_: shmid: $_->{_shm}->{_id}; " .
Data::Dumper->Dump([ $_->{_opts} ], [ 'opts' ]); Data::Dumper->Dump([ $_->attributes ], [ 'opts' ]);
} else { }
else {
' ' . Data::Dumper::Dumper($_); ' ' . Data::Dumper::Dumper($_);
} }
} @_; } @_;
Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg; Carp::carp "IPC::Shareable ($$) debug:\n", $caller, @msg;
}; }
sub _placeholder {}
1; 1;
...@@ -805,380 +1077,552 @@ __END__ ...@@ -805,380 +1077,552 @@ __END__
=head1 NAME =head1 NAME
IPC::Shareable - share Perl variables between processes IPC::Shareable - Use shared memory backed variables across processes
=for html
<a href="https://github.com/stevieb9/ipc-shareable/actions"><img src="https://github.com/stevieb9/ipc-shareable/workflows/CI/badge.svg"/></a>
<a href='https://coveralls.io/github/stevieb9/ipc-shareable?branch=master'><img src='https://coveralls.io/repos/stevieb9/ipc-shareable/badge.svg?branch=master&service=github' alt='Coverage Status' /></a>
=head1 SYNOPSIS =head1 SYNOPSIS
use IPC::Shareable (':lock'); use IPC::Shareable qw(:lock);
tie SCALAR, 'IPC::Shareable', GLUE, OPTIONS;
tie ARRAY, 'IPC::Shareable', GLUE, OPTIONS; my $href = IPC::Shareable->new(%options);
tie HASH, 'IPC::Shareable', GLUE, OPTIONS;
# ...or
tie SCALAR, 'IPC::Shareable', OPTIONS;
tie ARRAY, 'IPC::Shareable', OPTIONS;
tie HASH, 'IPC::Shareable', OPTIONS;
tied(VARIABLE)->lock;
tied(VARIABLE)->unlock;
(tied VARIABLE)->shlock; tied(VARIABLE)->lock(LOCK_SH|LOCK_NB)
(tied VARIABLE)->shunlock; or print "Resource unavailable\n";
(tied VARIABLE)->shlock(LOCK_SH|LOCK_NB) my $segment = tied(VARIABLE)->seg;
or print "resource unavailable\n"; my $semaphore = tied(VARIABLE)->sem;
(tied VARIABLE)->remove; tied(VARIABLE)->remove;
IPC::Shareable->clean_up; IPC::Shareable::clean_up;
IPC::Shareable->clean_up_all; IPC::Shareable::clean_up_all;
IPC::Shareable::clean_up_protected;
=head1 CONVENTIONS # Ensure only one instance of a script can be run at any time
The occurrence of a number in square brackets, as in [N], in the text IPC::Shareable->singleton('UNIQUE SCRIPT LOCK STRING');
of this document refers to a numbered note in the L</NOTES>.
# Get the actual IPC::Shareable tied object
my $knot = tied(VARIABLE); # Dereference first if using a tied reference
=head1 DESCRIPTION =head1 DESCRIPTION
IPC::Shareable allows you to tie a variable to shared memory making it IPC::Shareable allows you to tie a variable to shared memory making it
easy to share the contents of that variable with other Perl processes. easy to share the contents of that variable with other Perl processes and
Scalars, arrays, and hashes can be tied. The variable being tied may scripts.
contain arbitrarily complex data structures - including references to
Scalars, arrays, hashes and even objects can be tied. The variable being
tied may contain arbitrarily complex data structures - including references to
arrays, hashes of hashes, etc. arrays, hashes of hashes, etc.
The association between variables in distinct processes is provided by The association between variables in distinct processes is provided by
GLUE. This is an integer number or 4 character string[1] that serves GLUE (aka "key"). This is any arbitrary string or integer that serves as a
as a common identifier for data across process space. Hence the common identifier for data across process space. Hence the statement:
statement
tie $scalar, 'IPC::Shareable', 'data'; tie my $scalar, 'IPC::Shareable', { key => 'GLUE STRING', create => 1 };
in program one and the statement ...in program one and the statement
tie $variable, 'IPC::Shareable', 'data'; tie my $variable, 'IPC::Shareable', { key => 'GLUE STRING' };
in program two will bind $scalar in program one and $variable in ...in program two will create and bind C<$scalar> the shared memory in program
program two. one and bind it to C<$variable> in program two.
There is no pre-set limit to the number of processes that can bind to There is no pre-set limit to the number of processes that can bind to
data; nor is there a pre-set limit to the complexity of the underlying data; nor is there a pre-set limit to the complexity of the underlying
data of the tied variables[2]. The amount of data that can be shared data of the tied variables. The amount of data that can be shared
within a single bound variable is limited by the system's maximum size within a single bound variable is limited by the system's maximum size
for a shared memory segment (the exact value is system-dependent). for a shared memory segment (the exact value is system-dependent).
The bound data structures are all linearized (using Raphael Manfredi's The bound data structures are all linearized (using Raphael Manfredi's
Storable module) before being slurped into shared memory. Upon L<Storable> module or optionally L<JSON>) before being slurped into shared
retrieval, the original format of the data structure is recovered. memory. Upon retrieval, the original format of the data structure is recovered.
Semaphore flags can be used for locking data between competing processes. Semaphore flags can be used for locking data between competing processes.
=head1 OPTIONS =head1 OPTIONS
Options are specified by passing a reference to a hash as the fourth Options are specified by passing a reference to a hash as the third argument to
argument to the tie() function that enchants a variable. the C<tie()> function that enchants a variable.
Alternatively you can pass a reference to a hash as the third
argument; IPC::Shareable will then look at the field named B<key> in
this hash for the value of GLUE. So,
tie $variable, 'IPC::Shareable', 'data', \%options; The following fields are recognized in the options hash:
is equivalent to =head2 key
tie $variable, 'IPC::Shareable', { key => 'data', ... }; B<key> is the GLUE that is a direct reference to the shared memory segment
that's to be tied to the variable.
Boolean option values can be specified using a value that evaluates to If this option is missing, we'll default to using C<IPC_PRIVATE>. This
either true or false in the Perl sense. default key will not allow sharing of the variable between processes.
NOTE: Earlier versions allowed you to use the word B<yes> for true and Default: B<IPC_PRIVATE>
the word B<no> for false, but support for this "feature" is being
removed. B<yes> will still act as true (since it is true, in the Perl
sense), but use of the word B<no> now emits an (optional) warning and
then converts to a false value. This warning will become mandatory in a
future release and then at some later date the use of B<no> will
stop working altogether.
The following fields are recognized in the options hash. =head2 create
=over 4 B<create> is used to control whether the process creates a new shared
memory segment or not. If B<create> is set to a true value,
L<IPC::Shareable> will create a new binding associated with GLUE as
needed. If B<create> is false, L<IPC::Shareable> will not attempt to
create a new shared memory segment associated with GLUE. In this
case, a shared memory segment associated with GLUE must already exist
or we'll C<croak()>.
=item B<key> Defult: B<false>
The B<key> field is used to determine the GLUE when using the =head2 exclusive
three-argument form of the call to tie(). This argument is then, in
turn, used as the KEY argument in subsequent calls to shmget() and
semget().
The default value is IPC_PRIVATE, meaning that your variables cannot If B<exclusive> field is set to a true value, we will C<croak()> if the data
be shared with other processes. binding associated with GLUE already exists. If set to a false value, calls to
C<tie()> will succeed even if a shared memory segment associated with GLUE
already exists.
=item B<create> See L</graceful> for a silent, non-exception exit if a second process attempts
to obtain an in-use C<exclusive> segment.
B<create> is used to control whether calls to tie() create new shared Default: B<false>
memory segments or not. If B<create> is set to a true value,
IPC::Shareable will create a new binding associated with GLUE as
needed. If B<create> is false, IPC::Shareable will not attempt to
create a new shared memory segment associated with GLUE. In this
case, a shared memory segment associated with GLUE must already exist
or the call to tie() will fail and return undef. The default is
false.
=item B<exclusive> =head2 graceful
If B<exclusive> field is set to a true value, calls to tie() will fail If B<exclusive> is set to a true value, we normally C<croak()> if a second
(returning undef) if a data binding associated with GLUE already process attempts to obtain the same shared memory segment. Set B<graceful>
exists. If set to a false value, calls to tie() will succeed even if to true and we'll C<exit> silently and gracefully. This option does nothing
a shared memory segment associated with GLUE already exists. The if C<exclusive> isn't set.
default is false
=item B<mode> Useful for ensuring only a single process is running at a time.
The I<mode> argument is an octal number specifying the access Default: B<false>
=head2 warn
When set to a true value, B<graceful> will output a warning if there are
process collisions.
Default: B<false>
=head2 mode
The B<mode> argument is an octal number specifying the access
permissions when a new data binding is being created. These access permissions when a new data binding is being created. These access
permission are the same as file access permissions in that 0666 is permission are the same as file access permissions in that C<0666> is
world readable, 0600 is readable only by the effective UID of the world readable, C<0600> is readable only by the effective UID of the
process creating the shared variable, etc. The default is 0666 (world process creating the shared variable, etc.
readable and writable).
Default: B<0666> (world read and writeable)
=head2 size
This field may be used to specify the size of the shared memory segment
allocated.
=item B<destroy> The maximum size we allow by default is ~1GB. See the L</limit> option to
override this default.
Default: C<IPC::Shareable::SHM_BUFSIZ()> (ie. B<65536>)
=head2 protected
If set, the C<clean_up()> and C<clean_up_all()> routines will not remove the
segments or semaphores related to the tied object.
Set this to a specific integer so we can pass the value to any child objects
created under the main one.
To clean up protected objects, call
C<< (tied %object)->clean_up_protected(integer) >>, where 'integer' is the
value you set the C<protected> option to. You can call this cleanup routine in
the script you created the segment, or anywhere else, at any time.
Default: B<0>
=head2 limit
This field will allow you to set a segment size larger than the default maximum
which is 1,073,741,824 bytes (approximately 1 GB). If set, we will
C<croak()> if a size specified is larger than the maximum. If it's set to a
false value, we'll C<croak()> if you send in a size larger than the total
system RAM.
Default: B<true>
=head2 destroy
If set to a true value, the shared memory segment underlying the data If set to a true value, the shared memory segment underlying the data
binding will be removed when the process calling tie() exits binding will be removed when the process that initialized the shared memory
(gracefully)[3]. Use this option with care. In particular segment exits (gracefully)[1].
you should not use this option in a program that will fork
after binding the data. On the other hand, shared memory is
a finite resource and should be released if it is not needed.
The default is false
=item B<size> Only those memory segments that were created by the current process will be
removed.
This field may be used to specify the size of the shared memory Use this option with care. In particular you should not use this option in a
segment allocated. The default is IPC::Shareable::SHM_BUFSIZ(). program that will fork after binding the data. On the other hand, shared memory
is a finite resource and should be released if it is not needed.
=back B<NOTE>: If the segment was created with its L</protected> attribute set,
it will not be removed upon program completion, even if C<destroy> is set.
Default: B<false>
=head2 tidy
For long running processes, set this to a true value to clean up unneeded
segments from nested data structures. Comes with a slight performance hit.
Default: B<false>
Default values for options are =head2 serializer
key => IPC_PRIVATE, By default, we use L<Storable> as the data serializer when writing to or
create => 0, reading from the shared memory segments we create. For cross-platform and
exclusive => 0, cross-language purposes, you can optionally use L<JSON> for this task.
destroy => 0,
mode => 0, Send in either C<json> or C<storable> as the value to use the respective
size => IPC::Shareable::SHM_BUFSIZ(), serializer.
Default: B<storable>
=head2 Default Option Values
Default values for options are:
key => IPC_PRIVATE, # 0
create => 0,
exclusive => 0,
mode => 0666,
size => IPC::Shareable::SHM_BUFSIZ(), # 65536
protected => 0,
limit => 1,
destroy => 0,
graceful => 0,
warn => 0,
tidy => 0,
serializer => 'storable',
=head1 METHODS
=head2 new
Instantiates and returns a reference to a hash backed by shared memory.
my $href = IPC::Shareable->new(key => "testing", create => 1);
$href=>{a} = 1;
# Call tied() on the dereferenced variable to access object methods
# and information
tied(%$href)->ipcs;
Parameters:
Hash, Optional: See the L</OPTIONS> section for a list of all available options.
Most often, you'll want to send in the B<key> and B<create> options.
It is possible to get a reference to an array or scalar as well. Simply send in
either C<< var = > 'ARRAY' >> or C<< var => 'SCALAR' >> to do so.
Return: A reference to a hash (or array or scalar) which is backed by shared
memory.
=head2 singleton($glue, $warn)
Class method that ensures that only a single instance of a script can be run
at any given time.
Parameters:
$glue
Mandatory, String: The key/glue that identifies the shared memory segment.
$warn
Optional, Bool: Send in a true value to have subsequent processes throw a
warning that there's been a shared memory violation and that it will exit.
Default: B<false>
=head2 ipcs
Returns the number of instantiated shared memory segments that currently exist
on the system. This isn't precise; it simply does a C<wc -l> line count on your
system's C<ipcs -m> call. It is guaranteed though to produce reliable results.
Return: Integer
=head2 lock($flags)
Obtains a lock on the shared memory. C<$flags> specifies the type
of lock to acquire. If C<$flags> is not specified, an exclusive
read/write lock is obtained. Acceptable values for C<$flags> are
the same as for the C<flock()> system call.
Returns C<true> on success, and C<undef> on error. For non-blocking calls
(see below), the method returns C<0> if it would have blocked.
Obtain an exclusive lock like this:
tied(%var)->lock(LOCK_EX); # same as default
Only one process can hold an exclusive lock on the shared memory at a given
time.
Obtain a shared (read) lock:
tied(%var)->lock(LOCK_SH);
Multiple processes can hold a shared (read) lock at a given time. If a process
attempts to obtain an exclusive lock while one or more processes hold
shared locks, it will be blocked until they have all finished.
Either of the locks may be specified as non-blocking:
tied(%var)->lock( LOCK_EX|LOCK_NB );
tied(%var)->lock( LOCK_SH|LOCK_NB );
A non-blocking lock request will return C<0> if it would have had to
wait to obtain the lock.
Note that these locks are advisory (just like flock), meaning that
all cooperating processes must coordinate their accesses to shared memory
using these calls in order for locking to work. See the C<flock()> call for
details.
Locks are inherited through forks, which means that two processes actually
can possess an exclusive lock at the same time. Don't do that.
The constants C<LOCK_EX>, C<LOCK_SH>, C<LOCK_NB>, and C<LOCK_UN> are available
for import using any of the following export tags:
use IPC::Shareable qw(:lock);
use IPC::Shareable qw(:flock);
use IPC::Shareable qw(:all);
Or, just use the flock constants available in the Fcntl module.
See L</LOCKING> for further details.
=head2 unlock
Removes a lock. Takes no parameters, returns C<true> on success.
This is equivalent of calling C<shlock(LOCK_UN)>.
See L</LOCKING> for further details.
=head2 seg
Called on either the tied variable or the tie object, returns the shared
memory segment object currently in use.
=head2 sem
Called on either the tied variable or the tie object, returns the semaphore
object related to the memory segment currently in use.
=head2 attributes
Retrieves the list of attributes that drive the L<IPC::Shareable> object.
Parameters:
$attribute
Optional, String: The name of the attribute. If sent in, we'll return the value
of this specific attribute. Returns C<undef> if the attribute isn't found.
Attributes are the C<OPTIONS> that were used to create the object.
Returns: A hash reference of all attributes if C<$attributes> isn't sent in, the
value of the specific attribute if it is.
=head2 global_register
Returns a hash reference of hashes of all in-use shared memory segments across
all processes. The key is the memory segment ID, and the value is the segment
and semaphore objects.
=head2 process_register
Returns a hash reference of hashes of all in-use shared memory segments created
by the calling process. The key is the memory segment ID, and the value is the
segment and semaphore objects.
=head1 LOCKING =head1 LOCKING
IPC::Shareable provides methods to implement application-level IPC::Shareable provides methods to implement application-level
advisory locking of the shared data structures. These methods are advisory locking of the shared data structures. These methods are
called shlock() and shunlock(). To use them you must first get the called C<lock()> and C<unlock()>. To use them you must first get the
object underlying the tied variable, either by saving the return object underlying the tied variable, either by saving the return
value of the original call to tie() or by using the built-in tied() value of the original call to C<tie()> or by using the built-in C<tied()>
function. function.
To lock a variable, do this: To lock and subsequently unlock a variable, do this:
$knot = tie $sv, 'IPC::Shareable', $glue, { %options };
...
$knot->shlock;
or equivalently
tie($scalar, 'IPC::Shareable', $glue, { %options }); my $knot = tie my %hash, 'IPC::Shareable', { %options };
(tied $scalar)->shlock;
This will place an exclusive lock on the data of $scalar. You can $knot->lock;
also get shared locks or attempt to get a lock without blocking. $hash{a} = 'foo';
IPC::Shareable makes the constants LOCK_EX, LOCK_SH, LOCK_UN, and $knot->unlock;
LOCK_NB exportable to your address space with the export tags
C<:lock>, C<:flock>, or C<:all>. The values should be the same as
the standard C<flock> option arguments.
if ( (tied $scalar)->shlock(LOCK_SH|LOCK_NB) ) {
print "The value is $scalar\n";
(tied $scalar)->shunlock;
} else {
print "Another process has an exlusive lock.\n";
}
or equivalently, if you've decided to throw away the return of C<tie()>:
If no argument is provided to C<shlock>, it defaults to LOCK_EX. To tie my %hash, 'IPC::Shareable', { %options };
unlock a variable do this:
$knot->shunlock; tied(%hash)->lock;
$hash{a} = 'foo';
tied(%hash)->unlock;
or This will place an exclusive lock on the data of C<$scalar>. You can
also get shared locks or attempt to get a lock without blocking.
(tied $scalar)->shunlock; L<IPC::Shareable> makes the constants C<LOCK_EX>, C<LOCK_SH>, C<LOCK_UN>, and
C<LOCK_NB> exportable to your address space with the export tags C<:lock>,
C<:flock>, or C<:all>. The values should be the same as the standard C<flock>
option arguments.
or if (tied(%hash)->lock(LOCK_SH|LOCK_NB)){
print "The value is $hash{a}\n";
tied(%hash)->unlock;
} else {
print "Another process has an exclusive lock.\n";
}
$knot->shlock(LOCK_UN); # Same as calling shunlock If no argument is provided to C<lock>, it defaults to C<LOCK_EX>.
There are some pitfalls regarding locking and signals about which you There are some pitfalls regarding locking and signals about which you
should make yourself aware; these are discussed in L</NOTES>. should make yourself aware; these are discussed in L</NOTES>.
If you use the advisory locking, IPC::Shareable assumes that you know Note that in the background, we perform lock optimization when reading and
what you are doing and attempts some optimizations. When you obtain writing to the shared storage even if the advisory locks aren't being used.
a lock, either exclusive or shared, a fetch and thaw of the data is
performed. No additional fetch/thaw operations are performed until Using the advisory locks can speed up processes that are doing several writes/
you release the lock and access the bound variable again. During the reads at the same time.
time that the lock is kept, all accesses are perfomed on the copy in
program memory. If other processes do not honor the lock, and update
the shared memory region unfairly, the process with the lock will not be in
sync. In other words, IPC::Shareable does not enforce the lock
for you.
A similar optimization is done if you obtain an exclusive lock.
Updates to the shared memory region will be postponed until you
release the lock (or downgrade to a shared lock).
Use of locking can significantly improve performance for operations
such as iterating over an array, retrieving a list from a slice or
doing a slice assignment.
=head1 REFERENCES
When a reference to a non-tied scalar, hash, or array is assigned to a
tie()d variable, IPC::Shareable will attempt to tie() the thingy being
referenced[4]. This allows disparate processes to see changes to not
only the top-level variable, but also changes to nested data. This
feature is intended to be transparent to the application, but there
are some caveats to be aware of.
First of all, IPC::Shareable does not (yet) guarantee that the ids
shared memory segments allocated automagically are unique. The more
automagical tie()ing that happens, the greater the chance of a
collision.
Secondly, since a new shared memory segment is created for each thingy
being referenced, the liberal use of references could cause the system
to approach its limit for the total number of shared memory segments
allowed.
=head1 OBJECTS
IPC::Shareable implements tie()ing objects to shared memory too.
Since an object is just a reference, the same principles (and caveats)
apply to tie()ing objects as other reference types.
=head1 DESTRUCTION =head1 DESTRUCTION
perl(1) will destroy the object underlying a tied variable when then perl(1) will destroy the object underlying a tied variable when then
tied variable goes out of scope. Unfortunately for IPC::Shareable, tied variable goes out of scope. Unfortunately for L<IPC::Shareable>,
this may not be desirable: other processes may still need a handle on this may not be desirable: other processes may still need a handle on
the relevant shared memory segment. IPC::Shareable therefore provides the relevant shared memory segment.
an interface to allow the application to control the timing of removal
of shared memory segments. The interface consists of three methods -
remove(), clean_up(), and clean_up_all() - and the B<destroy> option
to tie().
=over 4 L<IPC::Shareable> therefore provides several options to control the timing of
removal of shared memory segments.
=item B<destroy option> =head2 destroy Option
As described in L</OPTIONS>, specifying the B<destroy> option when As described in L</OPTIONS>, specifying the B<destroy> option when
tie()ing a variable coerces IPC::Shareable to remove the underlying C<tie()>ing a variable coerces L<IPC::Shareable> to remove the underlying
shared memory segment when the process calling tie() exits gracefully. shared memory segment when the process calling C<tie()> exits gracefully.
Note that any related shared memory segments created automagically by
the use of references will also be removed. B<NOTE>: The destruction is handled in an C<END> block. Only those memory
segments that are tied to the current process will be removed.
B<NOTE>: If the segment was created with its L</protected> attribute set,
it will not be removed in the C<END> block, even if C<destroy> is set.
=head2 remove
tied($var)->remove;
=item B<remove()> # or
(tied $var)->remove; $knot->remove;
Calling remove() on the object underlying a tie()d variable removes Calling C<remove()> on the object underlying a C<tie()>d variable removes
the associated shared memory segment. The segment is removed the associated shared memory segments. The segment is removed
irrespective of whether it has the B<destroy> option set or not and irrespective of whether it has the B<destroy> option set or not and
irrespective of whether the calling process created the segment. irrespective of whether the calling process created the segment.
=item B<clean_up()> =head2 clean_up
IPC::Shareable->clean_up; IPC::Shareable->clean_up;
This is a class method that provokes IPC::Shareable to remove all # or
tied($var)->clean_up;
# or
$knot->clean_up;
This is a class method that provokes L<IPC::Shareable> to remove all
shared memory segments created by the process. Segments not created shared memory segments created by the process. Segments not created
by the calling process are not removed. by the calling process are not removed.
=item B<clean_up_all()> This method will not clean up segments created with the C<protected> option.
=head2 clean_up_all
IPC::Shareable->clean_up_all;
# or
tied($var)->clean_up_all;
IPC::Shareable->clean_up_all; # or
This is a class method that provokes IPC::Shareable to remove all $knot->clean_up_all
This is a class method that provokes L<IPC::Shareable> to remove all
shared memory segments encountered by the process. Segments are shared memory segments encountered by the process. Segments are
removed even if they were not created by the calling process. removed even if they were not created by the calling process.
=back This method will not clean up segments created with the C<protected> option.
=head1 EXAMPLES =head2 clean_up_protected($protect_key)
In a file called B<server>: If a segment is created with the C<protected> option, it, nor its children will
be removed during calls of C<clean_up()> or C<clean_up_all()>.
#!/usr/bin/perl -w
use strict; When setting L</protected>, you specified a lock key integer. When calling this
use IPC::Shareable; method, you must send that integer in as a parameter so we know which segments
my $glue = 'data'; to clean up.
my %options = (
create => 'yes', my $protect_key = 93432;
exclusive => 0,
mode => 0644,
destroy => 'yes',
);
my %colours;
tie %colours, 'IPC::Shareable', $glue, { %options } or
die "server: tie failed\n";
%colours = (
red => [
'fire truck',
'leaves in the fall',
],
blue => [
'sky',
'police cars',
],
);
((print "server: there are 2 colours\n"), sleep 5)
while scalar keys %colours == 2;
print "server: here are all my colours:\n";
foreach my $c (keys %colours) {
print "server: these are $c: ",
join(', ', @{$colours{$c}}), "\n";
}
exit;
In a file called B<client>
#!/usr/bin/perl -w
use strict;
use IPC::Shareable;
my $glue = 'data';
my %options = (
create => 0,
exclusive => 0,
mode => 0644,
destroy => 0,
);
my %colours;
tie %colours, 'IPC::Shareable', $glue, { %options } or
die "client: tie failed\n";
foreach my $c (keys %colours) {
print "client: these are $c: ",
join(', ', @{$colours{$c}}), "\n";
}
delete $colours{'red'};
exit;
And here is the output (the sleep commands in the command line prevent IPC::Shareable->clean_up_protected($protect_key);
the output from being interrupted by shell prompts):
bash$ ( ./server & ) ; sleep 10 ; ./client ; sleep 10 # or
server: there are 2 colours
server: there are 2 colours tied($var)->clean_up_protected($protect_key;
server: there are 2 colours
client: these are blue: sky, police cars # or
client: these are red: fire truck, leaves in the fall
server: here are all my colours: $knot->clean_up_protected($protect_key)
server: these are blue: sky, police cars
Parameters:
$protect_key
Mandatory, Integer: The integer protect key you assigned wit the C<protected>
option
=head1 RETURN VALUES =head1 RETURN VALUES
Calls to tie() that try to implement IPC::Shareable will return true Calls to C<tie()> that try to implement L<IPC::Shareable> will return an
if successful, I<undef> otherwise. The value returned is an instance instance of C<IPC::Shareable> on success, and C<undef> otherwise.
of the IPC::Shareable class.
=head1 AUTHOR =head1 AUTHOR
Benjamin Sugars <bsugars@canoe.ca> Benjamin Sugars <bsugars@canoe.ca>
=head1 MAINTAINED BY
Steve Bertrand <steveb@cpan.org>
=head1 NOTES =head1 NOTES
=head2 Footnotes from the above sections =head2 Footnotes from the above sections
...@@ -1187,43 +1631,21 @@ Benjamin Sugars <bsugars@canoe.ca> ...@@ -1187,43 +1631,21 @@ Benjamin Sugars <bsugars@canoe.ca>
=item 1 =item 1
If GLUE is longer than 4 characters, only the 4 most significant If the process has been smoked by an untrapped signal, the binding will remain
characters are used. These characters are turned into integers by in shared memory. If you're cautious, you might try:
unpack()ing them. If GLUE is less than 4 characters, it is space
padded.
=item 2
IPC::Shareable provides no pre-set limits, but the system does.
Namely, there are limits on the number of shared memory segments that
can be allocated and the total amount of memory usable by shared
memory.
=item 3
If the process has been smoked by an untrapped signal, the binding
will remain in shared memory. If you're cautious, you might try
$SIG{INT} = \&catch_int; $SIG{INT} = \&catch_int;
sub catch_int { sub catch_int {
die; die;
} }
... ...
tie $variable, IPC::Shareable, 'data', { 'destroy' => 'Yes!' }; tie $variable, IPC::Shareable, { key => 'GLUE', create => 1, 'destroy' => 1 };
which will at least clean up after your user hits CTRL-C because which will at least clean up after your user hits CTRL-C because
IPC::Shareable's END method will be called. Or, maybe you'd like to IPC::Shareable's END method will be called. Or, maybe you'd like to
leave the binding in shared memory, so subsequent process can recover leave the binding in shared memory, so subsequent process can recover
the data... the data...
=item 4
This behaviour is markedly different from previous versions of
IPC::Shareable. Older versions would sometimes tie() referenced
thingies, and sometimes not. The new approach is more reliable (I
think) and predictable (certainly) but uses more shared memory
segments.
=back =back
=head2 General Notes =head2 General Notes
...@@ -1232,20 +1654,21 @@ segments. ...@@ -1232,20 +1654,21 @@ segments.
=item o =item o
When using shlock() to lock a variable, be careful to guard against When using C<lock()> to lock a variable, be careful to guard against
signals. Under normal circumstances, IPC::Shareable's END method signals. Under normal circumstances, C<IPC::Shareable>'s C<END> method
unlocks any locked variables when the process exits. However, if an unlocks any locked variables when the process exits. However, if an
untrapped signal is received while a process holds an exclusive lock, untrapped signal is received while a process holds an exclusive lock,
DESTROY will not be called and the lock may be maintained even though C<END> will not be called and the lock may be maintained even though
the process has exited. If this scares you, you might be better off the process has exited. If this scares you, you might be better off
implementing your own locking methods. implementing your own locking methods.
One advantage of using C<flock> on some known file instead of the One advantage of using C<flock> on some known file instead of the
locking implemented with semaphores in IPC::Shareable is that when a locking implemented with semaphores in C<IPC::Shareable> is that when a
process dies, it automatically releases any locks. This only happens process dies, it automatically releases any locks. This only happens
with IPC::Shareable if the process dies gracefully. The alternative with C<IPC::Shareable> if the process dies gracefully.
is to attempt to account for every possible calamitous ending for your
process (robust signal handling in Perl is a source of much debate, The alternative is to attempt to account for every possible calamitous ending
for your process (robust signal handling in Perl is a source of much debate,
though it usually works just fine) or to become familiar with your though it usually works just fine) or to become familiar with your
system's tools for removing shared memory and semaphores. This system's tools for removing shared memory and semaphores. This
concern should be balanced against the significant performance concern should be balanced against the significant performance
...@@ -1254,15 +1677,37 @@ locking mechanism implemented in IPC::Shareable. ...@@ -1254,15 +1677,37 @@ locking mechanism implemented in IPC::Shareable.
=item o =item o
There is a program called ipcs(1/8) (and ipcrm(1/8)) that is There is a program called C<ipcs>(1/8) (and C<ipcrm>(1/8)) that is
available on at least Solaris and Linux that might be useful for available on at least Solaris and Linux that might be useful for
cleaning moribund shared memory segments or semaphore sets produced cleaning moribund shared memory segments or semaphore sets produced
by bugs in either IPC::Shareable or applications using it. by bugs in either L<IPC::Shareable> or applications using it.
Examples:
# List all semaphores and memory segments in use on the system
ipcs -a
# List all memory segments and semaphores along with each one's associated process ID
ipcs -ap
# List just the shared memory segments
ipcs -m
# List the details of an individual memory segment
ipcs -i 12345678
# Remove *all* semaphores and memory segments
ipcrm -a
=item o =item o
This version of IPC::Shareable does not understand the format of This version of L<IPC::Shareable> does not understand the format of
shared memory segments created by versions prior to 0.60. If you try shared memory segments created by versions prior to C<0.60>. If you try
to tie to such segments, you will get an error. The only work around to tie to such segments, you will get an error. The only work around
is to clear the shared memory segments and start with a fresh set. is to clear the shared memory segments and start with a fresh set.
...@@ -1270,14 +1715,16 @@ is to clear the shared memory segments and start with a fresh set. ...@@ -1270,14 +1715,16 @@ is to clear the shared memory segments and start with a fresh set.
Iterating over a hash causes a special optimization if you have not Iterating over a hash causes a special optimization if you have not
obtained a lock (it is better to obtain a read (or write) lock before obtained a lock (it is better to obtain a read (or write) lock before
iterating over a hash tied to Shareable, but we attempt this iterating over a hash tied to L<IPC::Shareable>, but we attempt this
optimization if you do not). The fetch/thaw operation is performed optimization if you do not).
For tied hashes, the C<fetch>/C<thaw> operation is performed
when the first key is accessed. Subsequent key and and value when the first key is accessed. Subsequent key and and value
accesses are done without accessing shared memory. Doing an accesses are done without accessing shared memory. Doing an
assignment to the hash or fetching another value between key assignment to the hash or fetching another value between key
accesses causes the hash to be replaced from shared memory. The accesses causes the hash to be replaced from shared memory. The
state of the iterator in this case is not defined by the Perl state of the iterator in this case is not defined by the Perl
documentation. Caveat Emptor. documentation. Caveat Emptor.
=back =back
...@@ -1285,27 +1732,21 @@ documentation. Caveat Emptor. ...@@ -1285,27 +1732,21 @@ documentation. Caveat Emptor.
Thanks to all those with comments or bug fixes, especially Thanks to all those with comments or bug fixes, especially
Maurice Aubrey <maurice@hevanet.com> Maurice Aubrey <maurice@hevanet.com>
Stephane Bortzmeyer <bortzmeyer@pasteur.fr> Stephane Bortzmeyer <bortzmeyer@pasteur.fr>
Doug MacEachern <dougm@telebusiness.co.nz> Doug MacEachern <dougm@telebusiness.co.nz>
Robert Emmery <roberte@netscape.com> Robert Emmery <roberte@netscape.com>
Mohammed J. Kabir <kabir@intevo.com> Mohammed J. Kabir <kabir@intevo.com>
Terry Ewing <terry@intevo.com> Terry Ewing <terry@intevo.com>
Tim Fries <timf@dicecorp.com> Tim Fries <timf@dicecorp.com>
Joe Thomas <jthomas@women.com> Joe Thomas <jthomas@women.com>
Paul Makepeace <Paul.Makepeace@realprogrammers.com> Paul Makepeace <Paul.Makepeace@realprogrammers.com>
Raphael Manfredi <Raphael_Manfredi@pobox.com> Raphael Manfredi <Raphael_Manfredi@pobox.com>
Lee Lindley <Lee.Lindley@bigfoot.com> Lee Lindley <Lee.Lindley@bigfoot.com>
Dave Rolsky <autarch@urth.org> Dave Rolsky <autarch@urth.org>
Steve Bertrand <steveb@cpan.org>
=head1 BUGS
Certainly; this is beta software. When you discover an anomaly, send
an email to me at bsugars@canoe.ca.
=head1 SEE ALSO =head1 SEE ALSO
perl(1), perltie(1), Storable(3), shmget(2), ipcs(1), ipcrm(1) L<perltie>, L<Storable>, C<shmget>, C<ipcs>, C<ipcrm> and other SysV IPC manual
and other SysV IPC man pages. pages.
=cut
opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/Shareable/SharedMem.pm
View file @ 971eb4d6
package IPC::Shareable::SharedMem; package IPC::Shareable::SharedMem;
use warnings;
use strict; use strict;
use constant DEBUGGING => ($ENV{SHM_DEBUG} or 0);
use Carp qw(carp croak confess);
use IPC::SysV qw(IPC_RMID); use IPC::SysV qw(IPC_RMID);
my $Def_Size = 1024; our $VERSION = '1.13';
sub _trace {
require Carp;
require Data::Dumper;
my $caller = ' ' . (caller(1))[3] . " called with:\n";
my $i = -1;
my @msg = map {
++$i;
' ' . Data::Dumper->Dump( [ $_ ] => [ "\_[$i]" ]);
} @_;
Carp::carp "IPC::SharedMem debug:\n", $caller, @msg;
}
sub _debug { use constant DEBUGGING => ($ENV{SHM_DEBUG} or 0);
require Carp;
require Data::Dumper; my $default_size = 1024;
local $Data::Dumper::Terse = 1;
my $caller = ' ' . (caller(1))[3] . " tells us that:\n";
my @msg = map { ' ' . Data::Dumper::Dumper($_) } @_;
Carp::carp "IPC::SharedMem debug:\n", $caller, @msg;
};
sub default_size { sub default_size {
_trace @_ if DEBUGGING;
my $class = shift; my $class = shift;
$Def_Size = shift if @_; $default_size = shift if @_;
return $Def_Size; return $default_size;
} }
sub new { sub new {
_trace @_ if DEBUGGING; my($class, $key, $size, $flags, $type) = @_;
my($class, $key, $size, $flags) = @_;
defined $key or do { defined $key or do {
require Carp; confess "usage: IPC::SharedMem->new(KEY, [ SIZE, [ FLAGS ] ])";
Carp::croak "usage: IPC::SharedMem->new(KEY, [ SIZE, [ FLAGS ] ])";
}; };
$size ||= $Def_Size;
$size ||= $default_size;
$flags ||= 0; $flags ||= 0;
_debug "calling shmget() on ", $key, $size, $flags if DEBUGGING;
my $id = shmget($key, $size, $flags); my $id = shmget($key, $size, $flags);
defined $id or do { defined $id or do {
require Carp; if ($! =~ /File exists/){
Carp::carp "IPC::Shareable::SharedMem: shmget: $!\n"; croak "\nERROR: IPC::Shareable::SharedMem: shmget $key: $!\n\n" .
"Are you using exclusive, but trying to create multiple " .
"instances?\n\n";
}
return undef; return undef;
}; };
my $sh = { my $sh = {
_id => $id, _id => $id,
_key => $key,
_size => $size, _size => $size,
_flags => $flags, _flags => $flags,
_type => $type,
}; };
return bless $sh => $class; return bless $sh => $class;
} }
sub id { sub id {
_trace @_ if DEBUGGING;
my $self = shift; my $self = shift;
$self->{_id} = shift if @_; $self->{_id} = shift if @_;
return $self->{_id}; return $self->{_id};
} }
sub key {
my $self = shift;
$self->{_key} = shift if @_;
return $self->{_key};
}
sub flags { sub flags {
_trace @_ if DEBUGGING;
my $self = shift; my $self = shift;
$self->{_flags} = shift if @_; $self->{_flags} = shift if @_;
return $self->{_flags}; return $self->{_flags};
} }
sub size { sub size {
_trace @_ if DEBUGGING;
my $self = shift; my $self = shift;
$self->{_size} = shift if @_; $self->{_size} = shift if @_;
return $self->{_size}; return $self->{_size};
} }
sub type {
my $self = shift;
$self->{_type} = shift if @_;
return $self->{_type};
}
sub shmwrite { sub shmwrite {
_trace @_ if DEBUGGING;
my($self, $data) = @_; my($self, $data) = @_;
_debug "calling shmwrite() on ", $self->{_id}, $data,
0, $self->{_size} if DEBUGGING;
return shmwrite($self->{_id}, $data, 0, $self->{_size}); return shmwrite($self->{_id}, $data, 0, $self->{_size});
} }
sub shmread { sub shmread {
_trace @_ if DEBUGGING;
my $self = shift; my $self = shift;
my $data = ''; my $data = '';
_debug "calling shread() on ", $self->{_id}, $data,
0, $self->{_size} if DEBUGGING;
shmread($self->{_id}, $data, 0, $self->{_size}) or return; shmread($self->{_id}, $data, 0, $self->{_size}) or return;
_debug "got ", $data, " from shm segment $self->{_id}" if DEBUGGING;
return $data; return $data;
} }
sub remove { sub remove {
_trace @_ if DEBUGGING; my $to_remove = shift;
my $self = shift;
my $op = shift; my $id;
if (ref $to_remove eq __PACKAGE__){
$id = $to_remove->{_id};
}
my $arg = 0; my $arg = 0;
return shmctl($self->{_id}, IPC_RMID, $arg); my $ret = shmctl($id, IPC_RMID, $arg);
return $ret;
} }
1; 1;
...@@ -121,6 +111,11 @@ sub remove { ...@@ -121,6 +111,11 @@ sub remove {
IPC::Shareable::SharedMem - Object oriented interface to shared memory IPC::Shareable::SharedMem - Object oriented interface to shared memory
=for html
<a href="https://github.com/stevieb9/ipc-shareable/actions"><img src="https://github.com/stevieb9/ipc-shareable/workflows/CI/badge.svg"/></a>
<a href='https://coveralls.io/github/stevieb9/ipc-shareable?branch=master'><img src='https://coveralls.io/repos/stevieb9/ipc-shareable/badge.svg?branch=master&service=github' alt='Coverage Status' /></a>
=head1 SYNOPSIS =head1 SYNOPSIS
*** No public interface *** *** No public interface ***
...@@ -128,9 +123,7 @@ IPC::Shareable::SharedMem - Object oriented interface to shared memory ...@@ -128,9 +123,7 @@ IPC::Shareable::SharedMem - Object oriented interface to shared memory
=head1 WARNING =head1 WARNING
This module is not intended for public consumption. It is used This module is not intended for public consumption. It is used
internally by IPC::Shareable to access shared memory. It will internally by IPC::Shareable to access shared memory.
probably be replaced soon by IPC::ShareLite or IPC::SharedMem (when
someone writes it).
=head1 DESCRIPTION =head1 DESCRIPTION
...@@ -144,4 +137,4 @@ Ben Sugars (bsugars@canoe.ca) ...@@ -144,4 +137,4 @@ Ben Sugars (bsugars@canoe.ca)
=head1 SEE ALSO =head1 SEE ALSO
IPC::Shareable, IPC::SharedLite L<IPC::Shareable>, L<IPC::ShareLite>
opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/ipc.pl 0 → 100644
View file @ 971eb4d6
use warnings;
use strict;
use feature 'say';
use Script::Singleton warn => 1;
sleep 10;
opt/thirdlane/perl_lib/local/dist/lib/perl5/Mock/Sub.pm 0 → 100644
View file @ 971eb4d6
package Mock::Sub;
use 5.006;
use strict;
use warnings;
use Carp qw(confess);
use Mock::Sub::Child;
use Scalar::Util qw(weaken);
our $VERSION = '1.09';
my %opts;
sub import {
my ($class, %args) = @_;
%opts = %args;
}
sub new {
my $self = bless {}, shift;
%{ $self } = @_;
for (keys %opts){
$self->{$_} = $opts{$_};
}
return $self;
}
sub mock {
my ($self, $sub, %p) = @_;
if (ref($self) ne 'Mock::Sub'){
confess
"calling mock() on the Mock::Sub class is no longer permitted. " .
"create a new mock object with Mock::Sub->new;, then call mock " .
"with my \$sub_object = \$mock->mock('sub_name'); ";
}
if (! defined wantarray){
confess "\n\ncalling mock() in void context isn't allowed. ";
}
my $child = Mock::Sub::Child->new(no_warnings => $self->{no_warnings});
my $side_effect = defined $p{side_effect}
? $p{side_effect}
: $self->{side_effect};
my $return_value = defined $p{return_value}
? $p{return_value}
: $self->{return_value};
$child->side_effect($side_effect);
$child->return_value($return_value);
$self->{objects}{$sub}{obj} = $child;
$child->_mock($sub);
# remove the REFCNT to the child, or else DESTROY won't be called
weaken $self->{objects}{$sub}{obj};
return $child;
}
sub mocked_subs {
my $self = shift;
my @names;
for (keys %{ $self->{objects} }) {
if ($self->mocked_state($_)){
push @names, $_;
}
}
return @names;
}
sub mocked_objects {
my $self = shift;
my @mocked;
for (keys %{ $self->{objects} }){
push @mocked, $self->{objects}{$_}{obj};
}
return @mocked;
}
sub mocked_state {
my ($self, $sub) = @_;
if (! $sub){
confess "calling mocked_state() on a Mock::Sub object requires a sub " .
"name to be passed in as its only parameter. ";
}
eval {
my $test = $self->{objects}{$sub}{obj}->mocked_state();
};
if ($@){
confess "can't call mocked_state() on the class if the sub hasn't yet " .
"been mocked. ";
}
return $self->{objects}{$sub}{obj}->mocked_state;
}
sub DESTROY {
}
sub __end {}; # vim fold placeholder
1;
=head1 NAME
Mock::Sub - Mock package, object and standard subroutines, with unit testing in mind.
=for html
<a href="http://travis-ci.org/stevieb9/mock-sub"><img src="https://secure.travis-ci.org/stevieb9/mock-sub.png"/>
<a href='https://coveralls.io/github/stevieb9/mock-sub?branch=master'><img src='https://coveralls.io/repos/stevieb9/mock-sub/badge.svg?branch=master&service=github' alt='Coverage Status' /></a>
=head1 SYNOPSIS
# see EXAMPLES for a full use case and caveats
use Mock::Sub;
# disable warnings about mocking non-existent subs
use Mock::Sub no_warnings => 1
# create the parent mock object
my $mock = Mock::Sub->new;
# mock some subs...
my $foo = $mock->mock('Package::foo');
my $bar = $mock->mock('Package::bar');
# wait until a mocked sub is called
Package::foo();
# then...
$foo->name; # name of sub that's mocked
$foo->called; # was the sub called?
$foo->called_count; # how many times was it called?
$foo->called_with; # array of params sent to sub
# have the mocked sub return something when it's called (list or scalar).
$foo->return_value(1, 2, {a => 1});
my @return = Package::foo;
# have the mocked sub perform an action
$foo->side_effect( sub { die "eval catch" if @_; } );
eval { Package::foo(1); };
like ($@, qr/eval catch/, "side_effect worked with params");
# extract the parameters the sub was called with (if return_value or
# side_effect is not used, we will return the parameters that were sent into
# the mocked sub (list or scalar context)
my @args = $foo->called_with;
# reset the mock object for re-use within the same scope
$foo->reset;
# restore original functionality to the sub
$foo->unmock;
# re-mock a previously unmock()ed sub
$foo->remock;
# check if a sub is mocked
my $state = $foo->mocked_state;
# mock out a CORE:: function. Be warned that this *must* be done within
# compile stage (BEGIN), and the function can NOT be unmocked prior
# to the completion of program execution
my ($mock, $caller);
BEGIN {
$mock = Mock::Sub->new;
$caller = $mock->mock('caller');
};
$caller->return_value(55);
caller(); # mocked caller() called
=head1 DESCRIPTION
Easy to use and very lightweight module for mocking out sub calls.
Very useful for testing areas of your own modules where getting coverage may
be difficult due to nothing to test against, and/or to reduce test run time by
eliminating the need to call subs that you really don't want or need to test.
=head1 EXAMPLE
Here's a full example to get further coverage where it's difficult if not
impossible to test certain areas of your code (eg: you have if/else statements,
but they don't do anything but call other subs. You don't want to test the
subs that are called, nor do you want to add statements to your code).
Note that if the end subroutine you're testing is NOT Object Oriented (and
you're importing them into your module that you're testing), you have to mock
them as part of your own namespace (ie. instead of Other::first, you'd mock
MyModule::first).
# module you're testing:
package MyPackage;
use Other;
use Exporter qw(import);
@EXPORT_OK = qw(test);
my $other = Other->new;
sub test {
my $arg = shift;
if ($arg == 1){
# how do you test this?... there's no return etc.
$other->first();
}
if ($arg == 2){
$other->second();
}
}
# your test file
use MyPackage qw(test);
use Mock::Sub;
use Test::More tests => 2;
my $mock = Mock::Sub->new;
my $first = $mock->mock('Other::first');
my $second = $mock->mock('Other::second');
# coverage for first if() in MyPackage::test
test(1);
is ($first->called, 1, "1st if() statement covered");
# coverage for second if()
test(2);
is ($second->called, 1, "2nd if() statement covered");
=head1 MOCK OBJECT METHODS
=head2 C<new(%opts)>
Instantiates and returns a new C<Mock::Sub> object, ready to be used to start
creating mocked sub objects.
Optional options:
=over 4
=item C<return_value =E<gt> $scalar>
Set this to have all mocked subs created with this mock object return anything
you wish (accepts a single scalar only. See C<return_value()> method to return
a list and for further information). You can also set it in individual mocks
only (see C<return_value()> method).
=item C<side_effect =E<gt> $cref>
Set this in C<new()> to have the side effect passed into all child mocks
created with this object. See C<side_effect()> method.
=back
=head2 C<mock('sub', %opts)>
Instantiates and returns a new mock object on each call. 'sub' is the name of
the subroutine to mock (requires full package name if the sub isn't in
C<main::>).
The mocked sub will return the parameters sent into the mocked sub if a return
value isn't set, or a side effect doesn't return anything, if available. If
in scalar context but a list was sent in, we'll return the first parameter in
the list. In list context, we simply receive the parameters as they were sent
in.
Optional parameters:
See C<new()> for a description of the parameters. Both the C<return_value> and
C<side_effect> parameters can be set in this method to individualize each mock
object, and will override the global configuration if set in C<new()>.
There's also C<return_value()> and C<side_effect()> methods if you want to
set, change or remove these values after instantiation of a child sub object.
=head2 mocked_subs
Returns a list of all the names of the subs that are currently mocked under
the parent mock object.
=head2 mocked_objects
Returns a list of all sub objects underneath the parent mock object, regardless
if its sub is currently mocked or not.
=head2 mocked_state('Sub::Name')
Returns 1 if the sub currently under the parent mock object is mocked or not,
and 0 if not. Croaks if there hasn't been a child sub object created with this
sub name.
=head1 SUB OBJECT METHODS
These methods are for the children mocked sub objects returned from the
parent mock object. See L<MOCK OBJECT METHODS> for methods related
to the parent mock object.
=head2 C<unmock>
Restores the original functionality back to the sub, and runs C<reset()> on
the object.
=head2 C<remock>
Re-mocks the sub within the object after calling C<unmock> on it (accepts the
side_effect and return_value parameters).
=head2 C<called>
Returns true (1) if the sub being mocked has been called, and false (0) if not.
=head2 C<called_count>
Returns the number of times the mocked sub has been called.
=head2 C<called_with>
Returns an array of the parameters sent to the subroutine. C<confess()s> if
we're called before the mocked sub has been called.
=head2 C<mocked_state>
Returns true (1) if the sub the object refers to is currently mocked, and
false (0) if not.
=head2 C<name>
Returns the name of the sub being mocked.
=head2 C<side_effect($cref)>
Add (or change/delete) a side effect after instantiation.
Send in a code reference containing an action you'd like the
mocked sub to perform.
The side effect function will receive all parameters sent into the mocked sub.
You can use both C<side_effect()> and C<return_value()> params at the same
time. C<side_effect> will be run first, and then C<return_value>. Note that if
C<side_effect>'s last expression evaluates to any value whatsoever
(even false), it will return that and C<return_value> will be skipped.
To work around this and have the side_effect run but still get the
return_value thereafter, write your cref to evaluate undef as the last thing
it does: C<sub { ...; undef; }>.
=head2 C<return_value>
Add (or change/delete) the mocked sub's return value after instantiation.
Can be a scalar or list. Send in C<undef> to remove previously set values.
=head2 C<reset>
Resets the functional parameters (C<return_value>, C<side_effect>), along
with C<called()> and C<called_count()> back to undef/false. Does not restore
the sub back to its original state.
=head1 NOTES
This module has a backwards parent-child relationship. To use, you create a
mock object using L</MOCK OBJECT METHODS> C<new> and C<mock> methods,
thereafter, you use the returned mocked sub object L</SUB OBJECT METHODS> to
perform the work.
The parent mock object retains certain information and statistics of the child
mocked objects (and the subs themselves).
To mock CORE::GLOBAL functions, you *must* initiate within a C<BEGIN> block
(see C<SYNOPSIS> for details). It is important that if you mock a CORE sub,
it can't and won't be returned to its original state until after the entire
program process tree exists. Period.
I didn't make this a C<Test::> module (although it started that way) because
I can see more uses than placing it into that category.
=head1 AUTHOR
Steve Bertrand, C<< <steveb at cpan.org> >>
=head1 BUGS
Please report any bugs or requests at
L<https://github.com/stevieb9/mock-sub/issues>
=head1 REPOSITORY
L<https://github.com/stevieb9/mock-sub>
=head1 BUILD RESULTS
CPAN Testers: L<http://matrix.cpantesters.org/?dist=Mock-Sub>
=head1 SUPPORT
You can find documentation for this module with the perldoc command.
perldoc Mock::Sub
=head1 ACKNOWLEDGEMENTS
Python's MagicMock module.
=head1 LICENSE AND COPYRIGHT
Copyright 2016 Steve Bertrand.
This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.
See L<http://dev.perl.org/licenses/> for more information.
=cut
1; # End of Mock::Sub
opt/thirdlane/perl_lib/local/dist/lib/perl5/Mock/Sub/Child.pm 0 → 100644
View file @ 971eb4d6
package Mock::Sub::Child;
use 5.006;
use strict;
use warnings;
use Carp qw(confess);
use Scalar::Util qw(weaken);
our $VERSION = '1.09';
sub new {
my $self = bless {}, shift;
%{ $self } = @_;
if ($self->{side_effect}){
$self->_check_side_effect($self->{side_effect});
}
return $self;
}
sub _mock {
my $self = shift;
# throw away the sub name if it's sent in and we're not called
# by Mock::Sub::mock()
my $sub_passed_in;
if ($_[0] && $_[0] =~ /::/){
$sub_passed_in = 1;
}
my $caller = (caller(1))[3] || '';
if ($caller ne 'Mock::Sub::mock' && $sub_passed_in){
undef @_;
if(ref($self) eq 'Mock::Sub::Child' && ! $self->{name}){
confess "can't call mock() on a child object before it is already " .
"initialized with the parent mock object. ";
}
}
if ($caller ne 'Mock::Sub::mock' && $caller ne 'Mock::Sub::Child::remock'){
confess "the _mock() method is not a public API call. For re-mocking " .
"an existing sub in an existing sub object, use remock().\n";
}
my $sub = $self->name || shift;
my %p = @_;
for (keys %p){
$self->{$_} = $p{$_};
}
if ($sub !~ /::/) {
my $core_sub = "CORE::" . $sub;
if (defined &$core_sub && ${^GLOBAL_PHASE} eq 'START') {
warn "WARNING! we're attempting to override a global core " .
"function. You will NOT be able to restore functionality " .
"to this function.";
$sub = "CORE::GLOBAL::" . $sub;
}
else {
$sub = "main::$sub" if $sub !~ /::/;
}
}
my $fake;
if (! exists &$sub && $sub !~ /CORE::GLOBAL/) {
$fake = 1;
if (! $self->_no_warn) {
warn "\n\nWARNING!: we've mocked a non-existent subroutine. ".
"the specified sub does not exist.\n\n";
}
}
$self->_check_side_effect($self->{side_effect});
if (defined $self->{return_value}){
push @{ $self->{return} }, $self->{return_value};
}
$self->{name} = $sub;
$self->{orig} = \&$sub if ! $fake;
$self->{called_count} = 0;
{
no strict 'refs';
no warnings 'redefine';
my $mock = $self;
weaken $mock;
*$sub = sub {
@{ $mock->{called_with} } = @_;
++$mock->{called_count};
if ($mock->{side_effect}) {
if (wantarray){
my @effect = $mock->{side_effect}->(@_);
return @effect if @effect;
}
else {
my $effect = $mock->{side_effect}->(@_);
return $effect if defined $effect;
}
}
return if ! defined $mock->{return};
if ($mock->{return}[0] && $mock->{return}[0] eq 'params'){
return ! wantarray ? $_[0] : @_;
}
else {
return ! wantarray && @{ $mock->{return} } == 1
? $mock->{return}[0]
: @{ $mock->{return} };
}
};
}
$self->{state} = 1;
return $self;
}
sub remock {
shift->_mock(@_);
}
sub unmock {
my $self = shift;
my $sub = $self->{name};
{
no strict 'refs';
no warnings 'redefine';
if (defined $self->{orig} && $sub !~ /CORE::GLOBAL/) {
*$sub = \&{ $self->{orig} };
}
else {
undef *$sub if $self->{name};
}
}
$self->{state} = 0;
$self->reset;
}
sub called {
return shift->called_count ? 1 : 0;
}
sub called_count {
return shift->{called_count} || 0;
}
sub called_with {
my $self = shift;
if (! $self->called){
confess "\n\ncan't call called_with() before the mocked sub has " .
"been called. ";
}
return @{ $self->{called_with} };
}
sub name {
return shift->{name};
}
sub reset {
for (qw(side_effect return_value return called called_count called_with)){
delete $_[0]->{$_};
}
}
sub return_value {
my $self = shift;
@{ $self->{return} } = @_;
}
sub side_effect {
$_[0]->_check_side_effect($_[1]);
$_[0]->{side_effect} = $_[1];
}
sub _check_side_effect {
if (defined $_[1] && ref $_[1] ne 'CODE') {
confess "\n\nside_effect parameter must be a code reference. ";
}
}
sub mocked_state {
return shift->{state};
}
sub _no_warn {
return $_[0]->{no_warnings};
}
sub DESTROY {
$_[0]->unmock;
}
sub _end {}; # vim fold placeholder
__END__
=head1 NAME
Mock::Sub::Child - Provides for Mock::Sub
=head1 METHODS
Please refer to the C<Mock::Sub> parent module for full documentation. The
descriptions here are just a briefing.
=head2 new
This method can only be called by the parent C<Mock::Sub> module.
=head2 called
Returns bool whether the mocked sub has been called yet.
=head2 called_count
Returns an integer representing the number of times the mocked sub has been
called.
=head2 called_with
Returns a list of arguments the mocked sub was called with.
=head2 mock
This method should only be called by the parent mock object. You shouldn't be
calling this.
=head2 remock
Re-mocks an unmocked sub back to the same subroutine it was originally mocked
with.
=head2 mocked_state
Returns bool whether the sub the object represents is currently mocked or not.
=head2 name
Returns the name of the sub this object is mocking.
=head2 return_value
Send in any values (list or scalar) that you want the mocked sub to return when
called.
=head2 side_effect
Send in a code reference with any actions you want the mocked sub to perform
after it's been called.
=head2 reset
Resets all state of the object back to default (does not unmock the sub).
=head2 unmock
Restores original functionality of the mocked sub, and calls C<reset()> on the
object.
=cut
1;
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent.pm
View file @ 971eb4d6
...@@ -2,8 +2,8 @@ ...@@ -2,8 +2,8 @@
AnyEvent - the DBI of event loop programming AnyEvent - the DBI of event loop programming
EV, Event, Glib, Tk, Perl, Event::Lib, Irssi, rxvt-unicode, IO::Async, Qt, EV, Event, Glib, Tk, UV, Perl, Event::Lib, Irssi, rxvt-unicode, IO::Async,
FLTK and POE are various supported event loops/environments. Qt, FLTK and POE are various supported event loops/environments.
=head1 SYNOPSIS =head1 SYNOPSIS
...@@ -273,7 +273,7 @@ Example 2: fire an event after 0.5 seconds, then roughly every second. ...@@ -273,7 +273,7 @@ Example 2: fire an event after 0.5 seconds, then roughly every second.
my $w = AnyEvent->timer (after => 0.5, interval => 1, cb => sub { my $w = AnyEvent->timer (after => 0.5, interval => 1, cb => sub {
warn "timeout\n"; warn "timeout\n";
}; });
=head3 TIMING ISSUES =head3 TIMING ISSUES
...@@ -489,6 +489,10 @@ Example: fork a process and wait for it ...@@ -489,6 +489,10 @@ Example: fork a process and wait for it
my $done = AnyEvent->condvar; my $done = AnyEvent->condvar;
# this forks and immediately calls exit in the child. this
# normally has all sorts of bad consequences for your parent,
# so take this as an example only. always fork and exec,
# or call POSIX::_exit, in real code.
my $pid = fork or exit 5; my $pid = fork or exit 5;
my $w = AnyEvent->child ( my $w = AnyEvent->child (
...@@ -747,7 +751,7 @@ one call to C<begin>, so the condvar waits for all calls to C<end> before ...@@ -747,7 +751,7 @@ one call to C<begin>, so the condvar waits for all calls to C<end> before
sending. sending.
The ping example mentioned above is slightly more complicated, as the The ping example mentioned above is slightly more complicated, as the
there are results to be passwd back, and the number of tasks that are there are results to be passed back, and the number of tasks that are
begun can potentially be zero: begun can potentially be zero:
my $cv = AnyEvent->condvar; my $cv = AnyEvent->condvar;
...@@ -765,6 +769,10 @@ begun can potentially be zero: ...@@ -765,6 +769,10 @@ begun can potentially be zero:
$cv->end; $cv->end;
...
my $results = $cv->recv;
This code fragment supposedly pings a number of hosts and calls This code fragment supposedly pings a number of hosts and calls
C<send> after results for all then have have been gathered - in any C<send> after results for all then have have been gathered - in any
order. To achieve this, the code issues a call to C<begin> when it starts order. To achieve this, the code issues a call to C<begin> when it starts
...@@ -809,11 +817,15 @@ In list context, all parameters passed to C<send> will be returned, ...@@ -809,11 +817,15 @@ In list context, all parameters passed to C<send> will be returned,
in scalar context only the first one will be returned. in scalar context only the first one will be returned.
Note that doing a blocking wait in a callback is not supported by any Note that doing a blocking wait in a callback is not supported by any
event loop, that is, recursive invocation of a blocking C<< ->recv event loop, that is, recursive invocation of a blocking C<< ->recv >> is
>> is not allowed, and the C<recv> call will C<croak> if such a not allowed and the C<recv> call will C<croak> if such a condition is
condition is detected. This condition can be slightly loosened by using detected. This requirement can be dropped by relying on L<Coro::AnyEvent>
L<Coro::AnyEvent>, which allows you to do a blocking C<< ->recv >> from , which allows you to do a blocking C<< ->recv >> from any thread
any thread that doesn't run the event loop itself. that doesn't run the event loop itself. L<Coro::AnyEvent> is loaded
automatically when L<Coro> is used with L<AnyEvent>, so code does not need
to do anything special to take advantage of that: any code that would
normally block your program because it calls C<recv>, be executed in an
C<async> thread instead without blocking other threads.
Not all event models support a blocking wait - some die in that case Not all event models support a blocking wait - some die in that case
(programs might want to do that to stay interactive), so I<if you are (programs might want to do that to stay interactive), so I<if you are
...@@ -835,8 +847,8 @@ C<croak> have been called. ...@@ -835,8 +847,8 @@ C<croak> have been called.
=item $cb = $cv->cb ($cb->($cv)) =item $cb = $cv->cb ($cb->($cv))
This is a mutator function that returns the callback set and optionally This is a mutator function that returns the callback set (or C<undef> if
replaces it before doing so. not) and optionally replaces it before doing so.
The callback will be called when the condition becomes "true", i.e. when The callback will be called when the condition becomes "true", i.e. when
C<send> or C<croak> are called, with the only argument being the C<send> or C<croak> are called, with the only argument being the
...@@ -844,11 +856,16 @@ condition variable itself. If the condition is already true, the ...@@ -844,11 +856,16 @@ condition variable itself. If the condition is already true, the
callback is called immediately when it is set. Calling C<recv> inside callback is called immediately when it is set. Calling C<recv> inside
the callback or at any later time is guaranteed not to block. the callback or at any later time is guaranteed not to block.
Additionally, when the callback is invoked, it is also removed from the
condvar (reset to C<undef>), so the condvar does not keep a reference to
the callback after invocation.
=back =back
=head1 SUPPORTED EVENT LOOPS/BACKENDS =head1 SUPPORTED EVENT LOOPS/BACKENDS
The available backend classes are (every class has its own manpage): The following backend classes are part of the AnyEvent distribution (every
class has its own manpage):
=over 4 =over 4
...@@ -873,6 +890,7 @@ create watchers. Nothing special needs to be done by the main program. ...@@ -873,6 +890,7 @@ create watchers. Nothing special needs to be done by the main program.
AnyEvent::Impl::Event based on Event, very stable, few glitches. AnyEvent::Impl::Event based on Event, very stable, few glitches.
AnyEvent::Impl::Glib based on Glib, slow but very stable. AnyEvent::Impl::Glib based on Glib, slow but very stable.
AnyEvent::Impl::Tk based on Tk, very broken. AnyEvent::Impl::Tk based on Tk, very broken.
AnyEvent::Impl::UV based on UV, innovated square wheels.
AnyEvent::Impl::EventLib based on Event::Lib, leaks memory and worse. AnyEvent::Impl::EventLib based on Event::Lib, leaks memory and worse.
AnyEvent::Impl::POE based on POE, very slow, some limitations. AnyEvent::Impl::POE based on POE, very slow, some limitations.
AnyEvent::Impl::Irssi used when running within irssi. AnyEvent::Impl::Irssi used when running within irssi.
...@@ -907,6 +925,13 @@ AnyEvent knows about both L<Prima> and L<Wx>, however, and will try to ...@@ -907,6 +925,13 @@ AnyEvent knows about both L<Prima> and L<Wx>, however, and will try to
load L<POE> when detecting them, in the hope that POE will pick them up, load L<POE> when detecting them, in the hope that POE will pick them up,
in which case everything will be automatic. in which case everything will be automatic.
=item Known event loops outside the AnyEvent distribution
The following event loops or programs support AnyEvent by providing their
own AnyEvent backend. They will be picked up automatically.
urxvt::anyevent available to rxvt-unicode extensions
=back =back
=head1 GLOBAL VARIABLES AND FUNCTIONS =head1 GLOBAL VARIABLES AND FUNCTIONS
...@@ -947,13 +972,12 @@ Arranges for the code block to be executed as soon as the event model is ...@@ -947,13 +972,12 @@ Arranges for the code block to be executed as soon as the event model is
autodetected (or immediately if that has already happened). autodetected (or immediately if that has already happened).
The block will be executed I<after> the actual backend has been detected The block will be executed I<after> the actual backend has been detected
(C<$AnyEvent::MODEL> is set), but I<before> any watchers have been (C<$AnyEvent::MODEL> is set), so it is possible to do some initialisation
created, so it is possible to e.g. patch C<@AnyEvent::ISA> or do only when AnyEvent is actually initialised - see the sources of
other initialisations - see the sources of L<AnyEvent::Strict> or
L<AnyEvent::AIO> to see how this is used. L<AnyEvent::AIO> to see how this is used.
The most common usage is to create some global watchers, without forcing The most common usage is to create some global watchers, without forcing
event module detection too early, for example, L<AnyEvent::AIO> creates event module detection too early. For example, L<AnyEvent::AIO> creates
and installs the global L<IO::AIO> watcher in a C<post_detect> block to and installs the global L<IO::AIO> watcher in a C<post_detect> block to
avoid autodetecting the event module at load time. avoid autodetecting the event module at load time.
...@@ -980,9 +1004,15 @@ C<$WATCHER>, but do so only do so after the event loop is initialised. ...@@ -980,9 +1004,15 @@ C<$WATCHER>, but do so only do so after the event loop is initialised.
=item @AnyEvent::post_detect =item @AnyEvent::post_detect
If there are any code references in this array (you can C<push> to it This is a lower level interface then C<AnyEvent::post_detect> (the
before or after loading AnyEvent), then they will be called directly function). This variable is mainly useful for modules that can do
after the event loop has been chosen. something useful when AnyEvent is used and thus want to know when it
is initialised, but do not need to even load it by default. This array
provides the means to hook into AnyEvent passively, without loading it.
Here is how it works: If there are any code references in this array (you
can C<push> to it before or after loading AnyEvent), then they will be
called directly after the event loop has been chosen.
You should check C<$AnyEvent::MODEL> before adding to this array, though: You should check C<$AnyEvent::MODEL> before adding to this array, though:
if it is defined then the event loop has already been detected, and the if it is defined then the event loop has already been detected, and the
...@@ -991,11 +1021,6 @@ array will be ignored. ...@@ -991,11 +1021,6 @@ array will be ignored.
Best use C<AnyEvent::post_detect { BLOCK }> when your application allows Best use C<AnyEvent::post_detect { BLOCK }> when your application allows
it, as it takes care of these details. it, as it takes care of these details.
This variable is mainly useful for modules that can do something useful
when AnyEvent is used and thus want to know when it is initialised, but do
not need to even load it by default. This array provides the means to hook
into AnyEvent passively, without loading it.
Example: To load Coro::AnyEvent whenever Coro and AnyEvent are used Example: To load Coro::AnyEvent whenever Coro and AnyEvent are used
together, you could put this into Coro (this is the actual code used by together, you could put this into Coro (this is the actual code used by
Coro to accomplish this): Coro to accomplish this):
...@@ -1023,7 +1048,7 @@ asynchronously does something for you and returns some transaction ...@@ -1023,7 +1048,7 @@ asynchronously does something for you and returns some transaction
object or guard to let you cancel the operation. For example, object or guard to let you cancel the operation. For example,
C<AnyEvent::Socket::tcp_connect>: C<AnyEvent::Socket::tcp_connect>:
# start a conenction attempt unless one is active # start a connection attempt unless one is active
$self->{connect_guard} ||= AnyEvent::Socket::tcp_connect "www.example.net", 80, sub { $self->{connect_guard} ||= AnyEvent::Socket::tcp_connect "www.example.net", 80, sub {
delete $self->{connect_guard}; delete $self->{connect_guard};
... ...
...@@ -1067,6 +1092,12 @@ creating a logger callback with the C<AnyEvent::Log::logger> function, ...@@ -1067,6 +1092,12 @@ creating a logger callback with the C<AnyEvent::Log::logger> function,
which can reduce typing, codesize and can reduce the logging overhead which can reduce typing, codesize and can reduce the logging overhead
enourmously. enourmously.
=item AnyEvent::fh_block $filehandle
=item AnyEvent::fh_unblock $filehandle
Sets blocking or non-blocking behaviour for the given filehandle.
=back =back
=head1 WHAT TO DO IN A MODULE =head1 WHAT TO DO IN A MODULE
...@@ -1141,24 +1172,24 @@ modules of the AnyEvent author himself :) ...@@ -1141,24 +1172,24 @@ modules of the AnyEvent author himself :)
=over 4 =over 4
=item L<AnyEvent::Util> =item L<AnyEvent::Util> (part of the AnyEvent distribution)
Contains various utility functions that replace often-used blocking Contains various utility functions that replace often-used blocking
functions such as C<inet_aton> with event/callback-based versions. functions such as C<inet_aton> with event/callback-based versions.
=item L<AnyEvent::Socket> =item L<AnyEvent::Socket> (part of the AnyEvent distribution)
Provides various utility functions for (internet protocol) sockets, Provides various utility functions for (internet protocol) sockets,
addresses and name resolution. Also functions to create non-blocking tcp addresses and name resolution. Also functions to create non-blocking tcp
connections or tcp servers, with IPv6 and SRV record support and more. connections or tcp servers, with IPv6 and SRV record support and more.
=item L<AnyEvent::Handle> =item L<AnyEvent::Handle> (part of the AnyEvent distribution)
Provide read and write buffers, manages watchers for reads and writes, Provide read and write buffers, manages watchers for reads and writes,
supports raw and formatted I/O, I/O queued and fully transparent and supports raw and formatted I/O, I/O queued and fully transparent and
non-blocking SSL/TLS (via L<AnyEvent::TLS>). non-blocking SSL/TLS (via L<AnyEvent::TLS>).
=item L<AnyEvent::DNS> =item L<AnyEvent::DNS> (part of the AnyEvent distribution)
Provides rich asynchronous DNS resolver capabilities. Provides rich asynchronous DNS resolver capabilities.
...@@ -1168,13 +1199,24 @@ Implement event-based interfaces to the protocols of the same name (for ...@@ -1168,13 +1199,24 @@ Implement event-based interfaces to the protocols of the same name (for
the curious, IGS is the International Go Server and FCP is the Freenet the curious, IGS is the International Go Server and FCP is the Freenet
Client Protocol). Client Protocol).
=item L<AnyEvent::AIO> =item L<AnyEvent::AIO> (part of the AnyEvent distribution)
Truly asynchronous (as opposed to non-blocking) I/O, should be in the Truly asynchronous (as opposed to non-blocking) I/O, should be in the
toolbox of every event programmer. AnyEvent::AIO transparently fuses toolbox of every event programmer. AnyEvent::AIO transparently fuses
L<IO::AIO> and AnyEvent together, giving AnyEvent access to event-based L<IO::AIO> and AnyEvent together, giving AnyEvent access to event-based
file I/O, and much more. file I/O, and much more.
=item L<AnyEvent::Fork>, L<AnyEvent::Fork::RPC>, L<AnyEvent::Fork::Pool>, L<AnyEvent::Fork::Remote>
These let you safely fork new subprocesses, either locally or
remotely (e.g.v ia ssh), using some RPC protocol or not, without
the limitations normally imposed by fork (AnyEvent works fine for
example). Dynamically-resized worker pools are obviously included as well.
And they are quite tiny and fast as well - "abusing" L<AnyEvent::Fork>
just to exec external programs can easily beat using C<fork> and C<exec>
(or even C<system>) in most programs.
=item L<AnyEvent::Filesys::Notify> =item L<AnyEvent::Filesys::Notify>
AnyEvent is good for non-blocking stuff, but it can't detect file or AnyEvent is good for non-blocking stuff, but it can't detect file or
...@@ -1185,18 +1227,14 @@ some weird, without doubt broken, stuff on OS X to monitor files. It can ...@@ -1185,18 +1227,14 @@ some weird, without doubt broken, stuff on OS X to monitor files. It can
fall back to blocking scans at regular intervals transparently on other fall back to blocking scans at regular intervals transparently on other
platforms, so it's about as portable as it gets. platforms, so it's about as portable as it gets.
(I haven't used it myself, but I haven't heard anybody complaining about (I haven't used it myself, but it seems the biggest problem with it is
it yet). it quite bad performance).
=item L<AnyEvent::DBI> =item L<AnyEvent::DBI>
Executes L<DBI> requests asynchronously in a proxy process for you, Executes L<DBI> requests asynchronously in a proxy process for you,
notifying you in an event-based way when the operation is finished. notifying you in an event-based way when the operation is finished.
=item L<AnyEvent::HTTPD>
A simple embedded webserver.
=item L<AnyEvent::FastPing> =item L<AnyEvent::FastPing>
The fastest ping in the west. The fastest ping in the west.
...@@ -1223,20 +1261,14 @@ to simply invert the flow control - don't call us, we will call you: ...@@ -1223,20 +1261,14 @@ to simply invert the flow control - don't call us, we will call you:
package AnyEvent; package AnyEvent;
# basically a tuned-down version of common::sense BEGIN {
sub common_sense { require "AnyEvent/constants.pl";
# from common:.sense 3.5 &AnyEvent::common_sense;
local $^W;
${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "\x3c\x3f\x33\x00\x0f\xf0\x0f\xc0\xf0\xfc\x33\x00";
# use strict vars subs - NO UTF-8, as Util.pm doesn't like this atm. (uts46data.pl)
$^H |= 0x00000600;
} }
BEGIN { AnyEvent::common_sense }
use Carp (); use Carp ();
our $VERSION = '7.04'; our $VERSION = 7.17;
our $MODEL; our $MODEL;
our @ISA; our @ISA;
our @REGISTRY; our @REGISTRY;
...@@ -1245,8 +1277,6 @@ our %PROTOCOL; # (ipv4|ipv6) => (1|2), higher numbers are preferred ...@@ -1245,8 +1277,6 @@ our %PROTOCOL; # (ipv4|ipv6) => (1|2), higher numbers are preferred
our $MAX_SIGNAL_LATENCY = $ENV{PERL_ANYEVENT_MAX_SIGNAL_LATENCY} || 10; # executes after the BEGIN block below (tainting!) our $MAX_SIGNAL_LATENCY = $ENV{PERL_ANYEVENT_MAX_SIGNAL_LATENCY} || 10; # executes after the BEGIN block below (tainting!)
BEGIN { BEGIN {
require "AnyEvent/constants.pl";
eval "sub TAINT (){" . (${^TAINT}*1) . "}"; eval "sub TAINT (){" . (${^TAINT}*1) . "}";
delete @ENV{grep /^PERL_ANYEVENT_/, keys %ENV} delete @ENV{grep /^PERL_ANYEVENT_/, keys %ENV}
...@@ -1345,6 +1375,25 @@ if (length $ENV{PERL_ANYEVENT_LOG}) { ...@@ -1345,6 +1375,25 @@ if (length $ENV{PERL_ANYEVENT_LOG}) {
require AnyEvent::Log; # AnyEvent::Log does the thing for us require AnyEvent::Log; # AnyEvent::Log does the thing for us
} }
BEGIN {
*_fh_nonblocking = AnyEvent::WIN32
? sub($$) {
ioctl $_[0], 0x8004667e, pack "L", $_[1]; # FIONBIO
}
: sub($$) {
fcntl $_[0], AnyEvent::F_SETFL, $_[1] ? AnyEvent::O_NONBLOCK : 0;
}
;
}
sub fh_block($) {
_fh_nonblocking shift, 0
}
sub fh_unblock($) {
_fh_nonblocking shift, 1
}
our @models = ( our @models = (
[EV:: => AnyEvent::Impl::EV::], [EV:: => AnyEvent::Impl::EV::],
[AnyEvent::Loop:: => AnyEvent::Impl::Perl::], [AnyEvent::Loop:: => AnyEvent::Impl::Perl::],
...@@ -1357,6 +1406,7 @@ our @models = ( ...@@ -1357,6 +1406,7 @@ our @models = (
# everything below here should not be autoloaded # everything below here should not be autoloaded
[Event::Lib:: => AnyEvent::Impl::EventLib::], # too buggy [Event::Lib:: => AnyEvent::Impl::EventLib::], # too buggy
[Tk:: => AnyEvent::Impl::Tk::], # crashes with many handles [Tk:: => AnyEvent::Impl::Tk::], # crashes with many handles
[UV:: => AnyEvent::Impl::UV::], # switched from libev, added back all bugs imaginable
[Qt:: => AnyEvent::Impl::Qt::], # requires special main program [Qt:: => AnyEvent::Impl::Qt::], # requires special main program
[POE::Kernel:: => AnyEvent::Impl::POE::], # lasciate ogni speranza [POE::Kernel:: => AnyEvent::Impl::POE::], # lasciate ogni speranza
[Wx:: => AnyEvent::Impl::POE::], [Wx:: => AnyEvent::Impl::POE::],
...@@ -1555,7 +1605,7 @@ package AE; ...@@ -1555,7 +1605,7 @@ package AE;
our $VERSION = $AnyEvent::VERSION; our $VERSION = $AnyEvent::VERSION;
sub _reset() { sub _reset() {
eval q{ eval q{
# fall back to the main API by default - backends and AnyEvent::Base # fall back to the main API by default - backends and AnyEvent::Base
# implementations can overwrite these. # implementations can overwrite these.
...@@ -2201,7 +2251,7 @@ list. ...@@ -2201,7 +2251,7 @@ list.
This variable can effectively be used for denial-of-service attacks This variable can effectively be used for denial-of-service attacks
against local programs (e.g. when setuid), although the impact is likely against local programs (e.g. when setuid), although the impact is likely
small, as the program has to handle conenction and other failures anyways. small, as the program has to handle connection and other failures anyways.
Examples: C<PERL_ANYEVENT_PROTOCOLS=ipv4,ipv6> - prefer IPv4 over IPv6, Examples: C<PERL_ANYEVENT_PROTOCOLS=ipv4,ipv6> - prefer IPv4 over IPv6,
but support both and try to use both. C<PERL_ANYEVENT_PROTOCOLS=ipv4> but support both and try to use both. C<PERL_ANYEVENT_PROTOCOLS=ipv4>
...@@ -2455,7 +2505,7 @@ anything about events. ...@@ -2455,7 +2505,7 @@ anything about events.
... ...
}); });
EV::loop; EV::run;
3b. The module user could use AnyEvent, too: 3b. The module user could use AnyEvent, too:
...@@ -2923,6 +2973,16 @@ chosen event library does not come with a timing source of its own. The ...@@ -2923,6 +2973,16 @@ chosen event library does not come with a timing source of its own. The
pure-perl event loop (L<AnyEvent::Loop>) will additionally load it to pure-perl event loop (L<AnyEvent::Loop>) will additionally load it to
try to use a monotonic clock for timing stability. try to use a monotonic clock for timing stability.
=item L<AnyEvent::AIO> (and L<IO::AIO>)
The default implementation of L<AnyEvent::IO> is to do I/O synchronously,
stopping programs while they access the disk, which is fine for a lot of
programs.
Installing AnyEvent::AIO (and its IO::AIO dependency) makes it switch to
a true asynchronous implementation, so event processing can continue even
while waiting for disk I/O.
=back =back
...@@ -2943,17 +3003,35 @@ is loaded). ...@@ -2943,17 +3003,35 @@ is loaded).
If you have to fork, you must either do so I<before> creating your first If you have to fork, you must either do so I<before> creating your first
watcher OR you must not use AnyEvent at all in the child OR you must do watcher OR you must not use AnyEvent at all in the child OR you must do
something completely out of the scope of AnyEvent. something completely out of the scope of AnyEvent (see below).
The problem of doing event processing in the parent I<and> the child The problem of doing event processing in the parent I<and> the child
is much more complicated: even for backends that I<are> fork-aware or is much more complicated: even for backends that I<are> fork-aware or
fork-safe, their behaviour is not usually what you want: fork clones all fork-safe, their behaviour is not usually what you want: fork clones all
watchers, that means all timers, I/O watchers etc. are active in both watchers, that means all timers, I/O watchers etc. are active in both
parent and child, which is almost never what you want. USing C<exec> parent and child, which is almost never what you want. Using C<exec>
to start worker children from some kind of manage rprocess is usually to start worker children from some kind of manage prrocess is usually
preferred, because it is much easier and cleaner, at the expense of having preferred, because it is much easier and cleaner, at the expense of having
to have another binary. to have another binary.
In addition to logical problems with fork, there are also implementation
problems. For example, on POSIX systems, you cannot fork at all in Perl
code if a thread (I am talking of pthreads here) was ever created in the
process, and this is just the tip of the iceberg. In general, using fork
from Perl is difficult, and attempting to use fork without an exec to
implement some kind of parallel processing is almost certainly doomed.
To safely fork and exec, you should use a module such as
L<Proc::FastSpawn> that let's you safely fork and exec new processes.
If you want to do multiprocessing using processes, you can
look at the L<AnyEvent::Fork> module (and some related modules
such as L<AnyEvent::Fork::RPC>, L<AnyEvent::Fork::Pool> and
L<AnyEvent::Fork::Remote>). This module allows you to safely create
subprocesses without any limitations - you can use X11 toolkits or
AnyEvent in the children created by L<AnyEvent::Fork> safely and without
any special precautions.
=head1 SECURITY CONSIDERATIONS =head1 SECURITY CONSIDERATIONS
...@@ -3004,13 +3082,13 @@ L<AnyEvent::Debug> (interactive shell, watcher tracing). ...@@ -3004,13 +3082,13 @@ L<AnyEvent::Debug> (interactive shell, watcher tracing).
Supported event modules: L<AnyEvent::Loop>, L<EV>, L<EV::Glib>, Supported event modules: L<AnyEvent::Loop>, L<EV>, L<EV::Glib>,
L<Glib::EV>, L<Event>, L<Glib::Event>, L<Glib>, L<Tk>, L<Event::Lib>, L<Glib::EV>, L<Event>, L<Glib::Event>, L<Glib>, L<Tk>, L<Event::Lib>,
L<Qt>, L<POE>, L<FLTK>. L<Qt>, L<POE>, L<FLTK>, L<Cocoa::EventLoop>, L<UV>.
Implementations: L<AnyEvent::Impl::EV>, L<AnyEvent::Impl::Event>, Implementations: L<AnyEvent::Impl::EV>, L<AnyEvent::Impl::Event>,
L<AnyEvent::Impl::Glib>, L<AnyEvent::Impl::Tk>, L<AnyEvent::Impl::Perl>, L<AnyEvent::Impl::Glib>, L<AnyEvent::Impl::Tk>, L<AnyEvent::Impl::Perl>,
L<AnyEvent::Impl::EventLib>, L<AnyEvent::Impl::Qt>, L<AnyEvent::Impl::EventLib>, L<AnyEvent::Impl::Qt>,
L<AnyEvent::Impl::POE>, L<AnyEvent::Impl::IOAsync>, L<Anyevent::Impl::Irssi>, L<AnyEvent::Impl::POE>, L<AnyEvent::Impl::IOAsync>, L<AnyEvent::Impl::Irssi>,
L<AnyEvent::Impl::FLTK>. L<AnyEvent::Impl::FLTK>, L<AnyEvent::Impl::Cocoa>, L<AnyEvent::Impl::UV>.
Non-blocking handles, pipes, stream sockets, TCP clients and Non-blocking handles, pipes, stream sockets, TCP clients and
servers: L<AnyEvent::Handle>, L<AnyEvent::Socket>, L<AnyEvent::TLS>. servers: L<AnyEvent::Handle>, L<AnyEvent::Socket>, L<AnyEvent::TLS>.
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/DNS.pm
View file @ 971eb4d6
...@@ -47,14 +47,29 @@ our @DNS_FALLBACK; # some public dns servers as fallback ...@@ -47,14 +47,29 @@ our @DNS_FALLBACK; # some public dns servers as fallback
my $ipv4 = $prep->( my $ipv4 = $prep->(
["08080808", "08080404"], # 8.8.8.8, 8.8.4.4 - google public dns ["08080808", "08080404"], # 8.8.8.8, 8.8.4.4 - google public dns
# ["d1f40003", "d1f30004"], # v209.244.0.3/4 - resolver1/2.level3.net - status unknown ["01010101", "01000001"], # 1.1.1.1, 1.0.0.1 - cloudflare public dns
["04020201", "04020203", "04020204", "04020205", "04020206"], # v4.2.2.1/3/4/5/6 - vnsc-pri.sys.gtei.net - effectively public ["50505050", "50505151"], # 80.80.80.80, 80.80.81.81 - freenom.world
["cdd22ad2", "4044c8c8"], # 205.210.42.205, 64.68.200.200 - cache1/2.dnsresolvers.com - verified public ## ["d1f40003", "d1f30004"], # v209.244.0.3/4 - resolver1/2.level3.net - status unknown
# ["8d010101"], # 141.1.1.1 - cable&wireless - status unknown ## ["04020201", "04020203", "04020204", "04020205", "04020206"], # v4.2.2.1/3/4/5/6 - vnsc-pri.sys.gtei.net - effectively public
## ["cdd22ad2", "4044c8c8"], # 205.210.42.205, 64.68.200.200 - cache1/2.dnsresolvers.com - verified public
# ["8d010101"], # 141.1.1.1 - cable&wireless, now vodafone - status unknown
# 84.200.69.80 # dns.watch
# 84.200.70.40 # dns.watch
# 37.235.1.174 # freedns.zone
# 37.235.1.177 # freedns.zone
# 213.73.91.35 # dnscache.berlin.ccc.de
# 194.150.168.168 # dns.as250.net; Berlin/Frankfurt
# 85.214.20.141 # FoeBud (digitalcourage.de)
# 77.109.148.136 # privacyfoundation.ch
# 77.109.148.137 # privacyfoundation.ch
# 91.239.100.100 # anycast.censurfridns.dk
# 89.233.43.71 # ns1.censurfridns.dk
# 204.152.184.76 # f.6to4-servers.net, ISC, USA
); );
my $ipv6 = $prep->( my $ipv6 = $prep->(
["20014860486000000000000000008888", "20014860486000000000000000008844"], # 2001:4860:4860::8888/8844 - google ipv6 ["20014860486000000000000000008888", "20014860486000000000000000008844"], # 2001:4860:4860::8888/8844 - google ipv6
["26064700470000000000000000001111", "26064700470000000000000000001001"], # 2606:4700:4700::1111/1001 - cloudflare dns
); );
undef $ipv4 unless $AnyEvent::PROTOCOL{ipv4}; undef $ipv4 unless $AnyEvent::PROTOCOL{ipv4};
...@@ -101,7 +116,7 @@ strings, you need to call the resolver manually: ...@@ -101,7 +116,7 @@ strings, you need to call the resolver manually:
Tries to resolve the given service, protocol and domain name into a list Tries to resolve the given service, protocol and domain name into a list
of service records. of service records.
Each C<$srv_rr> is an array reference with the following contents: Each C<$srv_rr> is an array reference with the following contents:
C<[$priority, $weight, $transport, $target]>. C<[$priority, $weight, $transport, $target]>.
They will be sorted with lowest priority first, then randomly They will be sorted with lowest priority first, then randomly
...@@ -114,8 +129,9 @@ Example: ...@@ -114,8 +129,9 @@ Example:
=item AnyEvent::DNS::any $domain, $cb->(@rrs) =item AnyEvent::DNS::any $domain, $cb->(@rrs)
Tries to resolve the given domain and passes all resource records found to Tries to resolve the given domain and passes all resource records found
the callback. to the callback. Note that this uses a DNS C<ANY> query, which, as of RFC
8482, are officially deprecated.
=item AnyEvent::DNS::ptr $domain, $cb->(@hostnames) =item AnyEvent::DNS::ptr $domain, $cb->(@hostnames)
...@@ -385,11 +401,25 @@ our %type_id = ( ...@@ -385,11 +401,25 @@ our %type_id = (
minfo => 14, minfo => 14,
mx => 15, mx => 15,
txt => 16, txt => 16,
sig => 24,
key => 25,
gpos => 27, # rfc1712
aaaa => 28, aaaa => 28,
loc => 29, # rfc1876
srv => 33, srv => 33,
naptr => 35, # rfc2915 naptr => 35, # rfc2915
dname => 39, # rfc2672 dname => 39, # rfc2672
opt => 41, opt => 41,
ds => 43, # rfc4034
sshfp => 44, # rfc4255
rrsig => 46, # rfc4034
nsec => 47, # rfc4034
dnskey=> 48, # rfc4034
smimea=> 53, # rfc8162
cds => 59, # rfc7344
cdnskey=> 60, # rfc7344
openpgpkey=> 61, # rfc7926
csync => 62, # rfc7929
spf => 99, spf => 99,
tkey => 249, tkey => 249,
tsig => 250, tsig => 250,
...@@ -397,6 +427,8 @@ our %type_id = ( ...@@ -397,6 +427,8 @@ our %type_id = (
axfr => 252, axfr => 252,
mailb => 253, mailb => 253,
"*" => 255, "*" => 255,
uri => 256,
caa => 257, # rfc6844
); );
our %type_str = reverse %type_id; our %type_str = reverse %type_id;
...@@ -557,6 +589,7 @@ our %dec_rr = ( ...@@ -557,6 +589,7 @@ our %dec_rr = (
}, },
39 => sub { local $ofs = $ofs - length; _dec_name }, # dname 39 => sub { local $ofs = $ofs - length; _dec_name }, # dname
99 => sub { unpack "(C/a*)*", $_ }, # spf 99 => sub { unpack "(C/a*)*", $_ }, # spf
257 => sub { unpack "CC/a*a*", $_ }, # caa
); );
sub _dec_rr { sub _dec_rr {
...@@ -605,7 +638,8 @@ Examples: ...@@ -605,7 +638,8 @@ Examples:
'aa' => '', 'aa' => '',
'an' => [], 'an' => [],
'rd' => 1, 'rd' => 1,
'op' => 'query' 'op' => 'query',
'__' => '<original dns packet>',
} }
# a successful reply # a successful reply
...@@ -634,7 +668,8 @@ Examples: ...@@ -634,7 +668,8 @@ Examples:
[ 'www.l.google.com', 'a', 'in', 3600, '66.249.93.147' ], [ 'www.l.google.com', 'a', 'in', 3600, '66.249.93.147' ],
], ],
'rd' => 1, 'rd' => 1,
'op' => 0 'op' => 0,
'__' => '<original dns packet>',
} }
=cut =cut
...@@ -647,6 +682,7 @@ sub dns_unpack($) { ...@@ -647,6 +682,7 @@ sub dns_unpack($) {
local $ofs = 6 * 2; local $ofs = 6 * 2;
{ {
__ => $pkt,
id => $id, id => $id,
qr => ! ! ($flags & 0x8000), qr => ! ! ($flags & 0x8000),
aa => ! ! ($flags & 0x0400), aa => ! ! ($flags & 0x0400),
...@@ -669,6 +705,70 @@ sub dns_unpack($) { ...@@ -669,6 +705,70 @@ sub dns_unpack($) {
=back =back
=head3 Extending DNS Encoder and Decoder
This section describes an I<experimental> method to extend the DNS encoder
and decoder with new opcode, rcode, class and type strings, as well as
resource record decoders.
Since this is experimental, it can change, as anything can change, but
this interface is expe ctedc to be relatively stable and was stable during
the whole existance of C<AnyEvent::DNS> so far.
Note that, since changing the decoder or encoder might break existing
code, you should either be sure to control for this, or only temporarily
change these values, e.g. like so:
my $decoded = do {
local $AnyEvent::DNS::opcode_str{7} = "yxrrset";
AnyEvent::DNS::dns_unpack $mypkt
};
=over 4
=item %AnyEvent::DNS::opcode_id, %AnyEvent::DNS::opcode_str
Two hashes that map lowercase opcode strings to numerical id's (For the
encoder), or vice versa (for the decoder). Example: add a new opcode
string C<notzone>.
$AnyEvent::DNS::opcode_id{notzone} = 10;
$AnyEvent::DNS::opcode_str{10} = 'notzone';
=item %AnyEvent::DNS::rcode_id, %AnyEvent::DNS::rcode_str
Same as above, for for rcode values.
=item %AnyEvent::DNS::class_id, %AnyEvent::DNS::class_str
Same as above, but for resource record class names/values.
=item %AnyEvent::DNS::type_id, %AnyEvent::DNS::type_str
Same as above, but for resource record type names/values.
=item %AnyEvent::DNS::dec_rr
This hash maps resource record type values to code references. When
decoding, they are called with C<$_> set to the undecoded data portion and
C<$ofs> being the current byte offset. of the record. You should have a
look at the existing implementations to understand how it works in detail,
but here are two examples:
Decode an A record. A records are simply four bytes with one byte per
address component, so the decoder simply unpacks them and joins them with
dots in between:
$AnyEvent::DNS::dec_rr{1} = sub { join ".", unpack "C4", $_ };
Decode a CNAME record, which contains a potentially compressed domain
name.
package AnyEvent::DNS; # for %dec_rr, $ofsd and &_dec_name
$dec_rr{5} = sub { local $ofs = $ofs - length; _dec_name };
=back
=head2 THE AnyEvent::DNS RESOLVER CLASS =head2 THE AnyEvent::DNS RESOLVER CLASS
This is the class which does the actual protocol work. This is the class which does the actual protocol work.
...@@ -698,7 +798,7 @@ resolver object. ...@@ -698,7 +798,7 @@ resolver object.
The resolver is created with the following parameters: The resolver is created with the following parameters:
untaint enabled untaint enabled
max_outstanding $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS} max_outstanding $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS} (default 10)
C<os_config> will be used for OS-specific configuration, unless C<os_config> will be used for OS-specific configuration, unless
C<$ENV{PERL_ANYEVENT_RESOLV_CONF}> is specified, in which case that file C<$ENV{PERL_ANYEVENT_RESOLV_CONF}> is specified, in which case that file
...@@ -722,7 +822,7 @@ sub resolver() { ...@@ -722,7 +822,7 @@ sub resolver() {
$RESOLVER || do { $RESOLVER || do {
$RESOLVER = new AnyEvent::DNS $RESOLVER = new AnyEvent::DNS
untaint => 1, untaint => 1,
max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 1, max_outstanding => $ENV{PERL_ANYEVENT_MAX_OUTSTANDING_DNS}*1 || 10,
; ;
$ENV{PERL_ANYEVENT_RESOLV_CONF} $ENV{PERL_ANYEVENT_RESOLV_CONF}
...@@ -812,7 +912,7 @@ sub new { ...@@ -812,7 +912,7 @@ sub new {
if (socket my $fh4, AF_INET , Socket::SOCK_DGRAM(), 0) { if (socket my $fh4, AF_INET , Socket::SOCK_DGRAM(), 0) {
++$got_socket; ++$got_socket;
AnyEvent::Util::fh_nonblocking $fh4, 1; AnyEvent::fh_unblock $fh4;
$self->{fh4} = $fh4; $self->{fh4} = $fh4;
$self->{rw4} = AE::io $fh4, 0, sub { $self->{rw4} = AE::io $fh4, 0, sub {
if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) { if (my $peer = recv $fh4, my $pkt, MAX_PKT, 0) {
...@@ -825,7 +925,7 @@ sub new { ...@@ -825,7 +925,7 @@ sub new {
++$got_socket; ++$got_socket;
$self->{fh6} = $fh6; $self->{fh6} = $fh6;
AnyEvent::Util::fh_nonblocking $fh6, 1; AnyEvent::fh_unblock $fh6;
$self->{rw6} = AE::io $fh6, 0, sub { $self->{rw6} = AE::io $fh6, 0, sub {
if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) { if (my $peer = recv $fh6, my $pkt, MAX_PKT, 0) {
$wself->_recv ($pkt, $peer); $wself->_recv ($pkt, $peer);
...@@ -1106,7 +1206,7 @@ sub _recv { ...@@ -1106,7 +1206,7 @@ sub _recv {
my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer); my ($port, $host) = AnyEvent::Socket::unpack_sockaddr ($peer);
return unless $port == 53 && grep $_ eq $host, @{ $self->{server} }; return unless $port == DOMAIN_PORT && grep $_ eq $host, @{ $self->{server} };
$self->_feed ($pkt); $self->_feed ($pkt);
} }
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Debug.pm
View file @ 971eb4d6
...@@ -46,7 +46,7 @@ our %STRCACHE; ...@@ -46,7 +46,7 @@ our %STRCACHE;
This function binds on the given host and service port and returns a This function binds on the given host and service port and returns a
shell object, which determines the lifetime of the shell. Any number shell object, which determines the lifetime of the shell. Any number
of conenctions are accepted on the port, and they will give you a very of connections are accepted on the port, and they will give you a very
primitive shell that simply executes every line you enter. primitive shell that simply executes every line you enter.
All commands will be executed "blockingly" with the socket C<select>ed for All commands will be executed "blockingly" with the socket C<select>ed for
...@@ -122,16 +122,37 @@ sub shell($$) { ...@@ -122,16 +122,37 @@ sub shell($$) {
$logger_guard if 0; # reference it $logger_guard if 0; # reference it
if (defined $len ? $len == 0 : $! != Errno::EAGAIN) { if (defined $len ? $len == 0 : ($! != Errno::EAGAIN && $! != Errno::EWOULDBLOCK)) {
undef $rw; undef $rw;
} else { } else {
while ($rbuf =~ s/^(.*)\015?\012//) { while ($rbuf =~ s/^(.*)\015?\012//) {
my $line = $1; my $line = $1;
AnyEvent::Util::fh_nonblocking $fh, 0; AnyEvent::fh_block $fh;
if ($line =~ /^\s*exit\b/) { if ($line =~ /^\s*exit\b/) {
syswrite $fh, "sorry, no... if you want to execute exit, try CORE::exit.\015\012"; syswrite $fh, "sorry, no... if you want to execute exit, try CORE::exit.\015\012";
} elsif ($line =~ /^\s*coro\b\s*(.*)/) {
my $arg = $1;
if (eval { require Coro; require Coro::Debug }) {
if ($arg =~ /\S/) {
Coro::async (sub {
select $fh;
Coro::Debug::command ($arg);
local $| = 1; # older Coro versions do not flush
syswrite $fh, "> ";
});
return;
} else {
undef $rw;
syswrite $fh, "switching to Coro::Debug...\015\012";
Coro::async (sub { Coro::Debug::session ($fh) });
return;
}
} else {
syswrite $fh, "Coro not available.\015\012";
}
} else { } else {
package AnyEvent::Debug::shell; package AnyEvent::Debug::shell;
...@@ -154,7 +175,7 @@ sub shell($$) { ...@@ -154,7 +175,7 @@ sub shell($$) {
} }
syswrite $fh, "> "; syswrite $fh, "> ";
AnyEvent::Util::fh_nonblocking $fh, 1; AnyEvent::fh_unblock $fh;
} }
} }
}; };
...@@ -178,6 +199,8 @@ ut disable tracing for newly created watchers ...@@ -178,6 +199,8 @@ ut disable tracing for newly created watchers
t id,... enable tracing for the given watcher (enabled by default) t id,... enable tracing for the given watcher (enabled by default)
ut id,... disable tracing for the given watcher ut id,... disable tracing for the given watcher
w id,... converts the watcher ids to watcher objects (for scripting) w id,... converts the watcher ids to watcher objects (for scripting)
coro xxx run xxx as Coro::Debug shell command, if available
coro switch to Coro::Debug shell, if available
EOF EOF
} }
...@@ -623,7 +646,7 @@ sub verbose { ...@@ -623,7 +646,7 @@ sub verbose {
my $res = "type: $self->{type} watcher\n" my $res = "type: $self->{type} watcher\n"
. "args: " . (join " ", %{ $self->{arg} }) . "\n" # TODO: decode fh? . "args: " . (join " ", %{ $self->{arg} }) . "\n" # TODO: decode fh?
. "created: " . (AnyEvent::Log::ft $self->{now}) . " ($self->{now})\n" . "created: " . (AnyEvent::Log::format_time $self->{now}) . " ($self->{now})\n"
. "file: ${ $self->{rfile} }\n" . "file: ${ $self->{rfile} }\n"
. "line: $self->{line}\n" . "line: $self->{line}\n"
. "subname: $self->{sub}\n" . "subname: $self->{sub}\n"
...@@ -639,7 +662,7 @@ sub verbose { ...@@ -639,7 +662,7 @@ sub verbose {
if (exists $self->{error}) { if (exists $self->{error}) {
$res .= "errors: " . @{$self->{error}} . "\n"; $res .= "errors: " . @{$self->{error}} . "\n";
$res .= "error: " . (AnyEvent::Log::ft $_->[0]) . " ($_->[0]) $_->[1]\n" $res .= "error: " . (AnyEvent::Log::format_time $_->[0]) . " ($_->[0]) $_->[1]\n"
for @{$self->{error}}; for @{$self->{error}};
} }
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Handle.pm
View file @ 971eb4d6
...@@ -32,8 +32,10 @@ AnyEvent::Handle - non-blocking I/O on streaming handles via AnyEvent ...@@ -32,8 +32,10 @@ AnyEvent::Handle - non-blocking I/O on streaming handles via AnyEvent
=head1 DESCRIPTION =head1 DESCRIPTION
This is a helper module to make it easier to do event-based I/O on This is a helper module to make it easier to do event-based I/O
stream-based filehandles (sockets, pipes, and other stream things). on stream-based filehandles (sockets, pipes, and other stream
things). Specifically, it doesn't work as expected on files, packet-based
sockets or similar things.
The L<AnyEvent::Intro> tutorial contains some well-documented The L<AnyEvent::Intro> tutorial contains some well-documented
AnyEvent::Handle examples. AnyEvent::Handle examples.
...@@ -55,7 +57,7 @@ package AnyEvent::Handle; ...@@ -55,7 +57,7 @@ package AnyEvent::Handle;
use Scalar::Util (); use Scalar::Util ();
use List::Util (); use List::Util ();
use Carp (); use Carp ();
use Errno qw(EAGAIN EINTR); use Errno qw(EAGAIN EWOULDBLOCK EINTR);
use AnyEvent (); BEGIN { AnyEvent::common_sense } use AnyEvent (); BEGIN { AnyEvent::common_sense }
use AnyEvent::Util qw(WSAEWOULDBLOCK); use AnyEvent::Util qw(WSAEWOULDBLOCK);
...@@ -93,7 +95,7 @@ The constructor supports these arguments (all as C<< key => value >> pairs). ...@@ -93,7 +95,7 @@ The constructor supports these arguments (all as C<< key => value >> pairs).
The filehandle this L<AnyEvent::Handle> object will operate on. The filehandle this L<AnyEvent::Handle> object will operate on.
NOTE: The filehandle will be set to non-blocking mode (using NOTE: The filehandle will be set to non-blocking mode (using
C<AnyEvent::Util::fh_nonblocking>) by the constructor and needs to stay in C<AnyEvent::fh_unblock>) by the constructor and needs to stay in
that mode. that mode.
=item connect => [$host, $service] [C<fh> or C<connect> MANDATORY] =item connect => [$host, $service] [C<fh> or C<connect> MANDATORY]
...@@ -134,9 +136,6 @@ parameters, together with a retry callback. At the time it is called the ...@@ -134,9 +136,6 @@ parameters, together with a retry callback. At the time it is called the
read and write queues, EOF status, TLS status and similar properties of read and write queues, EOF status, TLS status and similar properties of
the handle will have been reset. the handle will have been reset.
It is not allowed to use the read or write queues while the handle object
is connecting.
If, for some reason, the handle is not acceptable, calling C<$retry> will If, for some reason, the handle is not acceptable, calling C<$retry> will
continue with the next connection target (in case of multi-homed hosts or continue with the next connection target (in case of multi-homed hosts or
SRV records there can be multiple connection endpoints). The C<$retry> SRV records there can be multiple connection endpoints). The C<$retry>
...@@ -498,16 +497,43 @@ callback. ...@@ -498,16 +497,43 @@ callback.
This callback will only be called on TLS shutdowns, not when the This callback will only be called on TLS shutdowns, not when the
underlying handle signals EOF. underlying handle signals EOF.
=item json => JSON or JSON::XS object =item json => L<JSON>, L<JSON::PP> or L<JSON::XS> object
This is the json coder object used by the C<json> read and write types. This is the json coder object used by the C<json> read and write types.
If you don't supply it, then AnyEvent::Handle will create and use a If you don't supply it, then AnyEvent::Handle will create and use a
suitable one (on demand), which will write and expect UTF-8 encoded JSON suitable one (on demand), which will write and expect UTF-8 encoded
texts. JSON texts (either using L<JSON::XS> or L<JSON>). The written texts are
guaranteed not to contain any newline character.
For security reasons, this encoder will likely I<not> handle numbers and
strings, only arrays and objects/hashes. The reason is that originally
JSON was self-delimited, but Dougles Crockford thought it was a splendid
idea to redefine JSON incompatibly, so this is no longer true.
For protocols that used back-to-back JSON texts, this might lead to
run-ins, where two or more JSON texts will be interpreted as one JSON
text.
For this reason, if the default encoder uses L<JSON::XS>, it will default
to not allowing anything but arrays and objects/hashes, at least for the
forseeable future (it will change at some point). This might or might not
be true for the L<JSON> module, so this might cause a security issue.
If you depend on either behaviour, you should create your own json object
and pass it in explicitly.
=item cbor => L<CBOR::XS> object
This is the cbor coder object used by the C<cbor> read and write types.
If you don't supply it, then AnyEvent::Handle will create and use a
suitable one (on demand), which will write CBOR without using extensions,
if possible.
Note that you are responsible to depend on the JSON module if you want to Note that you are responsible to depend on the L<CBOR::XS> module if you
use this functionality, as AnyEvent does not have a dependency itself. want to use this functionality, as AnyEvent does not have a dependency on
it itself.
=back =back
...@@ -589,7 +615,7 @@ sub _start { ...@@ -589,7 +615,7 @@ sub _start {
Carp::croak "AnyEvent::Handle: only stream sockets supported, anything else will NOT work!" Carp::croak "AnyEvent::Handle: only stream sockets supported, anything else will NOT work!"
if Socket::SOCK_STREAM () != (unpack "I", $type) && defined $type; if Socket::SOCK_STREAM () != (unpack "I", $type) && defined $type;
AnyEvent::Util::fh_nonblocking $self->{fh}, 1; AnyEvent::fh_unblock $self->{fh};
$self->{_activity} = $self->{_activity} =
$self->{_ractivity} = $self->{_ractivity} =
...@@ -735,23 +761,6 @@ sub oobinline { ...@@ -735,23 +761,6 @@ sub oobinline {
}; };
} }
=item $handle->keepalive ($boolean)
Enables or disables the C<keepalive> setting (see constructor argument of
the same name for details).
=cut
sub keepalive {
$_[0]{keepalive} = $_[1];
eval {
local $SIG{__DIE__};
setsockopt $_[0]{fh}, Socket::SOL_SOCKET (), Socket::SO_KEEPALIVE (), int $_[1]
if $_[0]{fh};
};
}
=item $handle->on_starttls ($cb) =item $handle->on_starttls ($cb)
Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument). Replace the current C<on_starttls> callback (see the C<on_starttls> constructor argument).
...@@ -949,7 +958,7 @@ sub _drain_wbuf { ...@@ -949,7 +958,7 @@ sub _drain_wbuf {
&& $self->{on_drain}; && $self->{on_drain};
delete $self->{_ww} unless length $self->{wbuf}; delete $self->{_ww} unless length $self->{wbuf};
} elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
$self->_error ($!, 1); $self->_error ($!, 1);
} }
}; };
...@@ -1047,18 +1056,23 @@ Encodes the given hash or array reference into a JSON object. Unless you ...@@ -1047,18 +1056,23 @@ Encodes the given hash or array reference into a JSON object. Unless you
provide your own JSON object, this means it will be encoded to JSON text provide your own JSON object, this means it will be encoded to JSON text
in UTF-8. in UTF-8.
JSON objects (and arrays) are self-delimiting, so you can write JSON at The default encoder might or might not handle every type of JSON value -
one end of a handle and read them at the other end without using any it might be limited to arrays and objects for security reasons. See the
additional framing. C<json> constructor attribute for more details.
The generated JSON text is guaranteed not to contain any newlines: While JSON objects (and arrays) are self-delimiting, so if you only use arrays
this module doesn't need delimiters after or between JSON texts to be and hashes, you can write JSON at one end of a handle and read them at the
able to read them, many other languages depend on that. other end without using any additional framing.
A simple RPC protocol that interoperates easily with others is to send The JSON text generated by the default encoder is guaranteed not to
JSON arrays (or objects, although arrays are usually the better choice as contain any newlines: While this module doesn't need delimiters after or
they mimic how function argument passing works) and a newline after each between JSON texts to be able to read them, many other languages depend on
JSON text: them.
A simple RPC protocol that interoperates easily with other languages is
to send JSON arrays (or objects, although arrays are usually the better
choice as they mimic how function argument passing works) and a newline
after each JSON text:
$handle->push_write (json => ["method", "arg1", "arg2"]); # whatever $handle->push_write (json => ["method", "arg1", "arg2"]); # whatever
$handle->push_write ("\012"); $handle->push_write ("\012");
...@@ -1071,19 +1085,50 @@ rely on the fact that the newline will be skipped as leading whitespace: ...@@ -1071,19 +1085,50 @@ rely on the fact that the newline will be skipped as leading whitespace:
Other languages could read single lines terminated by a newline and pass Other languages could read single lines terminated by a newline and pass
this line into their JSON decoder of choice. this line into their JSON decoder of choice.
=item cbor => $perl_scalar
Encodes the given scalar into a CBOR value. Unless you provide your own
L<CBOR::XS> object, this means it will be encoded to a CBOR string not
using any extensions, if possible.
CBOR values are self-delimiting, so you can write CBOR at one end of
a handle and read them at the other end without using any additional
framing.
A simple nd very very fast RPC protocol that interoperates with
other languages is to send CBOR and receive CBOR values (arrays are
recommended):
$handle->push_write (cbor => ["method", "arg1", "arg2"]); # whatever
An AnyEvent::Handle receiver would simply use the C<cbor> read type:
$handle->push_read (cbor => sub { my $array = $_[1]; ... });
=cut =cut
sub json_coder() { sub json_coder() {
eval { require JSON::XS; JSON::XS->new->utf8 } eval { require JSON::XS; JSON::XS->new->utf8 }
|| do { require JSON; JSON->new->utf8 } || do { require JSON::PP; JSON::PP->new->utf8 }
} }
register_write_type json => sub { register_write_type json => sub {
my ($self, $ref) = @_; my ($self, $ref) = @_;
my $json = $self->{json} ||= json_coder; ($self->{json} ||= json_coder)
->encode ($ref)
};
sub cbor_coder() {
require CBOR::XS;
CBOR::XS->new
}
register_write_type cbor => sub {
my ($self, $scalar) = @_;
$json->encode ($ref) ($self->{cbor} ||= cbor_coder)
->encode ($scalar)
}; };
=item storable => $reference =item storable => $reference
...@@ -1487,11 +1532,13 @@ register_read_type line => sub { ...@@ -1487,11 +1532,13 @@ register_read_type line => sub {
my ($self, $cb, $eol) = @_; my ($self, $cb, $eol) = @_;
if (@_ < 3) { if (@_ < 3) {
# this is more than twice as fast as the generic code below # this is faster then the generic code below
sub { sub {
$_[0]{rbuf} =~ s/^([^\015\012]*)(\015?\012)// or return; (my $pos = index $_[0]{rbuf}, "\012") >= 0
or return;
$cb->($_[0], "$1", "$2"); (my $str = substr $_[0]{rbuf}, 0, $pos + 1, "") =~ s/(\015?\012)\Z// or die;
$cb->($_[0], $str, "$1");
1 1
} }
} else { } else {
...@@ -1510,7 +1557,8 @@ register_read_type line => sub { ...@@ -1510,7 +1557,8 @@ register_read_type line => sub {
=item regex => $accept[, $reject[, $skip], $cb->($handle, $data) =item regex => $accept[, $reject[, $skip], $cb->($handle, $data)
Makes a regex match against the regex object C<$accept> and returns Makes a regex match against the regex object C<$accept> and returns
everything up to and including the match. everything up to and including the match. All the usual regex variables
($1, %+ etc.) from the regex match are available in the callback.
Example: read a single line terminated by '\n'. Example: read a single line terminated by '\n'.
...@@ -1664,13 +1712,12 @@ register_read_type packstring => sub { ...@@ -1664,13 +1712,12 @@ register_read_type packstring => sub {
Reads a JSON object or array, decodes it and passes it to the Reads a JSON object or array, decodes it and passes it to the
callback. When a parse error occurs, an C<EBADMSG> error will be raised. callback. When a parse error occurs, an C<EBADMSG> error will be raised.
If a C<json> object was passed to the constructor, then that will be used If a C<json> object was passed to the constructor, then that will be
for the final decode, otherwise it will create a JSON coder expecting UTF-8. used for the final decode, otherwise it will create a L<JSON::XS> or
L<JSON::PP> coder object expecting UTF-8.
This read type uses the incremental parser available with JSON version This read type uses the incremental parser available with JSON version
2.09 (and JSON::XS version 2.2) and above. You have to provide a 2.09 (and JSON::XS version 2.2) and above.
dependency on your own: this module will load the JSON module, but
AnyEvent does not depend on it itself.
Since JSON texts are fully self-delimiting, the C<json> read and write Since JSON texts are fully self-delimiting, the C<json> read and write
types are an ideal simple RPC protocol: just exchange JSON datagrams. See types are an ideal simple RPC protocol: just exchange JSON datagrams. See
...@@ -1684,7 +1731,6 @@ register_read_type json => sub { ...@@ -1684,7 +1731,6 @@ register_read_type json => sub {
my $json = $self->{json} ||= json_coder; my $json = $self->{json} ||= json_coder;
my $data; my $data;
my $rbuf = \$self->{rbuf};
sub { sub {
my $ref = eval { $json->incr_parse ($_[0]{rbuf}) }; my $ref = eval { $json->incr_parse ($_[0]{rbuf}) };
...@@ -1713,6 +1759,52 @@ register_read_type json => sub { ...@@ -1713,6 +1759,52 @@ register_read_type json => sub {
} }
}; };
=item cbor => $cb->($handle, $scalar)
Reads a CBOR value, decodes it and passes it to the callback. When a parse
error occurs, an C<EBADMSG> error will be raised.
If a L<CBOR::XS> object was passed to the constructor, then that will be
used for the final decode, otherwise it will create a CBOR coder without
enabling any options.
You have to provide a dependency to L<CBOR::XS> on your own: this module
will load the L<CBOR::XS> module, but AnyEvent does not depend on it
itself.
Since CBOR values are fully self-delimiting, the C<cbor> read and write
types are an ideal simple RPC protocol: just exchange CBOR datagrams. See
the C<cbor> write type description, above, for an actual example.
=cut
register_read_type cbor => sub {
my ($self, $cb) = @_;
my $cbor = $self->{cbor} ||= cbor_coder;
my $data;
sub {
my (@value) = eval { $cbor->incr_parse ($_[0]{rbuf}) };
if (@value) {
$cb->($_[0], @value);
1
} elsif ($@) {
# error case
$cbor->incr_reset;
$_[0]->_error (Errno::EBADMSG);
()
} else {
()
}
}
};
=item storable => $cb->($handle, $ref) =item storable => $cb->($handle, $ref)
Deserialises a L<Storable> frozen representation as written by the Deserialises a L<Storable> frozen representation as written by the
...@@ -1766,9 +1858,9 @@ SSL2-compatible framing is supported). ...@@ -1766,9 +1858,9 @@ SSL2-compatible framing is supported).
If it detects that the input data is likely TLS, it calls the callback If it detects that the input data is likely TLS, it calls the callback
with a true value for C<$detect> and the (on-wire) TLS version as second with a true value for C<$detect> and the (on-wire) TLS version as second
and third argument (C<$major> is C<3>, and C<$minor> is 0..3 for SSL and third argument (C<$major> is C<3>, and C<$minor> is 0..4 for SSL
3.0, TLS 1.0, 1.1 and 1.2, respectively). If it detects the input to 3.0, TLS 1.0, 1.1, 1.2 and 1.3, respectively). If it detects the input
be definitely not TLS, it calls the callback with a false value for to be definitely not TLS, it calls the callback with a false value for
C<$detect>. C<$detect>.
The callback could use this information to decide whether or not to start The callback could use this information to decide whether or not to start
...@@ -1788,7 +1880,7 @@ accomodate protocol changes. ...@@ -1788,7 +1880,7 @@ accomodate protocol changes.
This read type does not rely on L<AnyEvent::TLS> (and thus, not on This read type does not rely on L<AnyEvent::TLS> (and thus, not on
L<Net::SSLeay>). L<Net::SSLeay>).
=item tls_autostart => $tls[, $tls_ctx] =item tls_autostart => [$tls_ctx, ]$tls
Tries to detect a valid SSL or TLS handshake. If one is detected, it tries Tries to detect a valid SSL or TLS handshake. If one is detected, it tries
to start tls by calling C<starttls> with the given arguments. to start tls by calling C<starttls> with the given arguments.
...@@ -1802,7 +1894,7 @@ See C<tls_detect> above for more details. ...@@ -1802,7 +1894,7 @@ See C<tls_detect> above for more details.
Example: give the client a chance to start TLS before accepting a text Example: give the client a chance to start TLS before accepting a text
line. line.
$hdl->push_read (tls_detect => "accept"); $hdl->push_read (tls_autostart => "accept");
$hdl->push_read (line => sub { $hdl->push_read (line => sub {
print "received ", ($_[0]{tls} ? "encrypted" : "cleartext"), " <$_[1]>\n"; print "received ", ($_[0]{tls} ? "encrypted" : "cleartext"), " <$_[1]>\n";
}); });
...@@ -1824,7 +1916,7 @@ register_read_type tls_detect => sub { ...@@ -1824,7 +1916,7 @@ register_read_type tls_detect => sub {
# full match, valid TLS record # full match, valid TLS record
my ($major, $minor) = unpack "CC", $1; my ($major, $minor) = unpack "CC", $1;
$cb->($self, "accept", $major + $minor * 0.1); $cb->($self, "accept", $major, $minor);
} else { } else {
# mismatch == guaranteed not TLS # mismatch == guaranteed not TLS
$cb->($self, undef); $cb->($self, undef);
...@@ -1934,7 +2026,7 @@ sub start_read { ...@@ -1934,7 +2026,7 @@ sub start_read {
$self->{_eof} = 1; $self->{_eof} = 1;
$self->_drain_rbuf; $self->_drain_rbuf;
} elsif ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK) { } elsif ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK) {
return $self->_error ($!, 1); return $self->_error ($!, 1);
} }
}; };
...@@ -1974,15 +2066,18 @@ sub _dotls { ...@@ -1974,15 +2066,18 @@ sub _dotls {
my $tmp; my $tmp;
if (length $self->{_tls_wbuf}) { while (length $self->{_tls_wbuf}) {
while (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) > 0) { if (($tmp = Net::SSLeay::write ($self->{tls}, $self->{_tls_wbuf})) <= 0) {
substr $self->{_tls_wbuf}, 0, $tmp, ""; $tmp = Net::SSLeay::get_error ($self->{tls}, $tmp);
return $self->_tls_error ($tmp)
if $tmp != $ERROR_WANT_READ
&& ($tmp != $ERROR_SYSCALL || $!);
last;
} }
$tmp = Net::SSLeay::get_error ($self->{tls}, $tmp); substr $self->{_tls_wbuf}, 0, $tmp, "";
return $self->_tls_error ($tmp)
if $tmp != $ERROR_WANT_READ
&& ($tmp != $ERROR_SYSCALL || $!);
} }
while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) { while (defined ($tmp = Net::SSLeay::read ($self->{tls}))) {
...@@ -2006,7 +2101,7 @@ sub _dotls { ...@@ -2006,7 +2101,7 @@ sub _dotls {
$self->{tls} or return; # tls session might have gone away in callback $self->{tls} or return; # tls session might have gone away in callback
} }
$tmp = Net::SSLeay::get_error ($self->{tls}, -1); $tmp = Net::SSLeay::get_error ($self->{tls}, -1); # -1 is not neccessarily correct, but Net::SSLeay doesn't tell us
return $self->_tls_error ($tmp) return $self->_tls_error ($tmp)
if $tmp != $ERROR_WANT_READ if $tmp != $ERROR_WANT_READ
&& ($tmp != $ERROR_SYSCALL || $!); && ($tmp != $ERROR_SYSCALL || $!);
...@@ -2100,19 +2195,19 @@ sub starttls { ...@@ -2100,19 +2195,19 @@ sub starttls {
# basically, this is deep magic (because SSL_read should have the same issues) # basically, this is deep magic (because SSL_read should have the same issues)
# but the openssl maintainers basically said: "trust us, it just works". # but the openssl maintainers basically said: "trust us, it just works".
# (unfortunately, we have to hardcode constants because the abysmally misdesigned # (unfortunately, we have to hardcode constants because the abysmally misdesigned
# and mismaintained ssleay-module doesn't even offer them). # and mismaintained ssleay-module didn't offer them for a decade or so).
# http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html # http://www.mail-archive.com/openssl-dev@openssl.org/msg22420.html
# #
# in short: this is a mess. # in short: this is a mess.
# #
# note that we do not try to keep the length constant between writes as we are required to do. # note that we do not try to keep the length constant between writes as we are required to do.
# we assume that most (but not all) of this insanity only applies to non-blocking cases, # we assume that most (but not all) of this insanity only applies to non-blocking cases,
# and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to # and we drive openssl fully in blocking mode here. Or maybe we don't - openssl seems to
# have identity issues in that area. # have identity issues in that area.
# Net::SSLeay::CTX_set_mode ($ssl, # Net::SSLeay::set_mode ($ssl,
# (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1) # (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ENABLE_PARTIAL_WRITE () } || 1)
# | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2)); # | (eval { local $SIG{__DIE__}; Net::SSLeay::MODE_ACCEPT_MOVING_WRITE_BUFFER () } || 2));
Net::SSLeay::CTX_set_mode ($tls, 1|2); Net::SSLeay::set_mode ($tls, 1|2);
$self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); $self->{_rbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
$self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ()); $self->{_wbio} = Net::SSLeay::BIO_new (Net::SSLeay::BIO_s_mem ());
...@@ -2197,7 +2292,7 @@ sub DESTROY { ...@@ -2197,7 +2292,7 @@ sub DESTROY {
if ($len > 0) { if ($len > 0) {
substr $wbuf, 0, $len, ""; substr $wbuf, 0, $len, "";
} elsif (defined $len || ($! != EAGAIN && $! != EINTR && $! != WSAEWOULDBLOCK)) { } elsif (defined $len || ($! != EAGAIN && $! != EINTR && $! != EWOULDBLOCK && $! != WSAEWOULDBLOCK)) {
@linger = (); # end @linger = (); # end
} }
}; };
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/IO.pm
View file @ 971eb4d6
...@@ -6,7 +6,7 @@ AnyEvent::IO - the DBI of asynchronous I/O implementations ...@@ -6,7 +6,7 @@ AnyEvent::IO - the DBI of asynchronous I/O implementations
use AnyEvent::IO; use AnyEvent::IO;
# load /etc/passwd, call clalback with the file data when done. # load /etc/passwd, call callback with the file data when done.
aio_load "/etc/passwd", sub { aio_load "/etc/passwd", sub {
my ($data) = @_ my ($data) = @_
or return AE::log error => "/etc/passwd: $!"; or return AE::log error => "/etc/passwd: $!";
...@@ -58,10 +58,11 @@ is to I/O the same as L<AnyEvent> is to event libraries - it only ...@@ -58,10 +58,11 @@ is to I/O the same as L<AnyEvent> is to event libraries - it only
I<interfaces> to other implementations or to a portable pure-perl I<interfaces> to other implementations or to a portable pure-perl
implementation (which does not, however, do asynchronous I/O). implementation (which does not, however, do asynchronous I/O).
The only other implementation that is supported (or even known to The only other implementation that is supported (or even known to the
the author) is L<IO::AIO>, which is used automatically when it can author) is L<IO::AIO>, which is used automatically when it can be loaded
be loaded. If it is not available, L<AnyEvent::IO> falls back to its (via L<AnyEvent::AIO>, which also needs to be installed). If it is not
synchronous pure-perl implementation. available, then L<AnyEvent::IO> falls back to its synchronous pure-perl
implementation.
Unlike L<AnyEvent>, which model to use is currently decided at module load Unlike L<AnyEvent>, which model to use is currently decided at module load
time, not at first use. Future releases might change this. time, not at first use. Future releases might change this.
...@@ -162,8 +163,8 @@ the following import tags can be used: ...@@ -162,8 +163,8 @@ the following import tags can be used:
The functions in this module are not meant to be the most versatile or The functions in this module are not meant to be the most versatile or
the highest-performers (they are not very slow either, of course). They the highest-performers (they are not very slow either, of course). They
are primarily meant to give users of your code the option to do the I/O are primarily meant to give users of your code the option to do the I/O
asynchronously (by installing L<IO::AIO>), without adding a dependency on asynchronously (by installing L<IO::AIO> and L<AnyEvent::AIO>),
that module. without adding a dependency on those modules.
=head2 NAMING =head2 NAMING
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Glib.pm
View file @ 971eb4d6
...@@ -19,10 +19,22 @@ Glib is probably the most inefficient event loop that has ever seen the ...@@ -19,10 +19,22 @@ Glib is probably the most inefficient event loop that has ever seen the
light of the world: Glib not only scans all its watchers (really, ALL of light of the world: Glib not only scans all its watchers (really, ALL of
them, whether I/O-related, timer-related or what not) during each loop them, whether I/O-related, timer-related or what not) during each loop
iteration, it also does so multiple times and rebuilds the poll list for iteration, it also does so multiple times and rebuilds the poll list for
the kernel each time again, dynamically even. the kernel each time again, dynamically even. Newer versions of libglib
fortunately do not call malloc/free on every single watcher invocation,
though.
On the positive side, and most importantly, Glib generally works Glib also enforces certain undocumented behaviours, for example, you
correctly, no quarrels there. cannot always remove active child watchers, and the conditions on when
it is valid to do so are not documented. Of course, if you get it wrong,
you get "GLib-CRITICAL" messages. This makes it extremely hard to write
"correct" glib programs, as you have to study the source code to get it
right, and hope future versions don't change any internals.
AnyEvent implements the necessary workarounds, at a small performance
cost.
On the positive side, and most importantly, when it works, Glib generally
works correctly, no quarrels there.
If you create many watchers (as in: more than two), you might consider one If you create many watchers (as in: more than two), you might consider one
of the L<Glib::EV>, L<EV::Glib> or L<Glib::Event> modules that map Glib to of the L<Glib::EV>, L<EV::Glib> or L<Glib::Event> modules that map Glib to
...@@ -70,9 +82,18 @@ sub timer { ...@@ -70,9 +82,18 @@ sub timer {
remove Glib::Source $source; remove Glib::Source $source;
$source = add Glib::Timeout $ival, sub { &$cb; 1 }; $source = add Glib::Timeout $ival, sub { &$cb; 1 };
&$cb; &$cb;
0 1 # already removed, should be a nop
} }
: sub { &$cb; 0 }; : sub {
# due to the braindamaged libglib API (it manages
# removed-but-active watchers internally, but forces
# users to # manage the same externally as well),
# we have to go through these contortions.
remove Glib::Source $source;
undef $source;
&$cb;
1 # already removed, should be a nop
};
bless \\$source, $class bless \\$source, $class
} }
...@@ -87,7 +108,8 @@ sub idle { ...@@ -87,7 +108,8 @@ sub idle {
} }
sub DESTROY { sub DESTROY {
remove Glib::Source $${$_[0]}; remove Glib::Source $${$_[0]}
if defined $${$_[0]};
} }
our %pid_w; our %pid_w;
...@@ -105,10 +127,16 @@ sub child { ...@@ -105,10 +127,16 @@ sub child {
$pid_cb{$pid}{$cb+0} = $cb; $pid_cb{$pid}{$cb+0} = $cb;
$pid_w{$pid} ||= Glib::Child->watch_add ($pid, sub { $pid_w{$pid} ||= Glib::Child->watch_add ($pid, sub {
# the unbelievably braindamaged glib api ignores the return
# value and always removes the watcher (this is of course
# undocumented), so we need to go through these contortions to
# work around this, here and in DESTROY.
undef $pid_w{$pid};
$_->($_[0], $_[1]) $_->($_[0], $_[1])
for values %{ $pid_cb{$pid} }; for values %{ $pid_cb{$pid} };
1 1 # gets ignored
}); });
bless [$pid, $cb+0], "AnyEvent::Impl::Glib::child" bless [$pid, $cb+0], "AnyEvent::Impl::Glib::child"
...@@ -120,7 +148,8 @@ sub AnyEvent::Impl::Glib::child::DESTROY { ...@@ -120,7 +148,8 @@ sub AnyEvent::Impl::Glib::child::DESTROY {
delete $pid_cb{$pid}{$icb}; delete $pid_cb{$pid}{$icb};
unless (%{ $pid_cb{$pid} }) { unless (%{ $pid_cb{$pid} }) {
delete $pid_cb{$pid}; delete $pid_cb{$pid};
remove Glib::Source delete $pid_w{$pid}; my $source = delete $pid_w{$pid};
remove Glib::Source if defined $source;
} }
} }
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/IOAsync.pm
View file @ 971eb4d6
...@@ -19,6 +19,40 @@ I/O, timers, signals and child process watchers. Idle watchers are emulated. ...@@ -19,6 +19,40 @@ I/O, timers, signals and child process watchers. Idle watchers are emulated.
I/O watchers need to dup their fh because IO::Async only supports IO handles, I/O watchers need to dup their fh because IO::Async only supports IO handles,
not plain file descriptors. not plain file descriptors.
=head1 FUNCTIONS AND VARIABLES
The only user-servicible part in this module is the C<set_loop> function
and C<$LOOP> variable:
=over 4
=item AnyEvent::Impl::IOAsync::set_loop $new_loop
Unfortunately, IO::Async has no concept of a default loop. Modules using
IO::Async must be told by their caller which loop to use, which makes it
impossible to transparently use IO::Async from a module.
This module is no exception. It creates a new IO::Async::Loop object when
it is loaded. This might not be the right loop object, though, and thus
you can replace it by a call to this function with the loop object of your
choice.
Note that switching loops while watchers are already initialised can have
unexpected effects, and is not supported unless you can live witht he
consequences.
=item $AnyEvent::Impl::IOAsync::LOOP
This variable always contains the IO::Async::Loop object used by this
AnyEvent backend. See above for more info.
Storing the "default" loop makes this module a possible arbiter for other
modules that want to use IO::Async transparently. It's advised to directly
refer to this variable each time you want to use it, without making a
local copy.
=back
=head1 PROBLEMS WITH IO::Async =head1 PROBLEMS WITH IO::Async
This section had a long list of problems and shortcomings that made it This section had a long list of problems and shortcomings that made it
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Perl.pm
View file @ 971eb4d6
...@@ -38,9 +38,9 @@ our $VERSION = $AnyEvent::VERSION; ...@@ -38,9 +38,9 @@ our $VERSION = $AnyEvent::VERSION;
*AE::idle = \&AnyEvent::Loop::idle; *AE::idle = \&AnyEvent::Loop::idle;
*_poll = \&AnyEvent::Loop::one_event; *_poll = \&AnyEvent::Loop::one_event;
*loop = \&AnyEvent::Loop::run; # compatibility with AnyEvent < 6.0 *loop = \&AnyEvent::Loop::run; # compatibility with AnyEvent < 6.0
*now_update = \&AnyEvent::Loop::now_update;
sub now { $AnyEvent::Loop::NOW } sub now { $AnyEvent::Loop::NOW }
sub now_update { AE::now_update }
sub AnyEvent::CondVar::Base::_wait { sub AnyEvent::CondVar::Base::_wait {
AnyEvent::Loop::one_event until exists $_[0]{_ae_sent}; AnyEvent::Loop::one_event until exists $_[0]{_ae_sent};
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Log.pm
View file @ 971eb4d6
...@@ -10,10 +10,10 @@ Simple uses: ...@@ -10,10 +10,10 @@ Simple uses:
AE::log fatal => "No config found, cannot continue!"; # never returns AE::log fatal => "No config found, cannot continue!"; # never returns
AE::log alert => "The battery died!"; AE::log alert => "The battery died!";
AE::log crit => "The battery temperature is too hot!"; AE::log crit => "The battery is too hot!";
AE::log error => "Division by zero attempted."; AE::log error => "Division by zero attempted.";
AE::log warn => "Couldn't delete the file."; AE::log warn => "Couldn't delete the file.";
AE::log note => "Wanted to create config, but config already exists."; AE::log note => "Attempted to create config, but config already exists.";
AE::log info => "File soandso successfully deleted."; AE::log info => "File soandso successfully deleted.";
AE::log debug => "the function returned 3"; AE::log debug => "the function returned 3";
AE::log trace => "going to call function abc"; AE::log trace => "going to call function abc";
...@@ -35,18 +35,27 @@ Log level overview: ...@@ -35,18 +35,27 @@ Log level overview:
use AnyEvent::Log; use AnyEvent::Log;
my $tracer = AnyEvent::Log::logger trace => \$my $trace; my $tracer = AnyEvent::Log::logger trace => \my $trace;
$tracer->("i am here") if $trace; $tracer->("i am here") if $trace;
$tracer->(sub { "lots of data: " . Dumper $self }) if $trace; $tracer->(sub { "lots of data: " . Dumper $self }) if $trace;
Configuration (also look at the EXAMPLES section): Configuration (also look at the EXAMPLES section):
# set default logging level to suppress anything below "notice"
# i.e. enable logging at "notice" or above - the default is to
# to not log anything at all.
$AnyEvent::Log::FILTER->level ("notice");
# set logging for the current package to errors and higher only # set logging for the current package to errors and higher only
AnyEvent::Log::ctx->level ("error"); AnyEvent::Log::ctx->level ("error");
# set logging level to suppress anything below "notice" # enable logging for the current package, regardless of global logging level
$AnyEvent::Log::FILTER->level ("notice"); AnyEvent::Log::ctx->attach ($AnyEvent::Log::LOG);
# enable debug logging for module some::mod and enable logging by default
(AnyEvent::Log::ctx "some::mod")->level ("debug");
(AnyEvent::Log::ctx "some::mod")->attach ($AnyEvent::Log::LOG);
# send all critical and higher priority messages to syslog, # send all critical and higher priority messages to syslog,
# regardless of (most) other settings # regardless of (most) other settings
...@@ -73,9 +82,9 @@ level at runtime with something like: ...@@ -73,9 +82,9 @@ level at runtime with something like:
$AnyEvent::Log::FILTER->level ("info"); $AnyEvent::Log::FILTER->level ("info");
The design goal behind this module was to keep it simple (and small), The design goal behind this module was to keep it simple (and small),
but make it powerful enough to be potentially useful for any module, and but make it powerful enough to be potentially useful for any module,
extensive enough for the most common tasks, such as logging to multiple and extensive enough for the most common tasks, such as logging to
targets, or being able to log into a database. multiple targets, or being able to log into a database.
The module is also usable before AnyEvent itself is initialised, in which The module is also usable before AnyEvent itself is initialised, in which
case some of the functionality might be reduced. case some of the functionality might be reduced.
...@@ -155,7 +164,7 @@ our ($COLLECT, $FILTER, $LOG); ...@@ -155,7 +164,7 @@ our ($COLLECT, $FILTER, $LOG);
our ($now_int, $now_str1, $now_str2); our ($now_int, $now_str1, $now_str2);
# Format Time, not public - yet? # Format Time, not public - yet?
sub ft($) { sub format_time($) {
my $i = int $_[0]; my $i = int $_[0];
my $f = sprintf "%06d", 1e6 * ($_[0] - $i); my $f = sprintf "%06d", 1e6 * ($_[0] - $i);
...@@ -264,8 +273,8 @@ AnyEvent::post_detect { ...@@ -264,8 +273,8 @@ AnyEvent::post_detect {
our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace); our @LEVEL2STR = qw(0 fatal alert crit error warn note info debug trace);
# time, ctx, level, msg # time, ctx, level, msg
sub _format($$$$) { sub default_format($$$$) {
my $ts = ft $_[0]; my $ts = format_time $_[0];
my $ct = " "; my $ct = " ";
my @res; my @res;
...@@ -324,7 +333,7 @@ sub _log { ...@@ -324,7 +333,7 @@ sub _log {
# format msg # format msg
my $str = $ctx->[4] my $str = $ctx->[4]
? $ctx->[4]($now, $_[0], $level, $format) ? $ctx->[4]($now, $_[0], $level, $format)
: ($fmt[$level] ||= _format $now, $_[0], $level, $format); : ($fmt[$level] ||= default_format $now, $_[0], $level, $format);
$success = 1; $success = 1;
...@@ -456,6 +465,41 @@ initialised, this switch will also decide whether to use C<CORE::time> or ...@@ -456,6 +465,41 @@ initialised, this switch will also decide whether to use C<CORE::time> or
C<Time::HiRes::time> when logging a message before L<AnyEvent> becomes C<Time::HiRes::time> when logging a message before L<AnyEvent> becomes
available. available.
=item AnyEvent::Log::format_time $timestamp
Formats a timestamp as returned by C<< AnyEvent->now >> or C<<
AnyEvent->time >> or many other functions in the same way as
C<AnyEvent::Log> does.
In your main program (as opposed to in your module) you can override
the default timestamp display format by loading this module and then
redefining this function.
Most commonly, this function can be used in formatting callbacks.
=item AnyEvent::Log::default_format $time, $ctx, $level, $msg
Format a log message using the given timestamp, logging context, log level
and log message.
This is the formatting function used to format messages when no custom
function is provided.
In your main program (as opposed to in your module) you can override the
default message format by loading this module and then redefining this
function.
=item AnyEvent::Log::fatal_exit()
This is the function that is called after logging a C<fatal> log
message. It must not return.
The default implementation simply calls C<exit 1>.
In your main program (as opposed to in your module) you can override
the fatal exit function by loading this module and then redefining this
function. Make sure you don't return.
=back =back
=head1 LOGGING CONTEXTS =head1 LOGGING CONTEXTS
...@@ -552,7 +596,7 @@ something that logs to a file, or to attach additional logging targets ...@@ -552,7 +596,7 @@ something that logs to a file, or to attach additional logging targets
This function creates or returns a logging context (which is an object). This function creates or returns a logging context (which is an object).
If a package name is given, then the context for that packlage is If a package name is given, then the context for that package is
returned. If it is called without any arguments, then the context for the returned. If it is called without any arguments, then the context for the
callers package is returned (i.e. the same context as a C<AE::log> call callers package is returned (i.e. the same context as a C<AE::log> call
would use). would use).
...@@ -842,6 +886,7 @@ sub attach { ...@@ -842,6 +886,7 @@ sub attach {
$ctx->[2]{$_+0} = $_ $ctx->[2]{$_+0} = $_
for map { AnyEvent::Log::ctx $_ } @_; for map { AnyEvent::Log::ctx $_ } @_;
AnyEvent::Log::_reassess;
} }
sub detach { sub detach {
...@@ -849,11 +894,13 @@ sub detach { ...@@ -849,11 +894,13 @@ sub detach {
delete $ctx->[2]{$_+0} delete $ctx->[2]{$_+0}
for map { AnyEvent::Log::ctx $_ } @_; for map { AnyEvent::Log::ctx $_ } @_;
AnyEvent::Log::_reassess;
} }
sub slaves { sub slaves {
undef $_[0][2]; undef $_[0][2];
&attach; &attach;
AnyEvent::Log::_reassess;
} }
=back =back
...@@ -910,6 +957,20 @@ If, for some reason, you want to use C<caller> to find out more about the ...@@ -910,6 +957,20 @@ If, for some reason, you want to use C<caller> to find out more about the
logger then you should walk up the call stack until you are no longer logger then you should walk up the call stack until you are no longer
inside the C<AnyEvent::Log> package. inside the C<AnyEvent::Log> package.
To implement your own logging callback, you might find the
C<AnyEvent::Log::format_time> and C<AnyEvent::Log::default_format>
functions useful.
Example: format the message just as AnyEvent::Log would, by letting
AnyEvent::Log do the work. This is a good basis to design a formatting
callback that only changes minor aspects of the formatting.
$ctx->fmt_cb (sub {
my ($time, $ctx, $lvl, $msg) = @_;
AnyEvent::Log::default_format $time, $ctx, $lvl, $msg
});
Example: format just the raw message, with numeric log level in angle Example: format just the raw message, with numeric log level in angle
brackets. brackets.
...@@ -1181,6 +1242,9 @@ Context names starting with a C<%> are anonymous contexts created when the ...@@ -1181,6 +1242,9 @@ Context names starting with a C<%> are anonymous contexts created when the
name is first mentioned. The difference to package contexts is that by name is first mentioned. The difference to package contexts is that by
default they have no attached slaves. default they have no attached slaves.
This makes it possible to create new log contexts that can be refered to
multiple times by name within the same log specification.
=item a perl package name =item a perl package name
Any other string references the logging context associated with the given Any other string references the logging context associated with the given
...@@ -1449,6 +1513,12 @@ default. ...@@ -1449,6 +1513,12 @@ default.
=back =back
=head1 ASYNCHRONOUS DISK I/O
This module uses L<AnyEvent::IO> to actually write log messages (in
C<log_to_file> and C<log_to_path>), so it doesn't block your program when
the disk is busy and a non-blocking L<AnyEvent::IO> backend is available.
=head1 AUTHOR =head1 AUTHOR
Marc Lehmann <schmorp@schmorp.de> Marc Lehmann <schmorp@schmorp.de>
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Loop.pm
View file @ 971eb4d6
...@@ -130,7 +130,7 @@ our ($NOW, $MNOW); ...@@ -130,7 +130,7 @@ our ($NOW, $MNOW);
sub MAXWAIT() { 3600 } # never sleep for longer than this many seconds sub MAXWAIT() { 3600 } # never sleep for longer than this many seconds
BEGIN { BEGIN {
local $SIG{__DIE__}; local $SIG{__DIE__}; # protect us against the many broken __DIE__ handlers out there
my $time_hires = eval "use Time::HiRes (); 1"; my $time_hires = eval "use Time::HiRes (); 1";
my $clk_tck = eval "use POSIX (); POSIX::sysconf (POSIX::_SC_CLK_TCK ())"; my $clk_tck = eval "use POSIX (); POSIX::sysconf (POSIX::_SC_CLK_TCK ())";
my $round; # actual granularity my $round; # actual granularity
...@@ -153,7 +153,7 @@ BEGIN { ...@@ -153,7 +153,7 @@ BEGIN {
$next = (POSIX::times ())[0]; $next = (POSIX::times ())[0];
# we assume 32 bit signed on wrap but 64 bit will never wrap # we assume 32 bit signed on wrap but 64 bit will never wrap
$last -= 4294967296 if $last > $next; # 0x100000000, but perl has probelsm with big hex constants $last -= 4294967296 if $last > $next; # 0x100000000, but perl has problems with big hex constants
$MNOW += ($next - $last) * $HZ1; $MNOW += ($next - $last) * $HZ1;
$last = $next; $last = $next;
}; };
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Socket.pm
View file @ 971eb4d6
...@@ -40,7 +40,7 @@ use Errno (); ...@@ -40,7 +40,7 @@ use Errno ();
use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR); use Socket qw(AF_INET AF_UNIX SOCK_STREAM SOCK_DGRAM SOL_SOCKET SO_REUSEADDR);
use AnyEvent (); BEGIN { AnyEvent::common_sense } use AnyEvent (); BEGIN { AnyEvent::common_sense }
use AnyEvent::Util qw(guard fh_nonblocking AF_INET6); use AnyEvent::Util qw(guard AF_INET6);
use AnyEvent::DNS (); use AnyEvent::DNS ();
use base 'Exporter'; use base 'Exporter';
...@@ -104,12 +104,21 @@ Example: ...@@ -104,12 +104,21 @@ Example:
print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1"; print unpack "H*", parse_ipv6 "2002:5345::10.0.0.1";
# => 2002534500000000000000000a000001 # => 2002534500000000000000000a000001
print unpack "H*", parse_ipv6 "192.89.98.1";
# => 00000000000000000000ffffc0596201
=cut =cut
sub parse_ipv6($) { sub parse_ipv6($) {
# quick test to avoid longer processing # quick test to avoid longer processing
my $n = $_[0] =~ y/://; my $n = $_[0] =~ y/://;
return undef if $n < 2 || $n > 8;
if ($n < 2 || $n > 8) {
if (!$n && (my $ipn = parse_ipv4 $_[0])) {
return "\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff$ipn";
}
return undef;
}
my ($h, $t) = split /::/, $_[0], 2; my ($h, $t) = split /::/, $_[0], 2;
...@@ -117,8 +126,8 @@ sub parse_ipv6($) { ...@@ -117,8 +126,8 @@ sub parse_ipv6($) {
($h, $t) = (undef, $h); ($h, $t) = (undef, $h);
} }
my @h = split /:/, $h; my @h = split /:/, $h, -1;
my @t = split /:/, $t; my @t = split /:/, $t, -1;
# check for ipv4 tail # check for ipv4 tail
if (@t && $t[-1]=~ /\./) { if (@t && $t[-1]=~ /\./) {
...@@ -145,7 +154,7 @@ sub parse_ipv6($) { ...@@ -145,7 +154,7 @@ sub parse_ipv6($) {
=item $token = parse_unix $hostname =item $token = parse_unix $hostname
This fucntion exists mainly for symmetry to the other C<parse_protocol> This function exists mainly for symmetry to the other C<parse_protocol>
functions - it takes a hostname and, if it is C<unix/>, it returns a functions - it takes a hostname and, if it is C<unix/>, it returns a
special address token, otherwise C<undef>. special address token, otherwise C<undef>.
...@@ -163,17 +172,19 @@ sub parse_unix($) { ...@@ -163,17 +172,19 @@ sub parse_unix($) {
=item $ipn = parse_address $ip =item $ipn = parse_address $ip
Combines C<parse_ipv4> and C<parse_ipv6> in one function. The address Combines C<parse_ipv4>, C<parse_ipv6> and C<parse_unix> in one
here refers to the host address (not socket address) in network form function. The address here refers to the host address (not socket address)
(binary). in network form (binary).
If the C<$text> is C<unix/>, then this function returns a special token If the C<$text> is C<unix/>, then this function returns a special token
recognised by the other functions in this module to mean "UNIX domain recognised by the other functions in this module to mean "UNIX domain
socket". socket".
If the C<$text> to parse is a mapped IPv4 in IPv6 address (:ffff::<ipv4>), If the C<$text> to parse is a plain IPv4 or mapped IPv4 in IPv6 address
then it will be treated as an IPv4 address. If you don't want that, you (:ffff::<ipv4>), then it will be treated as an IPv4 address and four
have to call C<parse_ipv4> and/or C<parse_ipv6> manually. octets will be returned. If you don't want that, you have to call
C<parse_ipv4> and/or C<parse_ipv6> manually (the latter always returning a
16 octet IPv6 address for mapped IPv4 addresses).
Example: Example:
...@@ -191,9 +202,9 @@ sub parse_address($) { ...@@ -191,9 +202,9 @@ sub parse_address($) {
for (&parse_ipv6) { for (&parse_ipv6) {
if ($_) { if ($_) {
s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//; s/^\x00\x00\x00\x00\x00\x00\x00\x00\x00\x00\xff\xff//;
return $_; return $_
} else { } else {
return &parse_ipv4 || &parse_unix return &parse_unix
} }
} }
} }
...@@ -258,7 +269,7 @@ It also supports defaulting the service name in a simple way by using ...@@ -258,7 +269,7 @@ It also supports defaulting the service name in a simple way by using
C<$default_service> if no service was detected. If neither a service was C<$default_service> if no service was detected. If neither a service was
detected nor a default was specified, then this function returns the detected nor a default was specified, then this function returns the
empty list. The same happens when a parse error was detected, such as a empty list. The same happens when a parse error was detected, such as a
hostname with a colon in it (the function is rather conservative, though). hostname with a colon in it (the function is rather forgiving, though).
Example: Example:
...@@ -271,7 +282,7 @@ Example: ...@@ -271,7 +282,7 @@ Example:
print join ",", parse_hostport "[::1]"; print join ",", parse_hostport "[::1]";
# => "," (empty list) # => "," (empty list)
print join ",", parse_host_port "/tmp/debug.sock"; print join ",", parse_hostport "/tmp/debug.sock";
# => "unix/", "/tmp/debug.sock" # => "unix/", "/tmp/debug.sock"
=cut =cut
...@@ -418,8 +429,7 @@ sub format_ipv6($) { ...@@ -418,8 +429,7 @@ sub format_ipv6($) {
or $ip =~ s/(?:^|:) 0:0:0:0:0 (?:$|:)/::/x or $ip =~ s/(?:^|:) 0:0:0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0:0:0 (?:$|:)/::/x or $ip =~ s/(?:^|:) 0:0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0:0 (?:$|:)/::/x or $ip =~ s/(?:^|:) 0:0:0 (?:$|:)/::/x
or $ip =~ s/(?:^|:) 0:0 (?:$|:)/::/x or $ip =~ s/(?:^|:) 0:0 (?:$|:)/::/x;
or $ip =~ s/(?:^|:) 0 (?:$|:)/::/x;
$ip $ip
} }
...@@ -578,8 +588,14 @@ module (C<format_address> converts it to C<unix/>). ...@@ -578,8 +588,14 @@ module (C<format_address> converts it to C<unix/>).
# perl contains a bug (imho) where it requires that the kernel always returns # perl contains a bug (imho) where it requires that the kernel always returns
# sockaddr_un structures of maximum length (which is not, AFAICS, required # sockaddr_un structures of maximum length (which is not, AFAICS, required
# by any standard). try to 0-pad structures for the benefit of those platforms. # by any standard). try to 0-pad structures for the benefit of those platforms.
# unfortunately, the IO::Async author chose to break Socket again in version
# 2.011 - it now contains a bogus length check, so we disable the workaround.
my $sa_un_zero = eval { Socket::pack_sockaddr_un "" }; $sa_un_zero ^= $sa_un_zero; my $sa_un_zero = $Socket::VERSION >= 2.011
? ""
: eval { Socket::pack_sockaddr_un "" };
$sa_un_zero ^= $sa_un_zero;
sub unpack_sockaddr($) { sub unpack_sockaddr($) {
my $af = sockaddr_family $_[0]; my $af = sockaddr_family $_[0];
...@@ -595,7 +611,7 @@ sub unpack_sockaddr($) { ...@@ -595,7 +611,7 @@ sub unpack_sockaddr($) {
} }
} }
=item resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...) =item AnyEvent::Socket::resolve_sockaddr $node, $service, $proto, $family, $type, $cb->([$family, $type, $proto, $sockaddr], ...)
Tries to resolve the given nodename and service name into protocol families Tries to resolve the given nodename and service name into protocol families
and sockaddr structures usable to connect to this node and service in a and sockaddr structures usable to connect to this node and service in a
...@@ -662,9 +678,11 @@ sub _parse_hosts($) { ...@@ -662,9 +678,11 @@ sub _parse_hosts($) {
next unless @aliases; next unless @aliases;
if (my $ip = parse_ipv4 $addr) { if (my $ip = parse_ipv4 $addr) {
($ip) = $ip =~ /^(.*)$/s if AnyEvent::TAINT;
push @{ $HOSTS{$_}[0] }, $ip push @{ $HOSTS{$_}[0] }, $ip
for @aliases; for @aliases;
} elsif (my $ip = parse_ipv6 $addr) { } elsif (my $ip = parse_ipv6 $addr) {
($ip) = $ip =~ /^(.*)$/s if AnyEvent::TAINT;
push @{ $HOSTS{$_}[1] }, $ip push @{ $HOSTS{$_}[1] }, $ip
for @aliases; for @aliases;
} }
...@@ -783,20 +801,18 @@ sub resolve_sockaddr($$$$$$) { ...@@ -783,20 +801,18 @@ sub resolve_sockaddr($$$$$$) {
} else { } else {
$node =~ y/A-Z/a-z/; $node =~ y/A-Z/a-z/;
my $hosts = $HOSTS{$node};
# a records # a records
if ($family != 6) { if ($family != 6) {
$cv->begin; $cv->begin;
AnyEvent::DNS::a $node, sub { AnyEvent::DNS::a $node, sub {
push @res, [$idx, "ipv4", [AF_INET , $type, $proton, pack_sockaddr $port, parse_ipv4 $_]] push @res, [$idx, "ipv4", [AF_INET, $type, $proton, pack_sockaddr $port, parse_ipv4 $_]]
for @_; for @_;
# dns takes precedence over hosts # dns takes precedence over hosts
_load_hosts_unless { _load_hosts_unless {
push @res, push @res,
map [$idx, "ipv4", [AF_INET , $type, $proton, pack_sockaddr $port, $_]], map [$idx, "ipv4", [AF_INET, $type, $proton, pack_sockaddr $port, $_]],
@{ $hosts->[0] }; @{ ($HOSTS{$node} || [])->[0] };
} $cv, @_; } $cv, @_;
}; };
} }
...@@ -811,7 +827,7 @@ sub resolve_sockaddr($$$$$$) { ...@@ -811,7 +827,7 @@ sub resolve_sockaddr($$$$$$) {
_load_hosts_unless { _load_hosts_unless {
push @res, push @res,
map [$idx + 0.5, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, $_]], map [$idx + 0.5, "ipv6", [AF_INET6, $type, $proton, pack_sockaddr $port, $_]],
@{ $hosts->[1] } @{ ($HOSTS{$node} || [])->[1] }
} $cv, @_; } $cv, @_;
}; };
} }
...@@ -904,9 +920,6 @@ in not-yet-connected state as only argument and must return the connection ...@@ -904,9 +920,6 @@ in not-yet-connected state as only argument and must return the connection
timeout value (or C<0>, C<undef> or the empty list to indicate the default timeout value (or C<0>, C<undef> or the empty list to indicate the default
timeout is to be used). timeout is to be used).
Note that the socket could be either a IPv4 TCP socket or an IPv6 TCP
socket (although only IPv4 is currently supported by this module).
Note to the poor Microsoft Windows users: Windows (of course) doesn't Note to the poor Microsoft Windows users: Windows (of course) doesn't
correctly signal connection errors, so unless your event library works correctly signal connection errors, so unless your event library works
around this, failed connections will simply hang. The only event libraries around this, failed connections will simply hang. The only event libraries
...@@ -1004,7 +1017,7 @@ sub tcp_connect($$$;$) { ...@@ -1004,7 +1017,7 @@ sub tcp_connect($$$;$) {
socket $state{fh}, $domain, $type, $proto socket $state{fh}, $domain, $type, $proto
or return $state{next}(); or return $state{next}();
fh_nonblocking $state{fh}, 1; AnyEvent::fh_unblock $state{fh};
my $timeout = $prepare && $prepare->($state{fh}); my $timeout = $prepare && $prepare->($state{fh});
...@@ -1100,12 +1113,16 @@ mode) as first, and the peer host and port as second and third arguments ...@@ -1100,12 +1113,16 @@ mode) as first, and the peer host and port as second and third arguments
Croaks on any errors it can detect before the listen. Croaks on any errors it can detect before the listen.
If called in non-void context, then this function returns a guard object In non-void context, this function returns a guard object whose lifetime
whose lifetime it tied to the TCP server: If the object gets destroyed, it tied to the TCP server: If the object gets destroyed, the server will
the server will be stopped (but existing accepted connections will be stopped and the listening socket will be cleaned up/unlinked (already
not be affected). accepted connections will not be affected).
When called in void-context, AnyEvent will keep the listening socket alive
internally. In this case, there is no guarantee that the listening socket
will be cleaned up or unlinked.
Regardless, when the function returns to the caller, the socket is bound In all cases, when the function returns to the caller, the socket is bound
and in listening state. and in listening state.
If you need more control over the listening socket, you can provide a If you need more control over the listening socket, you can provide a
...@@ -1141,84 +1158,117 @@ Example: bind a server on a unix domain socket. ...@@ -1141,84 +1158,117 @@ Example: bind a server on a unix domain socket.
my ($fh) = @_; my ($fh) = @_;
}; };
=item $guard = AnyEvent::Socket::tcp_bind $host, $service, $done_cb[, $prepare_cb]
Same as C<tcp_server>, except it doesn't call C<accept> in a loop for you
but simply passes the listen socket to the C<$done_cb>. This is useful
when you want to have a convenient set up for your listen socket, but want
to do the C<accept>'ing yourself, for example, in another process.
In case of an error, C<tcp_bind> either croaks, or passes C<undef> to the
C<$done_cb>.
In non-void context, a guard will be returned. It will clean up/unlink the
listening socket when destroyed. In void context, no automatic clean up
might be performed.
=cut =cut
sub tcp_server($$$;$) { sub _tcp_bind($$$;$) {
my ($host, $service, $accept, $prepare) = @_; my ($host, $service, $done, $prepare) = @_;
$host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6 $host = $AnyEvent::PROTOCOL{ipv4} < $AnyEvent::PROTOCOL{ipv6} && AF_INET6
? "::" : "0" ? "::" : "0"
unless defined $host; unless defined $host;
my $ipn = parse_address $host my $ipn = parse_address $host
or Carp::croak "AnyEvent::Socket::tcp_server: cannot parse '$host' as host address"; or Carp::croak "tcp_bind: cannot parse '$host' as host address";
my $af = address_family $ipn; my $af = address_family $ipn;
my %state; my %state;
# win32 perl is too stupid to get this right :/ # win32 perl is too stupid to get this right :/
Carp::croak "tcp_server/socket: address family not supported" Carp::croak "tcp_bind: AF_UNIX address family not supported on win32"
if AnyEvent::WIN32 && $af == AF_UNIX; if AnyEvent::WIN32 && $af == AF_UNIX;
socket $state{fh}, $af, SOCK_STREAM, 0 socket my $fh, $af, SOCK_STREAM, 0
or Carp::croak "tcp_server/socket: $!"; or Carp::croak "tcp_bind: $!";
$state{fh} = $fh;
if ($af == AF_INET || $af == AF_INET6) { if ($af == AF_INET || $af == AF_INET6) {
setsockopt $state{fh}, SOL_SOCKET, SO_REUSEADDR, 1 setsockopt $fh, SOL_SOCKET, SO_REUSEADDR, 1
or Carp::croak "tcp_server/so_reuseaddr: $!" or Carp::croak "tcp_bind: so_reuseaddr: $!"
unless AnyEvent::WIN32; # work around windows bug unless AnyEvent::WIN32; # work around windows bug
unless ($service =~ /^\d*$/) { unless ($service =~ /^\d*$/) {
$service = (getservbyname $service, "tcp")[2] $service = (getservbyname $service, "tcp")[2]
or Carp::croak "$service: service unknown" or Carp::croak "tcp_bind: unknown service '$service'"
} }
} elsif ($af == AF_UNIX) { } elsif ($af == AF_UNIX) {
unlink $service; unlink $service;
} }
bind $state{fh}, pack_sockaddr $service, $ipn bind $fh, pack_sockaddr $service, $ipn
or Carp::croak "bind: $!"; or Carp::croak "tcp_bind: $!";
if ($af == AF_UNIX) { if ($af == AF_UNIX and defined wantarray) {
my $fh = $state{fh}; # this is racy, but is not designed to be foolproof, just best-effort
my $ino = (stat $fh)[1]; my $ino = (lstat $service)[1];
$state{unlink} = guard { $state{unlink} = guard {
# this is racy, but is not designed to be foolproof, just best-effort
unlink $service unlink $service
if $ino == (stat $fh)[1]; if (lstat $service)[1] == $ino;
}; };
} }
fh_nonblocking $state{fh}, 1; AnyEvent::fh_unblock $fh;
my $len; my $len;
if ($prepare) { if ($prepare) {
my ($service, $host) = unpack_sockaddr getsockname $state{fh}; my ($service, $host) = unpack_sockaddr getsockname $fh;
$len = $prepare && $prepare->($state{fh}, format_address $host, $service); $len = $prepare && $prepare->($fh, format_address $host, $service);
} }
$len ||= 128; $len ||= 128;
listen $state{fh}, $len listen $fh, $len
or Carp::croak "listen: $!"; or Carp::croak "tcp_bind: $!";
$state{aw} = AE::io $state{fh}, 0, sub { $done->(\%state);
# this closure keeps $state alive
while ($state{fh} && (my $peer = accept my $fh, $state{fh})) {
fh_nonblocking $fh, 1; # POSIX requires inheritance, the outside world does not
my ($service, $host) = unpack_sockaddr $peer;
$accept->($fh, format_address $host, $service);
}
};
defined wantarray defined wantarray
? guard { %state = () } # clear fh and watcher, which breaks the circular dependency ? guard { %state = () } # clear fh, unlink
: () : ()
} }
sub tcp_bind($$$;$) {
my ($host, $service, $done, $prepare) = @_;
_tcp_bind $host, $service, sub {
$done->(delete shift->{fh});
}, $prepare
}
sub tcp_server($$$;$) {
my ($host, $service, $accept, $prepare) = @_;
_tcp_bind $host, $service, sub {
my $rstate = shift;
$rstate->{aw} = AE::io $rstate->{fh}, 0, sub {
# this closure keeps $state alive
while ($rstate->{fh} && (my $peer = accept my $fh, $rstate->{fh})) {
AnyEvent::fh_unblock $fh; # POSIX requires inheritance, the outside world does not
my ($service, $host) = unpack_sockaddr $peer;
$accept->($fh, format_address $host, $service);
}
};
}, $prepare
}
=item tcp_nodelay $fh, $enable =item tcp_nodelay $fh, $enable
Enables (or disables) the C<TCP_NODELAY> socket option (also known as Enables (or disables) the C<TCP_NODELAY> socket option (also known as
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Strict.pm
View file @ 971eb4d6
...@@ -24,10 +24,13 @@ L<AnyEvent>). However, this module can be loaded manually at any time. ...@@ -24,10 +24,13 @@ L<AnyEvent>). However, this module can be loaded manually at any time.
package AnyEvent::Strict; package AnyEvent::Strict;
use Carp qw(croak); use Carp qw(confess);
use Errno (); use Errno ();
use POSIX (); use POSIX ();
$Carp::Internal{AE} = 1;
$Carp::Internal{AnyEvent::Strict} = 1;
use AnyEvent (); BEGIN { AnyEvent::common_sense } use AnyEvent (); BEGIN { AnyEvent::common_sense }
AnyEvent::_isa_hook 1 => "AnyEvent::Strict", 1; AnyEvent::_isa_hook 1 => "AnyEvent::Strict", 1;
...@@ -93,28 +96,28 @@ sub io { ...@@ -93,28 +96,28 @@ sub io {
my (%arg, $fh, $cb, $fd) = @_; my (%arg, $fh, $cb, $fd) = @_;
ref $arg{cb} ref $arg{cb}
or croak "AnyEvent->io called with illegal cb argument '$arg{cb}'"; or confess "AnyEvent->io called with illegal cb argument '$arg{cb}'";
$cb = wrap delete $arg{cb}; $cb = wrap delete $arg{cb};
$arg{poll} =~ /^[rw]$/ $arg{poll} =~ /^[rw]$/
or croak "AnyEvent->io called with illegal poll argument '$arg{poll}'"; or confess "AnyEvent->io called with illegal poll argument '$arg{poll}'";
$fh = delete $arg{fh}; $fh = delete $arg{fh};
if ($fh =~ /^\s*\d+\s*$/) { if ($fh =~ /^\s*\d+\s*$/) {
$fd = $fh; $fd = $fh;
$fh = AnyEvent::_dupfh $arg{poll}, $fh; ($fh) = AnyEvent::_dupfh $arg{poll}, $fh;
} else { } else {
defined eval { $fd = fileno $fh } defined eval { $fd = fileno $fh }
or croak "AnyEvent->io called with illegal fh argument '$fh'"; or confess "AnyEvent->io called with illegal fh argument '$fh'";
} }
-f $fh -f $fh
and croak "AnyEvent->io called with fh argument pointing to a file"; and confess "AnyEvent->io called with fh argument pointing to a file";
delete $arg{poll}; delete $arg{poll};
croak "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg confess "AnyEvent->io called with unsupported parameter(s) " . join ", ", keys %arg
if keys %arg; if keys %arg;
++$FD_INUSE[$fd]; ++$FD_INUSE[$fd];
...@@ -134,18 +137,18 @@ sub timer { ...@@ -134,18 +137,18 @@ sub timer {
my %arg = @_; my %arg = @_;
ref $arg{cb} ref $arg{cb}
or croak "AnyEvent->timer called with illegal cb argument '$arg{cb}'"; or confess "AnyEvent->timer called with illegal cb argument '$arg{cb}'";
my $cb = wrap delete $arg{cb}; my $cb = wrap delete $arg{cb};
exists $arg{after} exists $arg{after}
or croak "AnyEvent->timer called without mandatory 'after' parameter"; or confess "AnyEvent->timer called without mandatory 'after' parameter";
delete $arg{after}; delete $arg{after};
!$arg{interval} or $arg{interval} > 0 !$arg{interval} or $arg{interval} > 0
or croak "AnyEvent->timer called with illegal interval argument '$arg{interval}'"; or confess "AnyEvent->timer called with illegal interval argument '$arg{interval}'";
delete $arg{interval}; delete $arg{interval};
croak "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg confess "AnyEvent->timer called with unsupported parameter(s) " . join ", ", keys %arg
if keys %arg; if keys %arg;
$class->SUPER::timer (@_, cb => $cb) $class->SUPER::timer (@_, cb => $cb)
...@@ -156,14 +159,14 @@ sub signal { ...@@ -156,14 +159,14 @@ sub signal {
my %arg = @_; my %arg = @_;
ref $arg{cb} ref $arg{cb}
or croak "AnyEvent->signal called with illegal cb argument '$arg{cb}'"; or confess "AnyEvent->signal called with illegal cb argument '$arg{cb}'";
my $cb = wrap delete $arg{cb}; my $cb = wrap delete $arg{cb};
defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0 defined AnyEvent::Base::sig2num $arg{signal} and $arg{signal} == 0
or croak "AnyEvent->signal called with illegal signal name '$arg{signal}'"; or confess "AnyEvent->signal called with illegal signal name '$arg{signal}'";
delete $arg{signal}; delete $arg{signal};
croak "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg confess "AnyEvent->signal called with unsupported parameter(s) " . join ", ", keys %arg
if keys %arg; if keys %arg;
$class->SUPER::signal (@_, cb => $cb) $class->SUPER::signal (@_, cb => $cb)
...@@ -174,14 +177,14 @@ sub child { ...@@ -174,14 +177,14 @@ sub child {
my %arg = @_; my %arg = @_;
ref $arg{cb} ref $arg{cb}
or croak "AnyEvent->child called with illegal cb argument '$arg{cb}'"; or confess "AnyEvent->child called with illegal cb argument '$arg{cb}'";
my $cb = wrap delete $arg{cb}; my $cb = wrap delete $arg{cb};
$arg{pid} =~ /^-?\d+$/ $arg{pid} =~ /^-?\d+$/
or croak "AnyEvent->child called with malformed pid value '$arg{pid}'"; or confess "AnyEvent->child called with malformed pid value '$arg{pid}'";
delete $arg{pid}; delete $arg{pid};
croak "AnyEvent->child called with unsupported parameter(s) " . join ", ", keys %arg confess "AnyEvent->child called with unsupported parameter(s) " . join ", ", keys %arg
if keys %arg; if keys %arg;
$class->SUPER::child (@_, cb => $cb) $class->SUPER::child (@_, cb => $cb)
...@@ -192,10 +195,10 @@ sub idle { ...@@ -192,10 +195,10 @@ sub idle {
my %arg = @_; my %arg = @_;
ref $arg{cb} ref $arg{cb}
or croak "AnyEvent->idle called with illegal cb argument '$arg{cb}'"; or confess "AnyEvent->idle called with illegal cb argument '$arg{cb}'";
my $cb = wrap delete $arg{cb}; my $cb = wrap delete $arg{cb};
croak "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg confess "AnyEvent->idle called with unsupported parameter(s) " . join ", ", keys %arg
if keys %arg; if keys %arg;
$class->SUPER::idle (@_, cb => $cb) $class->SUPER::idle (@_, cb => $cb)
...@@ -206,10 +209,10 @@ sub condvar { ...@@ -206,10 +209,10 @@ sub condvar {
my %arg = @_; my %arg = @_;
!exists $arg{cb} or ref $arg{cb} !exists $arg{cb} or ref $arg{cb}
or croak "AnyEvent->condvar called with illegal cb argument '$arg{cb}'"; or confess "AnyEvent->condvar called with illegal cb argument '$arg{cb}'";
my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : (); my @cb = exists $arg{cb} ? (cb => wrap delete $arg{cb}) : ();
croak "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg confess "AnyEvent->condvar called with unsupported parameter(s) " . join ", ", keys %arg
if keys %arg; if keys %arg;
$class->SUPER::condvar (@cb); $class->SUPER::condvar (@cb);
...@@ -219,7 +222,7 @@ sub time { ...@@ -219,7 +222,7 @@ sub time {
my $class = shift; my $class = shift;
@_ @_
and croak "AnyEvent->time wrongly called with paramaters"; and confess "AnyEvent->time wrongly called with paramaters";
$class->SUPER::time (@_) $class->SUPER::time (@_)
} }
...@@ -228,7 +231,7 @@ sub now { ...@@ -228,7 +231,7 @@ sub now {
my $class = shift; my $class = shift;
@_ @_
and croak "AnyEvent->now wrongly called with paramaters"; and confess "AnyEvent->now wrongly called with paramaters";
$class->SUPER::now (@_) $class->SUPER::now (@_)
} }
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/TLS.pm
View file @ 971eb4d6
...@@ -119,6 +119,14 @@ our %DH_PARAMS = ( ...@@ -119,6 +119,14 @@ our %DH_PARAMS = (
schmorp2048 => "MIIBCAKCAQEAhR5Fn9h3Tgnc+q4o3CMkZtre3lLUyDT+1bf3aiVOt22JdDQndZLc|FeKz8AqliB3UIgNExc6oDtuG4znKPgklfOnHv/a9tl1AYQbV+QFM/E0jYl6oG8tF|Epgxezt1GCivvtu64ql0s213wr64QffNMt3hva8lNqK1PXfqp13PzzLzAVsfghrv|fMAX7/bYm1T5fAJdcah6FeZkKof+mqbs8HtRjfvrUF2npEM2WdupFu190vcwABnN|TTJheXCWv2BF2f9EEr61q3OUhSNWIThtZP+NKe2bACm1PebT0drAcaxKoMz9LjKr|y5onGs0TOuQ7JmhtZL45Zr4LwBcyTucLUwIBAg==", schmorp2048 => "MIIBCAKCAQEAhR5Fn9h3Tgnc+q4o3CMkZtre3lLUyDT+1bf3aiVOt22JdDQndZLc|FeKz8AqliB3UIgNExc6oDtuG4znKPgklfOnHv/a9tl1AYQbV+QFM/E0jYl6oG8tF|Epgxezt1GCivvtu64ql0s213wr64QffNMt3hva8lNqK1PXfqp13PzzLzAVsfghrv|fMAX7/bYm1T5fAJdcah6FeZkKof+mqbs8HtRjfvrUF2npEM2WdupFu190vcwABnN|TTJheXCWv2BF2f9EEr61q3OUhSNWIThtZP+NKe2bACm1PebT0drAcaxKoMz9LjKr|y5onGs0TOuQ7JmhtZL45Zr4LwBcyTucLUwIBAg==",
schmorp4096 => "MIICCAKCAgEA5WwA5lQg09YRYqc/JILCd2AfBmYBkF19wmCEJB8G3JhTxv8EGvYk|xyP2ecKVUvHTG8Xw/qpW8nRqzPIyV8QRf6YFYSf33Qnx2xYhcnqOumU3nfC0SNOL|/w2q1BA9BbHtW4574P+6hOQx9ftRtbtZ2HPKBMRcAKGjpYZiKopv0+UAM4NpEC2p|bfajp7pyVLeb/Aqm/oWP3L63wPlY1SDp+XRzrOAKB+/uLGqEwV0bBaxxGL29BpOp|O2z1ALGXiDCcLs9WTn9WqUhWDzUN6fahm53rd7zxwpFCb6K2YhaK0peG95jzSUJ8|aoL0KgWuC6v5+gPJHRu0HrQIdfAdN4VchqYOKE46uNNkQl8VJGu4RjYB7lFBpRwO|g2HCsGMo2X7BRmA1st66fh+JOd1smXMZG/2ozTOooL+ixcx4spNneg4aQerWl5cb|nWXKtPCp8yPzt/zoNzL3Fon2Ses3sNgMos0M/ZbnigScDxz84Ms6V/X8Z0L4m/qX|mL42dP40tgvmgqi6BdsBzcIWeHlEcIhmGcsEBxxKEg7gjb0OjjvatpUCJhmRrGjJ|LtMkBR68qr42OBMN/PBB4KPOWNUqTauXZajfCwYdbpvV24ZhtkcRdw1zisyARBSh|aTKW/GV8iLsUzlYN27LgVEwMwnWQaoecW6eOTNKGUURC3In6XZSvVzsCAQI=", schmorp4096 => "MIICCAKCAgEA5WwA5lQg09YRYqc/JILCd2AfBmYBkF19wmCEJB8G3JhTxv8EGvYk|xyP2ecKVUvHTG8Xw/qpW8nRqzPIyV8QRf6YFYSf33Qnx2xYhcnqOumU3nfC0SNOL|/w2q1BA9BbHtW4574P+6hOQx9ftRtbtZ2HPKBMRcAKGjpYZiKopv0+UAM4NpEC2p|bfajp7pyVLeb/Aqm/oWP3L63wPlY1SDp+XRzrOAKB+/uLGqEwV0bBaxxGL29BpOp|O2z1ALGXiDCcLs9WTn9WqUhWDzUN6fahm53rd7zxwpFCb6K2YhaK0peG95jzSUJ8|aoL0KgWuC6v5+gPJHRu0HrQIdfAdN4VchqYOKE46uNNkQl8VJGu4RjYB7lFBpRwO|g2HCsGMo2X7BRmA1st66fh+JOd1smXMZG/2ozTOooL+ixcx4spNneg4aQerWl5cb|nWXKtPCp8yPzt/zoNzL3Fon2Ses3sNgMos0M/ZbnigScDxz84Ms6V/X8Z0L4m/qX|mL42dP40tgvmgqi6BdsBzcIWeHlEcIhmGcsEBxxKEg7gjb0OjjvatpUCJhmRrGjJ|LtMkBR68qr42OBMN/PBB4KPOWNUqTauXZajfCwYdbpvV24ZhtkcRdw1zisyARBSh|aTKW/GV8iLsUzlYN27LgVEwMwnWQaoecW6eOTNKGUURC3In6XZSvVzsCAQI=",
schmorp8192 => "MIIECAKCBAEA/SAEbRSSLenVxoInHiltm/ztSwehGOhOiUKfzDcKlRBZHlCC9jBl|S/aeklM6Ucg8E6J2bnfoh6CAdnE/glQOn6CifhZr8X/rnlL9/eP+r9m+aiAw4l0D|MBd8BondbEqwTZthMmLtx0SslnevsFAZ1Cj8WgmUNaSPOukvJ1N7aQ98U+E99Pw3|VG8ANBydXqLqW2sogS8FtZoMbVywcQuaGmC7M6i3Akxe3CCSIpR/JkEZIytREBSC|CH+x3oW/w+wHzq3w8DGB9hqz1iMXqDMiPIMSdXC0DaIPokLnd7X8u6N14yCAco2h|P0gspD3J8pS2FpUY8ZTVjzbVCjhNNmTryBZAxHSWBuX4xYcCHUtfGlUe/IGLSVE1|xIdFpZUfvlvAJjVq0/TtDMg3r2JSXrhQVlr8MPJwSApDVr5kOBHT/uABio4z+5yR|PAvundznfyo9GGAWhIA36GQqsxSQfoRTjWssFoR/cu+9aomRwwOLkvObu8nCVVLH|nLdKDk5cIR0TvNs9HZ6ZmkzL7ah7cPzEKl7U6eE6yZLVYMNecnPLS6PSAIG4gxcq|CVQrrZjQLfTDrJn0OGgpShX85RaDsuiRtp2bpDZ23YDqdwr4wRjvIargjqc2zcF+|jIb7dUS6ci7bVG/CGOQUuiMWAiXZ3a1f343SMf9A05/sf1xwnMeco6STBLZ3X+PA|4urU+grtpWaFtS/fPD2ILn8nrJ3WuSKKUeSnVM46mmJQsOkyn7z8l3jNLB17GYKo|qc+0UuU/2PM9qtZdZElSM/ACLV2vdCuaibop4B9UIP9z3F8kfZ72+zKxpGiE+Bo1|x8SfG8FQw90mYIx+qZzJ8MCvc2wh+l4wDX5KxrhwvcouE2tHQlwfDgv/DiIXp173|hAmUCV0+bPRW8IIJvBODdAWtJe9hNwxj1FFYmPA7l4wa3gXV4I6tb+iO1MbwVjZ/|116tD5MdCo3JuSisgPYCHfkQccwEO0FHEuBbmfN+fQimQ8H0dePP8XctwbkplsB+|aLT5hYKmva/j9smEswgyHglPwc3WvZ+2DgKk7A7DHi7a2gDwCRQlHaXtNWx3992R|dfNgkSeB1CvGSQoo95WpC9ZoqGmcSlVqdetDU8iglPmfYTKO8aIPA6TuTQ/lQ0IW|90LQmqP23FwnNFiyqX8+rztLq4KVkTyeHIQwig6vFxgD8N+SbZCW2PPiB72TVF2U|WePU8MRTv1OIGBUBajF49k28HnZPSGlILHtFEkYkbPvomcE5ENnoejwzjktOTS5d|/R3SIOvCauOzadtzwTYOXT78ORaR1KI1cm8DzkkwJTd/Rrk07Q5vnvnSJQMwFUeH|PwJIgWBQf/GZ/OsDHmkbYR2ZWDClbKw2mwIBAg==", schmorp8192 => "MIIECAKCBAEA/SAEbRSSLenVxoInHiltm/ztSwehGOhOiUKfzDcKlRBZHlCC9jBl|S/aeklM6Ucg8E6J2bnfoh6CAdnE/glQOn6CifhZr8X/rnlL9/eP+r9m+aiAw4l0D|MBd8BondbEqwTZthMmLtx0SslnevsFAZ1Cj8WgmUNaSPOukvJ1N7aQ98U+E99Pw3|VG8ANBydXqLqW2sogS8FtZoMbVywcQuaGmC7M6i3Akxe3CCSIpR/JkEZIytREBSC|CH+x3oW/w+wHzq3w8DGB9hqz1iMXqDMiPIMSdXC0DaIPokLnd7X8u6N14yCAco2h|P0gspD3J8pS2FpUY8ZTVjzbVCjhNNmTryBZAxHSWBuX4xYcCHUtfGlUe/IGLSVE1|xIdFpZUfvlvAJjVq0/TtDMg3r2JSXrhQVlr8MPJwSApDVr5kOBHT/uABio4z+5yR|PAvundznfyo9GGAWhIA36GQqsxSQfoRTjWssFoR/cu+9aomRwwOLkvObu8nCVVLH|nLdKDk5cIR0TvNs9HZ6ZmkzL7ah7cPzEKl7U6eE6yZLVYMNecnPLS6PSAIG4gxcq|CVQrrZjQLfTDrJn0OGgpShX85RaDsuiRtp2bpDZ23YDqdwr4wRjvIargjqc2zcF+|jIb7dUS6ci7bVG/CGOQUuiMWAiXZ3a1f343SMf9A05/sf1xwnMeco6STBLZ3X+PA|4urU+grtpWaFtS/fPD2ILn8nrJ3WuSKKUeSnVM46mmJQsOkyn7z8l3jNLB17GYKo|qc+0UuU/2PM9qtZdZElSM/ACLV2vdCuaibop4B9UIP9z3F8kfZ72+zKxpGiE+Bo1|x8SfG8FQw90mYIx+qZzJ8MCvc2wh+l4wDX5KxrhwvcouE2tHQlwfDgv/DiIXp173|hAmUCV0+bPRW8IIJvBODdAWtJe9hNwxj1FFYmPA7l4wa3gXV4I6tb+iO1MbwVjZ/|116tD5MdCo3JuSisgPYCHfkQccwEO0FHEuBbmfN+fQimQ8H0dePP8XctwbkplsB+|aLT5hYKmva/j9smEswgyHglPwc3WvZ+2DgKk7A7DHi7a2gDwCRQlHaXtNWx3992R|dfNgkSeB1CvGSQoo95WpC9ZoqGmcSlVqdetDU8iglPmfYTKO8aIPA6TuTQ/lQ0IW|90LQmqP23FwnNFiyqX8+rztLq4KVkTyeHIQwig6vFxgD8N+SbZCW2PPiB72TVF2U|WePU8MRTv1OIGBUBajF49k28HnZPSGlILHtFEkYkbPvomcE5ENnoejwzjktOTS5d|/R3SIOvCauOzadtzwTYOXT78ORaR1KI1cm8DzkkwJTd/Rrk07Q5vnvnSJQMwFUeH|PwJIgWBQf/GZ/OsDHmkbYR2ZWDClbKw2mwIBAg==",
# finite field dhe parameters, some taken from firefox, some directly from RFC 7919
ffdhe2048 => "MIIBCAKCAQEA//////////+t+FRYortKmq/cViAnPTzx2LnFg84tNpWp4TZBFGQz+8yTnc4kmz75fS/jY2MMddj2gbICrsRhetPfHtXV/WVhJDP1H18GbtCFY2VVPe0a87VXE15/V8k1mE8McODmi3fipona8+/och3xWKE2rec1MKzKT0g6eXq8CrGCsyT7YdEIqUuyyOP7uWrat2DX9GgdT0Kj3jlN9K5W7edjcrsZCwenyO4KbXCeAvzhzffi7MA0BM0oNC9hkXL+nOmFg/+OTxIy7vKBg8P+OxtMb61zO7X8vC7CIAXFjvGDfRaD ssbzSibBsu/6iGtCOGEoXJf//////////wIBAg==",
ffdhe3072 => "MIIBiAKCAYEA//////////+t+FRYortKmq/cViAnPTzx2LnFg84tNpWp4TZBFGQz+8yTnc4kmz75fS/jY2MMddj2gbICrsRhetPfHtXV/WVhJDP1H18GbtCFY2VVPe0a87VXE15/V8k1mE8McODmi3fipona8+/och3xWKE2rec1MKzKT0g6eXq8CrGCsyT7YdEIqUuyyOP7uWrat2DX9GgdT0Kj3jlN9K5W7edjcrsZCwenyO4KbXCeAvzhzffi7MA0BM0oNC9hkXL+nOmFg/+OTxIy7vKBg8P+OxtMb61zO7X8vC7CIAXFjvGDfRaDssbzSibBsu/6iGtCOGEfz9zeNVs7ZRkDW7w09N75nAI4YbRvydbmyQd62R0mkff37lmMsPrBhtkcrv4TCYUTknC0EwyTvEN5RPT9RFLi103TZPLiHnH1S/9croKrnJ32nuhtK8UiNjoNq8Uhl5sN6todv5pC1cRITgq80Gv6U93vPBsg7j/VnXwl5B0rZsYuN///////////AgEC",
ffdhe4096 => "MIICCAKCAgEA///////////JD9qiIWjCNMTGYouA3BzRKQJOCIpnzHQCC76mOxObIlFKCHmONATd75UZs806QxswKwpt8l8UN0/hNW1tUcJF5IW1dmJefsb0TELppjftawv/XLb0Brft7jhr+1qJn6WunyQRfEsf5kkoZlHs5Fs9wgB8uKFjvwWY2kg2HFXTmmkWP6j9JM9fg2VdI9yjrZYcYvNWIIVSu57VKQdwlpZtZww1Tkq8mATxdGwIyhghfDKQXkYuNs474553LBgOhgObJ4Oi7Aeij7XFXfBvTFLJ3ivL9pVYFxg5lUl86pVq5RXSJhiY+gUQFXKOWoqqxC2tMxcNBFB6M6hVIavfHLpk7PuFBFjb7wqK6nFXXQYMfbOXD4Wm4eTHq/WujNsJM9cejJTgSiVhnc7j0iYa0u5r8S/6BtmKCGTYdgJzPshqZFIfKxgXeyAMu+EXV3phXWx3CYjAutlG4gjiT6B05asxQ9tb/OD9EI5LgtEgqSEIARpyPBKnh+bXiHGaEL26WyaZwycYavTiPBqUaDS2FQvaJYPpyirUTOjbu8LbBN6O+S6O/BQfvsqmKHxZR05rwF2ZspZPoJDDoiM7oYZRW+ftH2EpcM7i16+4G912IXBIHNAGkSfVsFqpk7TqmI2P3cGG/7fckKbAj030Nck0BjGZ//////////8CAQI=",
ffdhe6144 =>
"MIIDCAKCAwEA//////////+t+FRYortKmq/cViAnPTzx2LnFg84tNpWp4TZBFGQz+8yTnc4kmz75fS/jY2MMddj2gbICrsRhetPfHtXV/WVhJDP1H18GbtCFY2VVPe0a87VXE15/V8k1mE8McODmi3fipona8+/och3xWKE2rec1MKzKT0g6eXq8CrGCsyT7YdEIqUuyyOP7uWrat2DX9GgdT0Kj3jlN9K5W7edjcrsZCwenyO4KbXCeAvzhzffi7MA0BM0oNC9hkXL+nOmFg/+OTxIy7vKBg8P+OxtMb61zO7X8vC7CIAXFjvGDfRaDssbzSibBsu/6iGtCOGEfz9zeNVs7ZRkDW7w09N75nAI4YbRvydbmyQd62R0mkff37lmMsPrBhtkcrv4TCYUTknC0EwyTvEN5RPT9RFLi103TZPLiHnH1S/9croKrnJ32nuhtK8UiNjoNq8Uhl5sN6todv5pC1cRITgq80Gv6U93vPBsg7j/VnXwl5B0rZp4e8W5vUsMWTfT7eTDp5OWIV7asfV9C1p9tGHdjzx1VA0AEh/VbpX4xzHpxNciG77Qxiu1qHgEtnmgyqQdgCpGBMMRtx3j5ca0AOAkpmaMzy4t6Gh25PXFAADwqTs6p+Y0KzAqCkc3OyX3Pjsm1Wn+IpGtNtahR9EGC4caKAH5eDdkCC/1ktkUDbHpOZ30sOFMqOiO6RELK9T6mO7RUMpt2JMiRe91kscD9TLOOjDNMcBw6za0GV/zP7HGbH1w+TkYEHziBR/tM/bR3pSRx96mpaRC4VTIu22NA2KAO8JI1BRHjCr7B//njom5/sp+MGDAjw1h+ONoAd9m0dj5OS5Syu8GUxmUed8r5ku6qwCMqKBv2s6c5wSJhFoIK6NtYR6Z8vvnJCRtGLVOM1ysDdGrnf15iKSwxFWKoRlBdyC24VDOK5J9SNclbkReMzy3Vys70A+ydGBDGJysEWztx+dxrgNY/3UqOmtseaWKmlSbUMWHBpB1XDXk42tSkDjKc0OQOZf//////////AgEC",
ffdhe8192 => "MIIECAKCBAEA//////////+t+FRYortKmq/cViAnPTzx2LnFg84tNpWp4TZBFGQz+8yTnc4kmz75fS/jY2MMddj2gbICrsRhetPfHtXV/WVhJDP1H18GbtCFY2VVPe0a87VXE15/V8k1mE8McODmi3fipona8+/och3xWKE2rec1MKzKT0g6eXq8CrGCsyT7YdEIqUuyyOP7uWrat2DX9GgdT0Kj3jlN9K5W7edjcrsZCwenyO4KbXCeAvzhzffi7MA0BM0oNC9hkXL+nOmFg/+OTxIy7vKBg8P+OxtMb61zO7X8vC7CIAXFjvGDfRaDssbzSibBsu/6iGtCOGEfz9zeNVs7ZRkDW7w09N75nAI4YbRvydbmyQd62R0mkff37lmMsPrBhtkcrv4TCYUTknC0EwyTvEN5RPT9RFLi103TZPLiHnH1S/9croKrnJ32nuhtK8UiNjoNq8Uhl5sN6todv5pC1cRITgq80Gv6U93vPBsg7j/VnXwl5B0rZp4e8W5vUsMWTfT7eTDp5OWIV7asfV9C1p9tGHdjzx1VA0AEh/VbpX4xzHpxNciG77Qxiu1qHgEtnmgyqQdgCpGBMMRtx3j5ca0AOAkpmaMzy4t6Gh25PXFAADwqTs6p+Y0KzAqCkc3OyX3Pjsm1Wn+IpGtNtahR9EGC4caKAH5eDdkCC/1ktkUDbHpOZ30sOFMqOiO6RELK9T6mO7RUMpt2JMiRe91kscD9TLOOjDNMcBw6za0GV/zP7HGbH1w+TkYEHziBR/tM/bR3pSRx96mpaRC4VTIu22NA2KAO8JI1BRHjCr7B//njom5/sp+MGDAjw1h+ONoAd9m0dj5OS5Syu8GUxmUed8r5ku6qwCMqKBv2s6c5wSJhFoIK6NtYR6Z8vvnJCRtGLVOM1ysDdGrnf15iKSwxFWKoRlBdyC24VDOK5J9SNclbkReMzy3Vys70A+ydGBDGJysEWztx+dxrgNY/3UqOmtseaWKmlSbUMWHBpB1XDXk42tSkDjKcz/RqqjatAEz2AMg4HkJaMdlRrmT9sj/OyVCdQ2h/62nt0cxeC4zDvfZLEO+GtjFCo6uIKVVbL3R8kyZlyywPHMAb1wIpOIg50q8F5FRQSseLdYKCKEbAujXDX1xZFgzARv2CUVQfxoychrAiu3CZh2pGDnRRqKkxCXA/7hwhfmw4JuUsUappHg5CPPyZ6eMWUMEhe2JIFs2tmpX51bgBlIjZwKCh/jB1pXfiMYP4HUo/L6RXHvyM4LqKT+i2hV3+crCmbt7S+6v75Yow+vq+HF1xqH4vdB74wf6G/qa7/eUwZ38Nl9EdSfeoRD0IIuUGqfRhTgEeKpSDj/iM1oyLt8XGQkz//////////wIBAg==",
); );
=item $tls = new AnyEvent::TLS key => value... =item $tls = new AnyEvent::TLS key => value...
...@@ -127,12 +135,13 @@ The constructor supports these arguments (all as key => value pairs). ...@@ -127,12 +135,13 @@ The constructor supports these arguments (all as key => value pairs).
=over 4 =over 4
=item method => "SSLv2" | "SSLv3" | "TLSv1" | "any" =item method => "SSLv2" | "SSLv3" | "TLSv1" | "TLSv1_1" | "TLSv1_2" | "any"
The protocol parser to use. C<SSLv2>, C<SSLv3> and C<TLSv1> will use The protocol parser to use. C<SSLv2>, C<SSLv3>, C<TLSv1>, C<TLSv1_1>
a parser for those protocols only (so will I<not> accept or create and C<TLSv1_2> will use a parser for those protocols only (so will
connections with/to other protocol versions), while C<any> (the I<not> accept or create connections with/to other protocol versions),
default) uses a parser capable of all three protocols. while C<any> (the default) uses a parser capable of all three
protocols.
The default is to use C<"any"> but disable SSLv2. This has the effect of The default is to use C<"any"> but disable SSLv2. This has the effect of
sending a SSLv2 hello, indicating the support for SSLv3 and TLSv1, but not sending a SSLv2 hello, indicating the support for SSLv3 and TLSv1, but not
...@@ -141,11 +150,15 @@ actually negotiating an (insecure) SSLv2 connection. ...@@ -141,11 +150,15 @@ actually negotiating an (insecure) SSLv2 connection.
Specifying a specific version is almost always wrong to use for a server Specifying a specific version is almost always wrong to use for a server
speaking to a wide variety of clients (e.g. web browsers), and often wrong speaking to a wide variety of clients (e.g. web browsers), and often wrong
for a client. If you only want to allow a specific protocol version, use for a client. If you only want to allow a specific protocol version, use
the C<sslv2>, C<sslv3> or C<tlsv1> arguments instead. the C<sslv2>, C<sslv3>, C<tlsv1>, C<tlsv1_1> or C<tlsv1_2> arguments instead.
For new services it is usually a good idea to enforce a C<TLSv1> method For new services it is usually a good idea to enforce a C<TLSv1> method
from the beginning. from the beginning.
C<TLSv1_1> and C<TLSv1_2> require L<Net::SSLeay> >= 1.55 and OpenSSL
>= 1.0.1. Check the L<Net::SSLeay> and OpenSSL documentations for more
details.
=item sslv2 => $enabled =item sslv2 => $enabled
Enable or disable SSLv2 (normally I<disabled>). Enable or disable SSLv2 (normally I<disabled>).
...@@ -158,6 +171,20 @@ Enable or disable SSLv3 (normally I<enabled>). ...@@ -158,6 +171,20 @@ Enable or disable SSLv3 (normally I<enabled>).
Enable or disable TLSv1 (normally I<enabled>). Enable or disable TLSv1 (normally I<enabled>).
=item tlsv1_1 => $enabled
Enable or disable TLSv1_1 (normally I<enabled>).
This requires L<Net::SSLeay> >= 1.55 and OpenSSL >= 1.0.1. Check the
L<Net::SSLeay> and OpenSSL documentations for more details.
=item tlsv1_2 => $enabled
Enable or disable TLSv1_2 (normally I<enabled>).
This requires L<Net::SSLeay> >= 1.55 and OpenSSL >= 1.0.1. Check the
L<Net::SSLeay> and OpenSSL documentations for more details.
=item verify => $enable =item verify => $enable
Enable or disable peer certificate checking (default is I<disabled>, which Enable or disable peer certificate checking (default is I<disabled>, which
...@@ -231,16 +258,11 @@ This RFC isn't very useful in determining how to do verification so it ...@@ -231,16 +258,11 @@ This RFC isn't very useful in determining how to do verification so it
just assumes that subjectAltNames are possible, but no wildcards are just assumes that subjectAltNames are possible, but no wildcards are
possible anywhere. possible anywhere.
=item [$check_cn, $wildcards_in_alt, $wildcards_in_cn] =item [$wildcards_in_alt, $wildcards_in_cn, $check_cn]
You can also specify a scheme yourself by using an array reference with You can also specify a scheme yourself by using an array reference with
three integers. three integers.
C<$check_cn> specifies if and how the common name field is used: C<0>
means it will be completely ignored, C<1> means it will only be used if
no host names have been found in the subjectAltNames, and C<2> means the
common name will always be checked against the peername.
C<$wildcards_in_alt> and C<$wildcards_in_cn> specify whether and where C<$wildcards_in_alt> and C<$wildcards_in_cn> specify whether and where
wildcards (C<*>) are allowed in subjectAltNames and the common name, wildcards (C<*>) are allowed in subjectAltNames and the common name,
respectively. C<0> means no wildcards are allowed, C<1> means they respectively. C<0> means no wildcards are allowed, C<1> means they
...@@ -248,6 +270,11 @@ are allowed only as the first component (C<*.example.org>), and C<2> ...@@ -248,6 +270,11 @@ are allowed only as the first component (C<*.example.org>), and C<2>
means they can be used anywhere (C<www*.example.org>), except that very means they can be used anywhere (C<www*.example.org>), except that very
dangerous matches will not be allowed (C<*.org> or C<*>). dangerous matches will not be allowed (C<*.org> or C<*>).
C<$check_cn> specifies if and how the common name field is checked: C<0>
means it will be completely ignored, C<1> means it will only be used if
no host names have been found in the subjectAltNames, and C<2> means the
common name will always be checked against the peername.
=back =back
You can specify either the name of the parent protocol (recommended, You can specify either the name of the parent protocol (recommended,
...@@ -453,22 +480,23 @@ of course. ...@@ -453,22 +480,23 @@ of course.
=item dh => $string =item dh => $string
Specify the Diffie-Hellman parameters in PEM format directly as a string Specify the Diffie-Hellman parameters in PEM format directly as a string
(see C<dh_file>), the default is C<schmorp1539> unless C<dh_file> was (see C<dh_file>), the default is C<ffdhe3072> unless C<dh_file> was
specified. specified.
AnyEvent::TLS supports supports a number of precomputed DH parameters, AnyEvent::TLS supports supports a number of precomputed DH parameters,
since computing them is expensive. They are: since computing them is expensive. They are:
# from RFC 7919 - recommended
ffdhe2048, ffdhe3072, ffdhe4096, ffdhe6144, ffdhe8192
# from "Assigned Number for SKIP Protocols" # from "Assigned Number for SKIP Protocols"
skip512, skip1024, skip2048, skip4096 skip512, skip1024, skip2048, skip4096
# from schmorp # from schmorp
schmorp1024, schmorp1539, schmorp2048, schmorp4096, schmorp8192 schmorp1024, schmorp1539, schmorp2048, schmorp4096, schmorp8192
The default was chosen as a trade-off between security and speed, and It is said that 2048 bit DH parameters are safe till 2030, and DH
should be secure for a few years. It is said that 2048 bit DH parameters parameters shorter than 900 bits are totally insecure.
are safe till 2030, and DH parameters shorter than 900 bits are totally
insecure.
To disable DH protocols completely, specify C<undef> as C<dh> parameter. To disable DH protocols completely, specify C<undef> as C<dh> parameter.
...@@ -553,6 +581,40 @@ sub init (); ...@@ -553,6 +581,40 @@ sub init ();
# ocsp_request => 7, # ocsp_request => 7,
#); #);
BEGIN {
eval 'sub _check_tls_gt_1 (){'
. (($Net::SSLeay::VERSION >= 1.55 && Net::SSLeay::OPENSSL_VERSION_NUMBER() >= 0x1000100f) * 1)
. '}';
# as of this writing, Net::SSLeay (1.85-2) has not been ported to OpenSSL 1.1,
# but many distributions and users compile it against openssl 1.1, leading to
# many symbols not being defined because they are now enums instead of macros
# and have different prefixes.
# The only one we use is SSL_ST_OK, or TLS_ST_OK, which should be available
# as Net::SSLeay::ST_OK. If it is not callable, we define it to be 1, which
# hopefully will not change.
eval 'Net::SSLeay::ST_OK (); 1'
or *Net::SSLeay::ST_OK = sub () { 1 };
}
our %SSL_METHODS = (
any => \&Net::SSLeay::CTX_new,
sslv23 => \&Net::SSLeay::CTX_new, # deliberately undocumented
sslv2 => \&Net::SSLeay::CTX_v2_new,
sslv3 => \&Net::SSLeay::CTX_v3_new,
tlsv1 => \&Net::SSLeay::CTX_tlsv1_new,
);
# Add TLSv1_1 and TLSv1_2 if Net::SSLeay and openssl allow them
if (_check_tls_gt_1) {
$SSL_METHODS{tlsv1_1} = \&Net::SSLeay::CTX_tlsv1_1_new;
$SSL_METHODS{tlsv1_2} = \&Net::SSLeay::CTX_tlsv1_2_new;
} else {
for my $method (qw(tlsv1_1 tlsv1_2)) {
$SSL_METHODS{$method} = sub { croak "AnyEvent::TLS method '$method' requires openssl v1.0.1 and Net::SSLeay 1.55 or higher" };
}
}
sub new { sub new {
my ($class, %arg) = @_; my ($class, %arg) = @_;
...@@ -560,12 +622,8 @@ sub new { ...@@ -560,12 +622,8 @@ sub new {
my $method = lc $arg{method} || "any"; my $method = lc $arg{method} || "any";
my $ctx = $method eq "any" ? Net::SSLeay::CTX_new () my $ctx = ($SSL_METHODS{$method}
: $method eq "sslv23" ? Net::SSLeay::CTX_new () # deliberately undocumented || croak "'$method' is not a valid AnyEvent::TLS method (must be one of @{[ sort keys %SSL_METHODS ]})")->();
: $method eq "sslv2" ? Net::SSLeay::CTX_v2_new ()
: $method eq "sslv3" ? Net::SSLeay::CTX_v3_new ()
: $method eq "tlsv1" ? Net::SSLeay::CTX_tlsv1_new ()
: croak "'$method' is not a valid AnyEvent::TLS method (must be one of SSLv2, SSLv3, TLSv1 or any)";
my $self = bless { ctx => $ctx }, $class; # to make sure it's destroyed if we croak my $self = bless { ctx => $ctx }, $class; # to make sure it's destroyed if we croak
...@@ -574,6 +632,8 @@ sub new { ...@@ -574,6 +632,8 @@ sub new {
$op |= Net::SSLeay::OP_NO_SSLv2 () unless $arg{sslv2}; $op |= Net::SSLeay::OP_NO_SSLv2 () unless $arg{sslv2};
$op |= Net::SSLeay::OP_NO_SSLv3 () if exists $arg{sslv3} && !$arg{sslv3}; $op |= Net::SSLeay::OP_NO_SSLv3 () if exists $arg{sslv3} && !$arg{sslv3};
$op |= Net::SSLeay::OP_NO_TLSv1 () if exists $arg{tlsv1} && !$arg{tlsv1}; $op |= Net::SSLeay::OP_NO_TLSv1 () if exists $arg{tlsv1} && !$arg{tlsv1};
$op |= Net::SSLeay::OP_NO_TLSv1_1 () if exists $arg{tlsv1_1} && !$arg{tlsv1_1} && _check_tls_gt_1;
$op |= Net::SSLeay::OP_NO_TLSv1_2 () if exists $arg{tlsv1_2} && !$arg{tlsv1_2} && _check_tls_gt_1;
$op |= Net::SSLeay::OP_SINGLE_DH_USE () if !exists $arg{dh_single_use} || $arg{dh_single_use}; $op |= Net::SSLeay::OP_SINGLE_DH_USE () if !exists $arg{dh_single_use} || $arg{dh_single_use};
Net::SSLeay::CTX_set_options ($ctx, $op); Net::SSLeay::CTX_set_options ($ctx, $op);
...@@ -590,7 +650,7 @@ sub new { ...@@ -590,7 +650,7 @@ sub new {
$dh_bio = Net::SSLeay::BIO_new_file ($dh_file, "r") $dh_bio = Net::SSLeay::BIO_new_file ($dh_file, "r")
or croak "$dh_file: failed to open DH parameter file: $!"; or croak "$dh_file: failed to open DH parameter file: $!";
} else { } else {
$arg{dh} = "schmorp1539" unless exists $arg{dh}; $arg{dh} = "ffdhe3072" unless exists $arg{dh};
if (defined $arg{dh}) { if (defined $arg{dh}) {
$dh_file = "dh string"; $dh_file = "dh string";
...@@ -598,7 +658,7 @@ sub new { ...@@ -598,7 +658,7 @@ sub new {
if ($arg{dh} =~ /^\w+$/) { if ($arg{dh} =~ /^\w+$/) {
$dh_file = "dh params $arg{dh}"; $dh_file = "dh params $arg{dh}";
$arg{dh} = "-----BEGIN DH PARAMETERS-----\n" $arg{dh} = "-----BEGIN DH PARAMETERS-----\n"
. $DH_PARAMS{$arg{dh}} . "\n" . (join "\n", unpack "(a74)*", $DH_PARAMS{$arg{dh}}) . "\n"
. "-----END DH PARAMETERS-----"; . "-----END DH PARAMETERS-----";
$arg{dh} =~ s/\|/\n/g; $arg{dh} =~ s/\|/\n/g;
} }
...@@ -786,6 +846,7 @@ sub verify { ...@@ -786,6 +846,7 @@ sub verify {
#=cut #=cut
#our %REF_MAP; #our %REF_MAP;
our $TLS_SNI_WARNED;
sub _get_session($$;$$) { sub _get_session($$;$$) {
my ($self, $mode, $ref, $cn) = @_; my ($self, $mode, $ref, $cn) = @_;
...@@ -801,6 +862,15 @@ sub _get_session($$;$$) { ...@@ -801,6 +862,15 @@ sub _get_session($$;$$) {
} elsif ($mode eq "connect") { } elsif ($mode eq "connect") {
$session = Net::SSLeay::new ($self->{ctx}); $session = Net::SSLeay::new ($self->{ctx});
if (defined &Net::SSLeay::set_tlsext_host_name) {
Net::SSLeay::set_tlsext_host_name ($session, $cn)
if length $cn;
} else {
AE::log 6 => "TLS SNI not supported by your Net::SSLeay module, connecting without"
unless $TLS_SNI_WARNED++;
}
Net::SSLeay::set_connect_state ($session); Net::SSLeay::set_connect_state ($session);
Net::SSLeay::set_options ($session, eval { Net::SSLeay::OP_NO_TICKET () }) Net::SSLeay::set_options ($session, eval { Net::SSLeay::OP_NO_TICKET () })
...@@ -968,7 +1038,8 @@ sub verify_hostname($$$) { ...@@ -968,7 +1038,8 @@ sub verify_hostname($$$) {
my @cert_alt = Net::SSLeay::X509_get_subjectAltNames ($cert); my @cert_alt = Net::SSLeay::X509_get_subjectAltNames ($cert);
# rfc2460 - convert to network byte order # rfc2460 - convert to network byte order
my $ip = AnyEvent::Socket::parse_address $cn; require AnyEvent::Socket;
my $ip = AnyEvent::Socket::parse_address ($cn);
my $alt_dns_count; my $alt_dns_count;
...@@ -1061,7 +1132,7 @@ all... ...@@ -1061,7 +1132,7 @@ all...
You can switch off verification. You still get an encrypted connection You can switch off verification. You still get an encrypted connection
that is protected against eavesdropping and injection - you just lose that is protected against eavesdropping and injection - you just lose
protection against man in the middle attacks, i.e. somebody else with protection against man in the middle attacks, i.e. somebody else with
enough abilities to to intercept all traffic can masquerade herself as the enough abilities to intercept all traffic can masquerade herself as the
other side. other side.
For many applications, switching off verification is entirely For many applications, switching off verification is entirely
...@@ -1103,7 +1174,7 @@ on what to watch out for. ...@@ -1103,7 +1174,7 @@ on what to watch out for.
=head1 BUGS =head1 BUGS
To to the abysmal code quality of Net::SSLeay, this module will leak small Due to the abysmal code quality of Net::SSLeay, this module will leak small
amounts of memory per TLS connection (currently at least one perl scalar). amounts of memory per TLS connection (currently at least one perl scalar).
=head1 AUTHORS =head1 AUTHORS
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Util.pm
View file @ 971eb4d6
=encoding utf-8
=head1 NAME =head1 NAME
AnyEvent::Util - various utility functions. AnyEvent::Util - various utility functions.
...@@ -191,7 +193,8 @@ windows, it is abysmally slow, do not expect more than 5..20 forks/s on ...@@ -191,7 +193,8 @@ windows, it is abysmally slow, do not expect more than 5..20 forks/s on
that sucky platform (note this uses perl's pseudo-threads, so avoid those that sucky platform (note this uses perl's pseudo-threads, so avoid those
like the plague). like the plague).
Example: poor man's async disk I/O (better use L<IO::AIO>). Example: poor man's async disk I/O (better use L<AnyEvent::IO> together
with L<IO::AIO>).
fork_call { fork_call {
open my $fh, "</etc/passwd" open my $fh, "</etc/passwd"
...@@ -308,7 +311,7 @@ sub _fork_schedule { ...@@ -308,7 +311,7 @@ sub _fork_schedule {
POSIX::_exit (0); POSIX::_exit (0);
exit 1; exit 1;
} elsif (($! != &Errno::EAGAIN && $! != &Errno::ENOMEM) || !$forks) { } elsif (($! != &Errno::EAGAIN && $! != &Errno::EWOULDBLOCK && $! != &Errno::ENOMEM) || !$forks) {
# we ignore some errors as long as we can run at least one job # we ignore some errors as long as we can run at least one job
# maybe we should wait a few seconds and retry instead # maybe we should wait a few seconds and retry instead
die "fork_call: $!"; die "fork_call: $!";
...@@ -351,22 +354,18 @@ Sets the blocking state of the given filehandle (true == nonblocking, ...@@ -351,22 +354,18 @@ Sets the blocking state of the given filehandle (true == nonblocking,
false == blocking). Uses fcntl on anything sensible and ioctl FIONBIO on false == blocking). Uses fcntl on anything sensible and ioctl FIONBIO on
broken (i.e. windows) platforms. broken (i.e. windows) platforms.
Instead of using this function, you could use C<AnyEvent::fh_block> or
C<AnyEvent::fh_unblock>.
=cut =cut
BEGIN { BEGIN {
*fh_nonblocking = AnyEvent::WIN32 *fh_nonblocking = \&AnyEvent::_fh_nonblocking;
? sub($$) {
ioctl $_[0], 0x8004667e, pack "L", $_[1]; # FIONBIO
}
: sub($$) {
fcntl $_[0], AnyEvent::F_SETFL, $_[1] ? AnyEvent::O_NONBLOCK : 0;
}
;
} }
=item $guard = guard { CODE } =item $guard = guard { CODE }
This function creates a special object that, when called, will execute This function creates a special object that, when destroyed, will execute
the code block. the code block.
This is often handy in continuation-passing style code to clean up some This is often handy in continuation-passing style code to clean up some
...@@ -469,7 +468,8 @@ when the program exits I<and> all redirected file descriptors have been ...@@ -469,7 +468,8 @@ when the program exits I<and> all redirected file descriptors have been
exhausted. exhausted.
The C<$cmd> is either a single string, which is then passed to a shell, or The C<$cmd> is either a single string, which is then passed to a shell, or
an arrayref, which is passed to the C<execvp> function. an arrayref, which is passed to the C<execvp> function (the first array
element is used both for the executable name and argv[0]).
The key-value pairs can be: The key-value pairs can be:
...@@ -485,6 +485,12 @@ Redirects program standard output into the specified filename, similar to C<< ...@@ -485,6 +485,12 @@ Redirects program standard output into the specified filename, similar to C<<
Appends program standard output to the referenced scalar. The condvar will Appends program standard output to the referenced scalar. The condvar will
not be signalled before EOF or an error is signalled. not be signalled before EOF or an error is signalled.
Specifying the same scalar in multiple ">" pairs is allowed, e.g. to
redirect both stdout and stderr into the same scalar:
">" => \$output,
"2>" => \$output,
=item ">" => $filehandle =item ">" => $filehandle
Redirects program standard output to the given filehandle (or actually its Redirects program standard output to the given filehandle (or actually its
...@@ -544,7 +550,7 @@ subprocess after C<run_cmd> returns. ...@@ -544,7 +550,7 @@ subprocess after C<run_cmd> returns.
Note the the PID might already have been recycled and used by an unrelated Note the the PID might already have been recycled and used by an unrelated
process at the time C<run_cmd> returns, so it's not useful to send process at the time C<run_cmd> returns, so it's not useful to send
signals, use a unique key in data structures and so on. signals, use as a unique key in data structures and so on.
=back =back
...@@ -561,7 +567,7 @@ Example: run F<openssl> and create a self-signed certificate and key, ...@@ -561,7 +567,7 @@ Example: run F<openssl> and create a self-signed certificate and key,
storing them in C<$cert> and C<$key>. When finished, check the exit status storing them in C<$cert> and C<$key>. When finished, check the exit status
in the callback and print key and certificate. in the callback and print key and certificate.
my $cv = run_cmd [qw(openssl req my $cv = run_cmd [qw(openssl req
-new -nodes -x509 -days 3650 -new -nodes -x509 -days 3650
-newkey rsa:2048 -keyout /dev/fd/3 -newkey rsa:2048 -keyout /dev/fd/3
-batch -subj /CN=AnyEvent -batch -subj /CN=AnyEvent
...@@ -801,7 +807,7 @@ sub idn_nameprep($;$) { ...@@ -801,7 +807,7 @@ sub idn_nameprep($;$) {
# load the mapping data # load the mapping data
unless (defined $uts46_imap) { unless (defined $uts46_imap) {
require Unicode::Normalize; require Unicode::Normalize;
require "lib/AnyEvent/Util/uts46data.pl"; require "AnyEvent/Util/uts46data.pl";
} }
# uts46 nameprep # uts46 nameprep
...@@ -821,7 +827,7 @@ sub idn_nameprep($;$) { ...@@ -821,7 +827,7 @@ sub idn_nameprep($;$) {
# not in valid class, search for mapping # not in valid class, search for mapping
utf8::encode $chr; # the imap table is in utf-8 utf8::encode $chr; # the imap table is in utf-8
(my $rep = index $uts46_imap, "\x00$chr") >= 0 (my $rep = index $uts46_imap, "\x00$chr") >= 0
or Carp::croak "$_[0]: disallowed characters ($chr) during idn_nameprep" . unpack "H*", $chr; or Carp::croak "$_[0]: disallowed characters (U+" . (unpack "H*", $chr) . ") during idn_nameprep";
(substr $uts46_imap, $rep, 128) =~ /\x00 .[\x80-\xbf]* ([^\x00]*) \x00/x (substr $uts46_imap, $rep, 128) =~ /\x00 .[\x80-\xbf]* ([^\x00]*) \x00/x
or die "FATAL: idn_nameprep imap table has unexpected contents"; or die "FATAL: idn_nameprep imap table has unexpected contents";
...@@ -868,7 +874,7 @@ sub idn_nameprep($;$) { ...@@ -868,7 +874,7 @@ sub idn_nameprep($;$) {
if (/[^0-9a-z\-.]/) { if (/[^0-9a-z\-.]/) {
# load the mapping data # load the mapping data
unless (defined $uts46_imap) { unless (defined $uts46_imap) {
require "lib/AnyEvent/Util/uts46data.pl"; require "AnyEvent/Util/uts46data.pl";
} }
vec $uts46_valid, ord, 1 vec $uts46_valid, ord, 1
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/constants.pl
View file @ 971eb4d6
# automatically generated from constants.pl.PL for perl 5.026003 built for x86_64-linux-thread-multi # automatically generated from constants.pl.PL
sub AnyEvent::common_sense {
local $^W;
${^WARNING_BITS} ^= ${^WARNING_BITS} ^ "\x0c\x3f\x33\x00\x0f\xf0\x0f\xc0\xf0\xfc\x33\x00\x00\x00\x0c\x00\x00";
$^H |= 0x7c0;
}
# generated for perl 5.026003 built for x86_64-linux-thread-multi
package AnyEvent; package AnyEvent;
sub CYGWIN(){0} sub CYGWIN(){0}
sub WIN32(){0} sub WIN32(){0}
...@@ -22,10 +28,15 @@ sub WSAEWOULDBLOCK(){-1e+99} ...@@ -22,10 +28,15 @@ sub WSAEWOULDBLOCK(){-1e+99}
sub WSAEINPROGRESS(){-1e+99} sub WSAEINPROGRESS(){-1e+99}
sub _AF_INET6(){10} sub _AF_INET6(){10}
package AnyEvent::Socket; package AnyEvent::Socket;
sub MSG_DONTWAIT(){64}
sub MSG_FASTOPEN(){536870912}
sub MSG_MORE(){32768}
sub MSG_NOSIGNAL(){16384}
sub TCP_CONGESTION(){13} sub TCP_CONGESTION(){13}
sub TCP_CONNECTIONTIMEOUT(){undef} sub TCP_CONNECTIONTIMEOUT(){undef}
sub TCP_CORK(){3} sub TCP_CORK(){3}
sub TCP_DEFER_ACCEPT(){9} sub TCP_DEFER_ACCEPT(){9}
sub TCP_FASTOPEN(){23}
sub TCP_INFO(){11} sub TCP_INFO(){11}
sub TCP_INIT_CWND(){undef} sub TCP_INIT_CWND(){undef}
sub TCP_KEEPALIVE(){undef} sub TCP_KEEPALIVE(){undef}
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/auto/AnyEvent/.packlist
View file @ 971eb4d6
...@@ -19,6 +19,7 @@ ...@@ -19,6 +19,7 @@
/opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Perl.pm /opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Perl.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Qt.pm /opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Qt.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Tk.pm /opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/Tk.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Impl/UV.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Intro.pod /opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Intro.pod
/opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Log.pm /opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Log.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Loop.pm /opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/AnyEvent/Loop.pm
......
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/auto/IPC/Shareable/.packlist
View file @ 971eb4d6
/opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/Shareable.pm /opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/Shareable.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/Shareable/SharedMem.pm /opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/Shareable/SharedMem.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/IPC/ipc.pl
opt/thirdlane/perl_lib/local/dist/lib/perl5/x86_64-linux-thread-multi/auto/Mock/Sub/.packlist 0 → 100644
View file @ 971eb4d6
/opt/thirdlane/perl_lib/local/dist/lib/perl5/Mock/Sub.pm
/opt/thirdlane/perl_lib/local/dist/lib/perl5/Mock/Sub/Child.pm
usr/local/share/perl5/sitecustomize.pl
View file @ 971eb4d6
...@@ -14,6 +14,10 @@ sub new { ...@@ -14,6 +14,10 @@ sub new {
symlink ($self->{root}, "/usr/libexec/webmin/asterisk/perl_lib"); symlink ($self->{root}, "/usr/libexec/webmin/asterisk/perl_lib");
$self->{force_libs} //= ['/usr/libexec/webmin', '/usr/libexec/webmin/asterisk', '/usr/libexec/webmin/asterisk/extlib', $ENV{HOME} . '/workspace/pbxmanager/server/extlib']; $self->{force_libs} //= ['/usr/libexec/webmin', '/usr/libexec/webmin/asterisk', '/usr/libexec/webmin/asterisk/extlib', $ENV{HOME} . '/workspace/pbxmanager/server/extlib'];
$ENV{OPENSSL_PREFIX} = $self->{root} . '/local/usr';
$ENV{OPENSSL_INCLUDE} = $ENV{OPENSSL_PREFIX} . '/include';
$ENV{OPENSSL_LIB} = $ENV{OPENSSL_PREFIX} . '/lib';
$ENV{LD_LIBRARY_PATH} = $self->{root} . '/local/usr/lib' . ($ENV{LD_LIBRARY_PATH} ? (':' . $ENV{LD_LIBRARY_PATH}) : ''); $ENV{LD_LIBRARY_PATH} = $self->{root} . '/local/usr/lib' . ($ENV{LD_LIBRARY_PATH} ? (':' . $ENV{LD_LIBRARY_PATH}) : '');
$ENV{LD_RUN_PATH} = $self->{root} . '/local/usr/lib' . ($ENV{LD_RUN_PATH} ? (':' . $ENV{LD_RUN_PATH}) : ''); $ENV{LD_RUN_PATH} = $self->{root} . '/local/usr/lib' . ($ENV{LD_RUN_PATH} ? (':' . $ENV{LD_RUN_PATH}) : '');
$ENV{PKG_CONFIG_PATH} = $self->{root} . '/local/usr/lib/pkgconfig' . ($ENV{PKG_CONFIG_PATH} ? (':' . $ENV{PKG_CONFIG_PATH}) : ''); $ENV{PKG_CONFIG_PATH} = $self->{root} . '/local/usr/lib/pkgconfig' . ($ENV{PKG_CONFIG_PATH} ? (':' . $ENV{PKG_CONFIG_PATH}) : '');
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment