IPC-ShareLite-0.17/0000755000076500000240000000000011155603665012560 5ustar andystaffIPC-ShareLite-0.17/Changes0000644000076500000240000000613211155603622014046 0ustar andystaffRevision history for Perl extension IPC::ShareLite. 0.17 2009-03-10 - Make unicode test work on older Perls. 0.16 2009-03-09 - Add unicode test. 0.15 2009-03-09 - Add some logging to help diagnose smoke failures. 0.14 2009-03-07 - Croak if 4 char key string is not 8-bit clean. See #33672. 0.13 2008-03-09 - Fixed patching of double quoted strings in Makefile. Affects Win32 and, probably, VMS. 0.12 2008-02-25 - Use Devel::CheckLib to verify that we have a C compiler. 0.11 2008-02-25 - Removed POD coverage test. Dynamic constants make it flaky. 0.10 2008-02-24 - Use Perl's malloc wrappers - moved test into t/sharelite.t - made test use Test::More - removed Configure mechanism - assorted minor tidying 0.09 Wed Dec 4 13:51:05 PST 2002 - fixed bug in size() thanks to Craig Manley 0.08 Sat Jul 15 03:00:16 PDT 2000 - added define for PL_sv_undef for older perls thanks to Christian Gilmore 0.07 Fri Apr 14 02:56:47 PDT 2000 - changed sv_undef to PL_sv_undef; should now compile under 5.006. Thanks to Frey Kuo and Leon Brocard - improved performance of _rearrange_args() thanks to patch from Sam Tregar - renamed all _func names to sharelite_func due to conflict with IRIX libraries. Thanks to John Clutterbuck 0.06 Tue Jan 18 04:33:57 PST 2000 - Eliminated some warnings thanks to Jim Mosier - Fix DESTROY bug thanks to Sam Tregar 0.05 Thu Dec 10 08:00:22 PST 1998 - adding casting to shmat() calls - was checking shmat() return value for NULL instead of -1 - removed -O3 from Makefile.PL 0.04 Sun Nov 29 17:38:48 PST 1998 - now using metaconfig to determine whether semun definition is available -- thanks to Paul J. Schinder . 0.03 Thu Nov 19 12:36:06 PST 1998 - changed shlock() and shunlock() to lock() and unlock(). old names were confusing. Old names remain but are deprecated. - added accessor methods for key, exclusive, etc. - added _initialize() method - added retry for EIDRM error when allocating additional segments - added version() method for use with per-process caches - moved segment state variable from semaphore to shared memory (it's faster) - modified documentation 0.02 Sat Nov 14 05:20:01 1998 - removed signal stuff from tests - added destroy() accessor method - added check for EINVAL when locking semaphore in new_share() - replaced lock_ex() and lock_sh() methods with single shlock() method that accepts flock() flags. Renamed unlock() to shunlock(). - LOCK_EX, LOCK_SH, LOCK_UN, and LOCK_NB now available for import. - replaced sv_setpvn() call with sv_usepvn() in read_share() XS function to remove an unnecessary mem copy. - modified documentation. 0.01 Mon Nov 9 17:49:02 1998 - original version; created by h2xs 1.18 IPC-ShareLite-0.17/MANIFEST0000644000076500000240000000055211155603661013707 0ustar andystaffChanges inc/Devel/CheckLib.pm inc/IO/CaptureOutput.pm lib/IPC/ShareLite.pm Makefile.PL MANIFEST README ShareLite.xs sharestuff.c sharestuff.h t/00-load.t t/pod.t t/sharelite.t t/unicode-key.t typemap META.yml Module meta-data (added by MakeMaker) SIGNATURE Public-key signature (added by MakeMaker) IPC-ShareLite-0.17/META.yml0000644000076500000240000000114111155603661014022 0ustar andystaff--- #YAML:1.0 name: IPC-ShareLite version: 0.17 abstract: Lightweight interface to shared memory author: - Maurice Aubrey license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 requires: File::Spec: 0 Test::More: 0 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.48 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 no_index: package: - Devel::CheckLib - IO::CaptureOutput IPC-ShareLite-0.17/Makefile.PL0000644000076500000240000000302211155304256014521 0ustar andystaffuse 5.006001; use strict; use lib qw(inc); use Config; use Devel::CheckLib; use ExtUtils::MakeMaker; if ( $^O =~ /^(MS)?Win32$/ ) { warn "IPC::ShareLite doesn't work on Windows.\nStopping.\n"; exit 0; # == NA test result } if ( $^O =~ /^VMS$/ ) { warn "IPC::ShareLite doesn't work on VMS.\nStopping.\n"; exit 0; # == NA test result } # Check that we have a C compiler check_lib_or_exit(); my %mm_args = ( ( MM->can( 'signature_target' ) ? ( SIGN => 1 ) : () ), NAME => 'IPC::ShareLite', AUTHOR => 'Maurice Aubrey ', VERSION_FROM => 'lib/IPC/ShareLite.pm', ABSTRACT_FROM => 'lib/IPC/ShareLite.pm', PL_FILES => {}, PREREQ_PM => { 'Test::More' => 0, 'File::Spec' => 0, }, LIBS => [''], DEFINE => '', INC => '', OBJECT => 'sharestuff.o ShareLite.o', dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'IPC-ShareLite-*' }, ); { local $^W = 0; # Silence warning about non-numeric version if ( $ExtUtils::MakeMaker::VERSION >= '6.31' ) { $mm_args{LICENSE} = 'perl'; } } WriteMakefile( %mm_args ); package MY; sub metafile { my @lines = split /\n/, shift->SUPER::metafile_target( @_ ); my @exclude = qw( Devel::CheckLib IO::CaptureOutput ); my $pad = ' ' x 4; die "Can't parse Makefile fragment" unless $lines[-2] =~ /^([^"']*(["'])).*?(\2[^"']*)$/; splice @lines, -1, 0, map { "$1$_$3" } ( 'no_index:', "${pad}package:", map { "${pad}${pad}- $_" } @exclude ); return join "\n", @lines; } IPC-ShareLite-0.17/README0000644000076500000240000000303111155306407013427 0ustar andystaffIPC::ShareLite 0.17 DESCRIPTION IPC::ShareLite provides a simple interface to shared memory, allowing data to be efficiently communicated between processes. Your operating system must support SysV IPC (shared memory and semaphores) in order to use this module. COPYRIGHT & TERMS Copyright 1998-2002, Maurice Aubrey . All rights reserved. This module is free software; you may redistribute it and/or modify it under the same terms as Perl itself. THIS SOFTWARE IS PROVIDED "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DAMAGES RESULTING FROM THE USE OF THIS SOFTWARE. PREREQUISITES This module requires perl 5.004 or later. INSTALLATION To install this module, move into the directory where this file is located and type the following: perl Makefile.PL make make test make install This will install the module into the Perl library directory. If you lack sufficient privileges for this, then you can specify an alternate directory like this: perl Makefile.PL PREFIX=/where/I/want/it/put make make test make install See the POD documentation for further details. Once the module is installed, you should be able to read the documentation by typing the following from the command-line: perldoc IPC::ShareLite IPC-ShareLite-0.17/SIGNATURE0000644000076500000240000000321111155603665014041 0ustar andystaffThis file contains message digests of all files listed in MANIFEST, signed via the Module::Signature module, version 0.55. To verify the content in this distribution, first make sure you have Module::Signature installed, then type: % cpansign -v It will check each file's integrity, as well as the signature's validity. If "==> Signature verified OK! <==" is not displayed, the distribution may already have been compromised, and you should not run its Makefile.PL or Build.PL. -----BEGIN PGP SIGNED MESSAGE----- Hash: SHA1 SHA1 6c67d3ac9cfeda7daf66b48f1781a51c5a6c5053 Changes SHA1 1e23e4b7999b637f5b6f2cd3c37fdbd2d322349d MANIFEST SHA1 456adf723e4cd3b84ad657cf9d64cc7c042b977d META.yml SHA1 8e8a7dd37aece0dd916a78c1c7a7dfd55d4e1ec5 Makefile.PL SHA1 82c7acfb70f7c2bc7b00d628afc2e24d5ac89326 README SHA1 1327e7cf2deda846b3f20a8fcf583715c82788ed ShareLite.xs SHA1 be67fd6b5fe57d9f5c0707595be8e5f65f090763 inc/Devel/CheckLib.pm SHA1 223b535f54603412215d820f8d03709b99ef2ba9 inc/IO/CaptureOutput.pm SHA1 18ae9fc202a3cb6725428d830b3adfc9ba94523e lib/IPC/ShareLite.pm SHA1 5fe4ba63c8d84a0ffdd834a49c21fc8c22ecee11 sharestuff.c SHA1 f0dc48bc23afed673887fdb3c69c5cc9dcf41fd3 sharestuff.h SHA1 294b9854766274e2d8b0d7bbc738c7564b3a6d5a t/00-load.t SHA1 0190346d7072d458c8a10a45c19f86db641dcc48 t/pod.t SHA1 c20fff25b5d842c1961015e99b20ddf366cfa0ed t/sharelite.t SHA1 3afef6542d6b02d998082ae3828ee43bb6cd7cc7 t/unicode-key.t SHA1 cae7af10ad41654f2e353566d1659f7bb0301879 typemap -----BEGIN PGP SIGNATURE----- Version: GnuPG v1.4.9 (Darwin) iEYEARECAAYFAkm3B7EACgkQwoknRJZQnCHo9QCgpRRRIw+4F0Mvu0DS1+mr4I7C c2wAmwedVfSkTxgR4CVqfj/QnzBQBaJf =22Op -----END PGP SIGNATURE----- IPC-ShareLite-0.17/ShareLite.xs0000644000076500000240000001351011154610610014777 0ustar andystaff#ifdef __cplusplus extern "C" { #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" #ifdef __cplusplus } #endif #include #include #include #include "sharestuff.h" /* * Some perl version compatibility stuff. * Taken from HTML::Parser */ #include "patchlevel.h" #if PATCHLEVEL <= 4 /* perl5.004_XX */ #ifndef PL_sv_undef #define PL_sv_undef sv_undef #define PL_sv_yes sv_yes #endif #ifndef PL_hexdigit #define PL_hexdigit hexdigit #endif #if (PATCHLEVEL == 4 && SUBVERSION <= 4) /* The newSVpvn function was introduced in perl5.004_05 */ static SV * newSVpvn( char *s, STRLEN len ) { register SV *sv = newSV( 0 ); sv_setpvn( sv, s, len ); return sv; } #endif /* not perl5.004_05 */ #endif /* perl5.004_XX */ static double constant( char *name, int arg ) { errno = 0; switch ( *name ) { case 'A': break; case 'B': break; case 'C': break; case 'D': break; case 'E': break; case 'F': break; case 'G': if ( strEQ( name, "GETALL" ) ) #ifdef GETALL return GETALL; #else goto not_there; #endif if ( strEQ( name, "GETNCNT" ) ) #ifdef GETNCNT return GETNCNT; #else goto not_there; #endif if ( strEQ( name, "GETPID" ) ) #ifdef GETPID return GETPID; #else goto not_there; #endif if ( strEQ( name, "GETVAL" ) ) #ifdef GETVAL return GETVAL; #else goto not_there; #endif if ( strEQ( name, "GETZCNT" ) ) #ifdef GETZCNT return GETZCNT; #else goto not_there; #endif break; case 'H': break; case 'I': if ( strEQ( name, "IPC_ALLOC" ) ) #ifdef IPC_ALLOC return IPC_ALLOC; #else goto not_there; #endif if ( strEQ( name, "IPC_CREAT" ) ) #ifdef IPC_CREAT return IPC_CREAT; #else goto not_there; #endif if ( strEQ( name, "IPC_EXCL" ) ) #ifdef IPC_EXCL return IPC_EXCL; #else goto not_there; #endif if ( strEQ( name, "IPC_NOWAIT" ) ) #ifdef IPC_NOWAIT return IPC_NOWAIT; #else goto not_there; #endif if ( strEQ( name, "IPC_O_RMID" ) ) #ifdef IPC_O_RMID return IPC_O_RMID; #else goto not_there; #endif if ( strEQ( name, "IPC_O_SET" ) ) #ifdef IPC_O_SET return IPC_O_SET; #else goto not_there; #endif if ( strEQ( name, "IPC_O_STAT" ) ) #ifdef IPC_O_STAT return IPC_O_STAT; #else goto not_there; #endif if ( strEQ( name, "IPC_PRIVATE" ) ) #ifdef IPC_PRIVATE return IPC_PRIVATE; #else goto not_there; #endif if ( strEQ( name, "IPC_RMID" ) ) #ifdef IPC_RMID return IPC_RMID; #else goto not_there; #endif if ( strEQ( name, "IPC_SET" ) ) #ifdef IPC_SET return IPC_SET; #else goto not_there; #endif if ( strEQ( name, "IPC_STAT" ) ) #ifdef IPC_STAT return IPC_STAT; #else goto not_there; #endif break; case 'J': break; case 'K': break; case 'L': if ( strEQ( name, "LOCK_EX" ) ) #ifdef LOCK_EX return LOCK_EX; #else goto not_there; #endif if ( strEQ( name, "LOCK_SH" ) ) #ifdef LOCK_SH return LOCK_SH; #else goto not_there; #endif if ( strEQ( name, "LOCK_NB" ) ) #ifdef LOCK_NB return LOCK_NB; #else goto not_there; #endif if ( strEQ( name, "LOCK_UN" ) ) #ifdef LOCK_UN return LOCK_UN; #else goto not_there; #endif break; case 'M': break; case 'N': break; case 'O': break; case 'P': break; case 'Q': break; case 'R': break; case 'S': if ( strEQ( name, "SEM_A" ) ) #ifdef SEM_A return SEM_A; #else goto not_there; #endif if ( strEQ( name, "SEM_R" ) ) #ifdef SEM_R return SEM_R; #else goto not_there; #endif if ( strEQ( name, "SEM_UNDO" ) ) #ifdef SEM_UNDO return SEM_UNDO; #else goto not_there; #endif if ( strEQ( name, "SETALL" ) ) #ifdef SETALL return SETALL; #else goto not_there; #endif if ( strEQ( name, "SETVAL" ) ) #ifdef SETVAL return SETVAL; #else goto not_there; #endif if ( strEQ( name, "SHM_LOCK" ) ) #ifdef SHM_LOCK return SHM_LOCK; #else goto not_there; #endif if ( strEQ( name, "SHM_R" ) ) #ifdef SHM_R return SHM_R; #else goto not_there; #endif if ( strEQ( name, "SHM_RDONLY" ) ) #ifdef SHM_RDONLY return SHM_RDONLY; #else goto not_there; #endif if ( strEQ( name, "SHM_RND" ) ) #ifdef SHM_RND return SHM_RND; #else goto not_there; #endif if ( strEQ( name, "SHM_SHARE_MMU" ) ) #ifdef SHM_SHARE_MMU return SHM_SHARE_MMU; #else goto not_there; #endif if ( strEQ( name, "SHM_UNLOCK" ) ) #ifdef SHM_UNLOCK return SHM_UNLOCK; #else goto not_there; #endif if ( strEQ( name, "SHM_W" ) ) #ifdef SHM_W return SHM_W; #else goto not_there; #endif break; case 'T': break; case 'U': break; case 'V': break; case 'W': break; case 'X': break; case 'Y': break; case 'Z': break; } errno = EINVAL; return 0; not_there: errno = ENOENT; return 0; } /* *INDENT-OFF* */ MODULE = IPC::ShareLite PACKAGE = IPC::ShareLite PROTOTYPES: DISABLE double constant( char *name, int arg) Share* new_share(key_t key, int segment_size, int flags) int write_share(Share *share, char *data, int length) char* read_share(Share *share) PREINIT: char* data; int length; CODE: length = read_share(share, &data); ST(0) = sv_newmortal(); if (length >= 0) { #ifdef sv_usepvn_flags sv_usepvn_flags((SV*)ST(0), data, length, SV_HAS_TRAILING_NUL); #else sv_usepvn((SV*)ST(0), data, length); #endif } else { sv_setsv(ST(0), &PL_sv_undef); } int destroy_share(Share *share, int rmid) int sharelite_lock(Share *share, int flags) int sharelite_unlock(Share *share) unsigned int sharelite_version(Share *share) int sharelite_num_segments(Share *share) IPC-ShareLite-0.17/inc/0000755000076500000240000000000011155603661013325 5ustar andystaffIPC-ShareLite-0.17/inc/Devel/0000755000076500000240000000000011155603661014364 5ustar andystaffIPC-ShareLite-0.17/inc/Devel/CheckLib.pm0000644000076500000240000001762311154610634016374 0ustar andystaff# $Id: CheckLib.pm,v 1.10 2007/10/30 15:12:17 drhyde Exp $ package Devel::CheckLib; use strict; use vars qw($VERSION @ISA @EXPORT); $VERSION = '0.3'; use Config; use File::Spec; use File::Temp; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(assert_lib check_lib_or_exit); # localising prevents the warningness leaking out of this module local $^W = 1; # use warnings is a 5.6-ism _findcc(); # bomb out early if there's no compiler =head1 NAME Devel::CheckLib - check that a library is available =head1 DESCRIPTION Devel::CheckLib is a perl module that checks whether a particular C library is available, and dies if it is not. =head1 SYNOPSIS # in a Makefile.PL or Build.PL use lib qw(inc); use Devel::CheckLib; check_lib_or_exit( lib => 'jpeg' ); check_lib_or_exit( lib => [ 'iconv', 'jpeg' ] ); # or prompt for path to library and then do this: check_lib_or_exit( lib => 'jpeg', libpath => $additional_path ); =head1 HOW IT WORKS You pass named parameters to a function describing how to build and link to the library. Currently the only parameter supported is 'lib', which can be a string or an arrayref of several libraries. In the future, expect us to add something for checking that header files are available as well. It works by trying to compile this: int main(void) { return 0; } and linking it to the specified libraries. If something pops out the end which looks executable, then we know that it worked. =head1 FUNCTIONS All of these take the same named parameters and are exported by default. To avoid exporting them, C. =head2 assert_lib Takes several named parameters. The value of C must be either a string with the name of a single library or a reference to an array of strings of library names. Depending on the compiler found, library names will be fed to the compiler either as C<-l> arguments or as C<.lib> file names. (E.g. C<-ljpeg> or C) Likewise, C must if provided either be a string or an array of strings representing additional paths to search for libraries. C must be a C-style space-seperated list of libraries (each preceded by '-l') and directories (preceded by '-L'). This will die with an error message if any of the libraries listed can not be found. B: dying in a Makefile.PL or Build.PL may provoke a 'FAIL' report from CPAN Testers' automated smoke testers. Use C instead. =head2 check_lib_or_exit This behaves exactly the same as C except that instead of dieing, it warns (with exactly the same error message) and exits. This is intended for use in Makefile.PL / Build.PL when you might want to prompt the user for various paths and things before checking that what they've told you is sane. If a library isn't found, it exits with an exit value of 0 to avoid causing a CPAN Testers 'FAIL' report. CPAN Testers should ignore this result -- which is what you want if an external library dependency is not available. =cut sub check_lib_or_exit { eval 'assert_lib(@_)'; if ( $@ ) { warn $@; exit; } } sub assert_lib { my %args = @_; my ( @libs, @libpaths ); @libs = ( ref( $args{lib} ) ? @{ $args{lib} } : $args{lib} ) if $args{lib}; @libpaths = ( ref( $args{libpath} ) ? @{ $args{libpath} } : $args{libpath} ) if $args{libpath}; # work-a-like for Makefile.PL's "LIBS" argument if ( defined( $args{LIBS} ) ) { foreach my $arg ( split( /\s+/, $args{LIBS} ) ) { die( "LIBS argument badly-formed: $arg\n" ) unless ( $arg =~ /^-l/i ); push @{ $arg =~ /^-l/ ? \@libs : \@libpaths }, substr( $arg, 2 ); } } my @cc = _findcc(); my ( $ch, $cfile ) = File::Temp::tempfile( 'assertlibXXXXXXXX', SUFFIX => '.c', UNLINK => 1 ); print $ch "int main(void) { return 0; }\n"; close( $ch ); my @missing; for my $lib ( @libs ) { my $exefile = File::Temp::mktemp( 'assertlibXXXXXXXX' ) . $Config{_exe}; my @sys_cmd; if ( $Config{cc} eq 'cl' ) { # Microsoft compiler require Win32; my @libpath = map { q{/libpath:} . Win32::GetShortPathName( $_ ) } @libpaths; @sys_cmd = ( @cc, $cfile, "${lib}.lib", "/Fe$exefile", "/link", @libpath ); } elsif ( $Config{cc} =~ /bcc32(\.exe)?/ ) { # Borland my @libpath = map { "-L$_" } @libpaths; @sys_cmd = ( @cc, "-o$exefile", "-l$lib", @libpath, $cfile ); } else { # Unix-ish # gcc, Sun, AIX (gcc, cc) my @libpath = map { "-L$_" } @libpaths; @sys_cmd = ( @cc, $cfile, "-o", "$exefile", "-l$lib", @libpath ); } warn "# @sys_cmd\n" if $args{debug}; my $rv = $args{debug} ? system( @sys_cmd ) : _quiet_system( @sys_cmd ); push @missing, $lib if $rv != 0 || !-x $exefile; _cleanup_exe( $exefile ); } unlink $cfile; my $miss_string = join( q{, }, map { qq{'$_'} } @missing ); die( "Can't build and link to $miss_string\n" ) if @missing; } sub _cleanup_exe { my ( $exefile ) = @_; my $ofile = $exefile; $ofile =~ s/$Config{_exe}$/$Config{_o}/; unlink $exefile if -f $exefile; unlink $ofile if -f $ofile; unlink "$exefile\.manifest" if -f "$exefile\.manifest"; return; } sub _findcc { my @paths = split( /$Config{path_sep}/, $ENV{PATH} ); my @cc = split( /\s+/, $Config{cc} ); return @cc if -x $cc[0]; foreach my $path ( @paths ) { my $compiler = File::Spec->catfile( $path, $cc[0] ) . $Config{_exe}; return ( $compiler, @cc[ 1 .. $#cc ] ) if -x $compiler; } die( "Couldn't find your C compiler\n" ); } # code substantially borrowed from IPC::Run3 sub _quiet_system { my ( @cmd ) = @_; # save handles local *STDOUT_SAVE; local *STDERR_SAVE; open STDOUT_SAVE, ">&STDOUT" or die "CheckLib: $! saving STDOUT"; open STDERR_SAVE, ">&STDERR" or die "CheckLib: $! saving STDERR"; # redirect to nowhere local *DEV_NULL; open DEV_NULL, ">" . File::Spec->devnull or die "CheckLib: $! opening handle to null device"; open STDOUT, ">&" . fileno DEV_NULL or die "CheckLib: $! redirecting STDOUT to null handle"; open STDERR, ">&" . fileno DEV_NULL or die "CheckLib: $! redirecting STDERR to null handle"; # run system command my $rv = system( @cmd ); # restore handles open STDOUT, ">&" . fileno STDOUT_SAVE or die "CheckLib: $! restoring STDOUT handle"; open STDERR, ">&" . fileno STDERR_SAVE or die "CheckLib: $! restoring STDERR handle"; return $rv; } =head1 PLATFORMS SUPPORTED You must have a C compiler installed. We check for C<$Config{cc}>, both literally as it is in Config.pm and also in the $PATH. It has been tested with varying degrees on rigourousness on: =over =item gcc (on Linux, *BSD, Solaris, Cygwin) =item Sun's compiler tools on Solaris =item IBM's tools on AIX =item Microsoft's tools on Windows =item MinGW on Windows (with Strawberry Perl) =item Borland's tools on Windows =back =head1 WARNINGS, BUGS and FEEDBACK This is a very early release intended primarily for feedback from people who have discussed it. The interface may change and it has not been adequately tested. Feedback is most welcome, including constructive criticism. Bug reports should be made using L or by email. When submitting a bug report, please include the output from running: perl -V perl -MDevel::CheckLib =head1 SEE ALSO L =head1 AUTHORS David Cantrell Edavid@cantrell.org.ukE David Golden Edagolden@cpan.orgE Thanks to the cpan-testers-discuss mailing list for prompting us to write it in the first place; to Chris Williams for help with Borland support. =head1 COPYRIGHT and LICENCE Copyright 2007 David Cantrell. Portions copyright 2007 David Golden. This module is free-as-in-speech software, and may be used, distributed, and modified under the same conditions as perl itself. =head1 CONSPIRACY This module is also free-as-in-mason software. =cut 1; IPC-ShareLite-0.17/inc/IO/0000755000076500000240000000000011155603661013634 5ustar andystaffIPC-ShareLite-0.17/inc/IO/CaptureOutput.pm0000444000076500000240000002176011154610647017023 0ustar andystaff# $Id: CaptureOutput.pm,v 1.3 2005/03/25 12:44:14 simonflack Exp $ package IO::CaptureOutput; use strict; use vars qw/$VERSION @ISA @EXPORT_OK %EXPORT_TAGS/; use Exporter; @ISA = 'Exporter'; @EXPORT_OK = qw/capture capture_exec qxx capture_exec_combined qxy/; %EXPORT_TAGS = ( all => \@EXPORT_OK ); $VERSION = '1.0801'; sub capture (&@) { ## no critic my ( $code, $output, $error, $output_file, $error_file ) = @_; for ( $output, $error ) { $_ = \do { my $s; $s = '' } unless ref $_; $$_ = '' if $_ != \undef && !defined( $$_ ); } # don't merge if both undef -- someone might still want to capture # them separately in temp files my $should_merge = defined $error && defined $output && $output == $error; my ( $capture_out, $capture_err ); if ( $output != \undef ) { $capture_out = IO::CaptureOutput::_proxy->new( 'STDOUT', $output, undef, $output_file ); } if ( $error != \undef ) { my $capture_err = IO::CaptureOutput::_proxy->new( 'STDERR', $error, ( $should_merge ? 'STDOUT' : undef ), $error_file ); } &$code(); } sub capture_exec { my @args = @_; my ( $output, $error ); capture sub { system _shell_quote( @args ) }, \$output, \$error; return wantarray ? ( $output, $error ) : $output; } *qxx = \&capture_exec; sub capture_exec_combined { my @args = @_; my $output; capture sub { system _shell_quote( @args ) }, \$output, \$output; return $output; } *qxy = \&capture_exec_combined; # extra quoting required on Win32 systems *_shell_quote = ( $^O =~ /MSWin32/ ) ? \&_shell_quote_win32 : sub { @_ }; sub _shell_quote_win32 { my @args; for ( @_ ) { if ( /[ \"]/ ) { # TODO: check if ^ requires escaping ( my $escaped = $_ ) =~ s/([\"])/\\$1/g; push @args, '"' . $escaped . '"'; next; } push @args, $_; } return @args; } # Captures everything printed to a filehandle for the lifetime of the object # and then transfers it to a scalar reference package IO::CaptureOutput::_proxy; use File::Temp 'tempfile'; use File::Basename qw/basename/; use Symbol qw/gensym qualify qualify_to_ref/; use Carp; sub _is_wperl { $^O eq 'MSWin32' && basename( $^X ) eq 'wperl.exe' } sub new { my $class = shift; my ( $fh, $capture, $merge_fh, $capture_file ) = @_; $fh = qualify( $fh ); # e.g. main::STDOUT my $fhref = qualify_to_ref( $fh ); # e.g. \*STDOUT # Duplicate the filehandle my $saved; { no strict 'refs'; ## no critic - needed for 5.005 if ( defined fileno( $fh ) && !_is_wperl() ) { $saved = gensym; open $saved, ">&$fh" or croak "Can't redirect <$fh> - $!"; } } # Create replacement filehandle if not merging my ( $newio, $newio_file ); if ( !$merge_fh ) { $newio = gensym; if ( $capture_file ) { $newio_file = $capture_file; } else { ( undef, $newio_file ) = tempfile; } open $newio, "+>$newio_file" or croak "Can't write temp file for $fh - $!"; } else { $newio = qualify( $merge_fh ); } # Redirect (or merge) { no strict 'refs'; ## no critic -- needed for 5.005 open $fhref, ">&" . fileno( $newio ) or croak "Can't redirect $fh - $!"; } bless [ $$, $fh, $saved, $capture, $newio, $newio_file, $capture_file ], $class; } sub DESTROY { my $self = shift; my ( $pid, $fh, $saved ) = @{$self}[ 0 .. 2 ]; return unless $pid eq $$; # only cleanup in the process that is capturing # restore the original filehandle my $fh_ref = Symbol::qualify_to_ref( $fh ); select( ( select( $fh_ref ), $| = 1 )[0] ); if ( defined $saved ) { open $fh_ref, ">&" . fileno( $saved ) or croak "Can't restore $fh - $!"; } else { close $fh_ref; } # transfer captured data to the scalar reference if we didn't merge my ( $capture, $newio, $newio_file ) = @{$self}[ 3 .. 5 ]; if ( $newio_file ) { # some versions of perl complain about reading from fd 1 or 2 # which could happen if STDOUT and STDERR were closed when $newio # was opened, so we just squelch warnings here and continue local $^W; seek $newio, 0, 0; $$capture = do { local $/; <$newio> }; close $newio; } # Cleanup return unless defined $newio_file && -e $newio_file; return if $self->[6]; # the "temp" file was explicitly named unlink $newio_file or carp "Couldn't remove temp file '$newio_file' - $!"; } 1; __END__ =pod =begin wikidoc = NAME IO::CaptureOutput - capture STDOUT and STDERR from Perl code, subprocesses or XS = VERSION This documentation describes version %%VERSION%%. = SYNOPSIS use IO::CaptureOutput qw(capture capture_exec); my ($stdout, $stderr); sub noisy { warn "this sub prints to stdout and stderr!"; print "arguments: @_"; } capture { noisy(@args) } \$stdout, \$stderr; ($stdout, $stderr) = capture_exec( 'perl', '-e', 'print "Hello"; print STDERR "World!"'); = DESCRIPTION This module provides routines for capturing STDOUT and STDERR from perl subroutines, forked system calls (e.g. {system()}, {fork()}) and from XS or C modules. = FUNCTIONS The following functions will be exported on demand. == capture() capture \&subroutine, \$stdout, \$stderr; Captures everything printed to {STDOUT} and {STDERR} for the duration of {&subroutine}. {$stdout} and {$stderr} are optional scalars that will contain {STDOUT} and {STDERR} respectively. {capture()} uses a code prototype so the first argument can be specified directly within brackets if desired. # shorthand with prototype capture { print __PACKAGE__ } \$stdout, \$stderr; Returns the return value(s) of {&subroutine}. The sub is called in the same context as {capture()} was called e.g.: @rv = capture { wantarray } ; # returns true $rv = capture { wantarray } ; # returns defined, but not true capture { wantarray }; # void, returns undef {capture()} is able to capture output from subprocesses and C code, which traditional {tie()} methods of output capture are unable to do. *Note:* {capture()} will only capture output that has been written or flushed to the filehandle. If the two scalar references refer to the same scalar, then {STDERR} will be merged to {STDOUT} before capturing and the scalar will hold the combined output of both. capture \&subroutine, \$combined, \$combined; Normally, {capture()} uses anonymous, temporary files for capturing output. If desired, specific file names may be provided instead as additional options. capture \&subroutine, \$stdout, \$stderr, $out_file, $err_file; Files provided will be clobbered, overwriting any previous data, but will persist after the call to {capture()} for inspection or other manipulation. By default, when no references are provided to hold STDOUT or STDERR, output is captured and silently discarded. # Capture STDOUT, discard STDERR capture \&subroutine, \$stdout; # Discard STDOUT, capture STDERR capture \&subroutine, undef, \$stderr; If either STDOUT or STDERR should be passed through to the terminal instead of captured, provide a reference to undef -- {\undef} -- instead of a capture variable. # Capture STDOUT, display STDERR capture \&subroutine, \$stdout, \undef; # Display STDOUT, capture STDERR capture \&subroutine, \undef, \$stderr; == capture_exec() ($stdout, $stderr) = capture_exec(@args); Captures and returns the output from {system(@args)}. In scalar context, {capture_exec()} will return what was printed to {STDOUT}. In list context, it returns what was printed to {STDOUT} and {STDERR} $stdout = capture_exec('perl', '-e', 'print "hello world"'); ($stdout, $stderr) = capture_exec('perl', '-e', 'warn "Test"'); {capture_exec} passes its arguments to {system()} and on MSWin32 will protect arguments with shell quotes if necessary. This makes it a handy and slightly more portable alternative to backticks, piped {open()} and {IPC::Open3}. You can check the exit status of the {system()} call with the {$?} variable. See [perlvar] for more information. == capture_exec_combined() $combined = capture_exec_combined( 'perl', '-e', 'print "hello\n"', 'warn "Test\n" ); This is just like {capture_exec()}, except that it merges {STDERR} with {STDOUT} before capturing output and returns a single scalar. *Note:* there is no guarantee that text printed to {STDOUT} and {STDERR} in the subprocess will be appear in order. The actual order will depend on how IO buffering is handled in the subprocess. == qxx() This is an alias for {capture_exec()}. == qxy() This is an alias for {capture_exec_combined()}. = SEE ALSO * [IPC::Open3] * [IO::Capture] * [IO::Utils] = AUTHORS * Simon Flack (original author) * David Golden (co-maintainer since version 1.04) = COPYRIGHT AND LICENSE Portions copyright 2004, 2005 Simon Flack. Portions copyright 2007 David Golden. All rights reserved. You may distribute under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. =end wikidoc =cut IPC-ShareLite-0.17/lib/0000755000076500000240000000000011155603661013322 5ustar andystaffIPC-ShareLite-0.17/lib/IPC/0000755000076500000240000000000011155603661013735 5ustar andystaffIPC-ShareLite-0.17/lib/IPC/ShareLite.pm0000644000076500000240000003403411155603622016154 0ustar andystaffpackage IPC::ShareLite; use strict; use warnings; use Carp; =head1 NAME IPC::ShareLite - Lightweight interface to shared memory =head1 VERSION This document describes IPC::ShareLite version 0.17 =cut use vars qw( $VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $AUTOLOAD ); use subs qw( IPC_CREAT IPC_EXCL IPC_RMID IPC_STAT IPC_PRIVATE GETVAL SETVAL GETALL SEM_UNDO LOCK_EX LOCK_SH LOCK_UN LOCK_NB ); require Exporter; require DynaLoader; require AutoLoader; @ISA = qw( Exporter DynaLoader ); @EXPORT = qw( ); @EXPORT_OK = qw( IPC_CREAT IPC_EXCL IPC_RMID IPC_STATE IPC_PRIVATE GETVAL SETVAL GETALL SEM_UNDO LOCK_EX LOCK_SH LOCK_UN LOCK_NB ); %EXPORT_TAGS = ( all => [ qw( IPC_CREAT IPC_EXCL IPC_RMID IPC_PRIVATE LOCK_EX LOCK_SH LOCK_UN LOCK_NB ) ], lock => [qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB )], flock => [qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB )], ); Exporter::export_ok_tags( 'all', 'lock', 'flock' ); $VERSION = '0.17'; =head1 SYNOPSIS use IPC::ShareLite; my $share = IPC::ShareLite->new( -key => 1971, -create => 'yes', -destroy => 'no' ) or die $!; $share->store( "This is stored in shared memory" ); my $str = $share->fetch; =head1 DESCRIPTION IPC::ShareLite provides a simple interface to shared memory, allowing data to be efficiently communicated between processes. Your operating system must support SysV IPC (shared memory and semaphores) in order to use this module. IPC::ShareLite provides an abstraction of the shared memory and semaphore facilities of SysV IPC, allowing the storage of arbitrarily large data; the module automatically acquires and removes shared memory segments as needed. Storage and retrieval of data is atomic, and locking functions are provided for higher-level synchronization. In many respects, this module is similar to IPC::Shareable. However, IPC::ShareLite does not provide a tied interface, does not (automatically) allow the storage of variables, and is written in C for additional speed. Construct an IPC::ShareLite object by calling its constructor: my $share = IPC::ShareLite->new( -key => 1971, -create => 'yes', -destroy => 'no' ) or die $!; Once an instance has been created, data can be written to shared memory by calling the store() method: $share->store("This is going in shared memory"); Retrieve the data by calling the fetch() method: my $str = $share->fetch(); The store() and fetch() methods are atomic; any processes attempting to read or write to the memory are blocked until these calls finish. However, in certain situations, you'll want to perform multiple operations atomically. Advisory locking methods are available for this purpose. An exclusive lock is obtained by calling the lock() method: $share->lock(); Happily, the lock() method also accepts all of the flags recognized by the flock() system call. So, for example, you can obtain a shared lock like this: $share->lock( LOCK_SH ); Or, you can make either type of lock non-blocking: $share->lock( LOCK_EX|LOCK_NB ); Release the lock by calling the unlock() method: $share->unlock; =head1 METHODS =head2 C<< new($key, $create, $destroy, $exclusive, $mode, $flags, $size) >> This is the constructor for IPC::ShareLite. It accepts both the positional and named parameter calling styles. C<$key> is an integer value used to associate data between processes. All processes wishing to communicate should use the same $key value. $key may also be specified as a four character string, in which case it will be converted to an integer value automatically. If $key is undefined, the shared memory will not be accessible from other processes. C<$create> specifies whether the shared memory segment should be created if it does not already exist. Acceptable values are 1, 'yes', 0, or 'no'. C<$destroy> indicates whether the shared memory segments and semaphores should be removed from the system once the object is destroyed. Acceptable values are 1, 'yes', 0, or 'no'. If C<$exclusive> is true, instantiation will fail if the shared memory segment already exists. Acceptable values are 1, 'yes', 0, or 'no'. C<$mode> specifies the permissions for the shared memory and semaphores. The default value is 0666. C<$flags> specifies the exact shared memory and semaphore flags to use. The constants IPC_CREAT, IPC_EXCL, and IPC_PRIVATE are available for import. C<$size> specifies the shared memory segment size, in bytes. The default size is 65,536 bytes, which is fairly portable. Linux, as an example, supports segment sizes of 4 megabytes. The constructor croaks on error. =cut sub new { my $class = shift; my $self = bless {}, ref $class || $class; my $args = $class->_rearrange_args( [ qw( key create destroy exclusive mode flags size glue ) ], \@_ ); $self->_initialize( $args ); return $self; } sub _8bit_clean { my ( $self, $str ) = @_; croak "$str is not 8-bit clean" if grep { $_ > 255 } map ord, split //, $str; } sub _initialize { my $self = shift; my $args = shift; for ( qw( create exclusive destroy ) ) { $args->{$_} = 0 if defined $args->{$_} and lc $args->{$_} eq 'no'; } # Allow glue as a synonym for key $self->{key} = $args->{key} || $args->{glue} || IPC_PRIVATE; # Allow a four character string as the key unless ( $self->{key} =~ /^\d+$/ ) { croak "Key must be a number or four character string" if length $self->{key} > 4; $self->_8bit_clean( $self->{key} ); $self->{key} = unpack( 'i', pack( 'A4', $self->{key} ) ); } $self->{create} = ( $args->{create} ? IPC_CREAT : 0 ); $self->{exclusive} = ( $args->{exclusive} ? IPC_EXCL | IPC_CREAT : 0 ); $self->{destroy} = ( $args->{destroy} ? 1 : 0 ); $self->{flags} = $args->{flags} || 0; $self->{mode} = $args->{mode} || 0666 unless $args->{flags}; $self->{size} = $args->{size} || 0; $self->{flags} = $self->{flags} | $self->{exclusive} | $self->{create} | $self->{mode}; $self->{share} = new_share( $self->{key}, $self->{size}, $self->{flags} ) or croak "Failed to create share"; return 1; } sub _rearrange_args { my ( $self, $names, $params ) = @_; my ( %hash, %names ); return \%hash unless ( @$params ); unless ( $params->[0] =~ /^-/ ) { croak "unexpected number of parameters" unless ( @$names == @$params ); $hash{@$names} = @$params; return \%hash; } %names = map { $_ => 1 } @$names; while ( @$params ) { my $param = lc substr( shift @$params, 1 ); exists $names{$param} or croak "unexpected parameter '-$param'"; $hash{$param} = shift @$params; } return \%hash; } =head2 C<< store( $scalar ) >> This method stores C<$scalar> into shared memory. C<$scalar> may be arbitrarily long. Shared memory segments are acquired and released automatically as the data length changes. The only limits on the amount of data are the system-wide limits on shared memory pages (SHMALL) and segments (SHMMNI) as compiled into the kernel. The method raises an exception on error. Note that unlike L, this module does not automatically allow references to be stored. Serializing all data is expensive, and is not always necessary. If you need to store a reference, you should employ the L module yourself. For example: use Storable qw( freeze thaw ); ... $hash = { red => 1, white => 1, blue => 1 }; $share->store( freeze( $hash ) ); ... $hash = thaw( $share->fetch ); =cut sub store { my $self = shift; if ( write_share( $self->{share}, $_[0], length $_[0] ) < 0 ) { croak "IPC::ShareLite store() error: $!"; } return 1; } =head2 C<< fetch >> This method returns the data that was previously stored in shared memory. The empty string is returned if no data was previously stored. The method raises an exception on error. =cut sub fetch { my $self = shift; my $str = read_share( $self->{share} ); defined $str or croak "IPC::ShareLite fetch() error: $!"; return $str; } =head2 C<< lock( $type ) >> Obtains a lock on the shared memory. $type specifies the type of lock to acquire. If $type is not specified, an exclusive read/write lock is obtained. Acceptable values for $type are the same as for the flock() system call. The method returns true on success, and undef on error. For non-blocking calls (see below), the method returns 0 if it would have blocked. Obtain an exclusive lock like this: $share->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 lock this this: $share->lock( LOCK_SH ); Multiple processes can hold a shared 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: $share->lock( LOCK_EX|LOCK_NB ); $share->lock( LOCK_SH|LOCK_NB ); A non-blocking lock request will return 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 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 LOCK_EX, LOCK_SH, LOCK_NB, and LOCK_UN are available for import: use IPC::ShareLite qw( :lock ); Or, just use the flock constants available in the Fcntl module. =cut sub lock { my $self = shift; my $response = sharelite_lock( $self->{share}, shift() ); return undef if ( $response == -1 ); return 0 if ( $response == 1 ); # operation failed due to LOCK_NB return 1; } =head2 C<< unlock >> Releases any locks. This is actually equivalent to: $share->lock( LOCK_UN ); The method returns true on success and undef on error. =cut sub unlock { my $self = shift; return undef if ( sharelite_unlock( $self->{share} ) < 0 ); return 1; } # DEPRECATED -- Use lock() and unlock() instead. sub shlock { shift->lock( @_ ) } sub shunlock { shift->unlock( @_ ) } =head2 C<< version >> Each share has a version number that incrementents monotonically for each write to the share. When the share is initally created its version number will be 1. my $num_writes = $share->version; =cut sub version { sharelite_version( shift->{share} ) } =head2 C<< key >> Get a share's key. my $key = $share->key; =cut sub key { shift->{key} } =head2 C<< create >> Get a share's create flag. =cut sub create { shift->{create} } =head2 C<< exclusive >> Get a share's exclusive flag. =cut sub exclusive { shift->{exclusive} } =head2 C<< flags >> Get a share's flag. =cut sub flags { shift->{flags} } =head2 C<< mode >> Get a share's mode. =cut sub mode { shift->{mode} } =head2 C<< size >> Get a share's segment size. =cut sub size { shift->{size} } =head2 C<< num_segments >> Get the number of segments in a share. The memory usage of a share can be approximated like this: my $usage = $share->size * $share->num_segments; C<$usage> will be the memory usage rounded up to the next segment boundary. =cut sub num_segments { my $self = shift; my $count = sharelite_num_segments( $self->{share} ); return undef if $count < 0; return $count; } =head2 C<< destroy >> Get or set the share's destroy flag. =cut sub destroy { my $self = shift; $self->{destroy} = shift if @_; return $self->{destroy}; } sub DESTROY { my $self = shift; destroy_share( $self->{share}, $self->{destroy} ) if $self->{share}; } sub AUTOLOAD { # This AUTOLOAD is used to 'autoload' constants from the constant() # XS function. If a constant is not found then control is passed # to the AUTOLOAD in AutoLoader. my $constname; ( $constname = $AUTOLOAD ) =~ s/.*:://; my $val = constant( $constname, @_ ? $_[0] : 0 ); if ( $! != 0 ) { if ( $! =~ /Invalid/ ) { $AutoLoader::AUTOLOAD = $AUTOLOAD; goto &AutoLoader::AUTOLOAD; } else { croak "Your vendor has not defined ShareLite macro $constname"; } } eval "sub $AUTOLOAD { $val }"; goto &$AUTOLOAD; } bootstrap IPC::ShareLite $VERSION; 1; __END__ =head1 PERFORMANCE For a rough idea of the performance you can expect, here are some benchmarks. The tests were performed using the Benchmark module on a Cyrix PR166+ running RedHat Linux 5.2 with the 2.0.36 kernel, perl 5.005_02 using perl's malloc, and the default shared memory segment size. Each test was run 5000 times. DATA SIZE (bytes) TIME (seconds) Op/Sec store 16384 2 2500 fetch 16384 2 2500 store 32768 3 1666 fetch 32768 3 1666 store 65536 6 833 fetch 65536 5 1000 store 131072 12 416 fetch 131072 12 416 store 262144 28 178 fetch 262144 27 185 store 524288 63 79 fetch 524288 61 81 Most of the time appears to be due to memory copying. Suggestions for speed improvements are welcome. =head1 PORTABILITY The module should compile on any system with SysV IPC and an ANSI C compiler, and should compile cleanly with the -pedantic and -Wall flags. The module has been tested under Solaris, FreeBSD, and Linux. Testing on other platforms is needed. If you encounter a compilation error due to the definition of the semun union, edit the top of sharestuff.c and undefine the semun definition. And then please tell me about it. I've heard rumors that a SysV IPC interface has been constructed for Win32 systems. Support for it may be added to this module. IPC::ShareLite does not understand the shared memory data format used by IPC::Shareable. =head1 AUTHOR Copyright 1998-2002, Maurice Aubrey . All rights reserved. This release by Andy Armstrong . This module is free software; you may redistribute it and/or modify it under the same terms as Perl itself. =head1 CREDITS Special thanks to Benjamin Sugars for developing the IPC::Shareable module. See the Changes file for other contributors. =head1 SEE ALSO L, ipc(2), shmget(2), semget(2), perl. =cut IPC-ShareLite-0.17/sharestuff.c0000644000076500000240000003711011155305576015100 0ustar andystaff#include #include #include #include #include #include #include #include #include #include "sharestuff.h" #ifndef errno extern int errno; #endif #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* Use Perl's memory management */ #ifndef Newxz #define Newxz(pointer, number, type) \ Newz(1, pointer, number, type) #endif #ifdef HAS_UNION_SEMUN #define SEMUN union semun #else union my_semun { int val; struct semid_ds *buf; unsigned short *array; }; #define SEMUN union my_semun #endif /* --- DEFINE MACROS FOR SEMAPHORE OPERATIONS --- */ #define GET_EX_LOCK(A) semop((A), &ex_lock[0], 3) #define GET_EX_LOCK_NB(A) semop((A), &ex_lock_nb[0], 3) #define RM_EX_LOCK(A) semop((A), &ex_unlock[0], 1) #define GET_SH_LOCK(A) semop((A), &sh_lock[0], 2) #define GET_SH_LOCK_NB(A) semop((A), &sh_lock_nb[0], 2) #define RM_SH_LOCK(A) semop((A), &sh_unlock[0], 1) /* --- DEFINE STRUCTURES FOR MANIPULATING SEMAPHORES --- */ static struct sembuf ex_lock[3] = { {1, 0, 0}, /* wait for readers to finish */ {2, 0, 0}, /* wait for writers to finish */ {2, 1, SEM_UNDO} /* assert write lock */ }; static struct sembuf ex_lock_nb[3] = { {1, 0, IPC_NOWAIT}, /* wait for readers to finish */ {2, 0, IPC_NOWAIT}, /* wait for writers to finish */ {2, 1, ( SEM_UNDO | IPC_NOWAIT )} /* assert write lock */ }; static struct sembuf ex_unlock[1] = { {2, -1, ( SEM_UNDO | IPC_NOWAIT )} /* remove write lock */ }; static struct sembuf sh_lock[2] = { {2, 0, 0}, /* wait for writers to finish */ {1, 1, SEM_UNDO} /* assert shared read lock */ }; static struct sembuf sh_lock_nb[2] = { {2, 0, IPC_NOWAIT}, /* wait for writers to finish */ {1, 1, ( SEM_UNDO | IPC_NOWAIT )} /* assert shared read lock */ }; static struct sembuf sh_unlock[1] = { {1, -1, ( SEM_UNDO | IPC_NOWAIT )} /* remove shared read lock */ }; FILE *log_fh = NULL; #define LOG_ARGS const char *file, int line, const char *fmt, ... #define LOG0(fmt) sharelite_log(__FILE__, __LINE__, fmt) #define LOG1(fmt, a1) sharelite_log(__FILE__, __LINE__, fmt, a1) #define LOG2(fmt, a1, a2) sharelite_log(__FILE__, __LINE__, fmt, a1, a2) #define LOG3(fmt, a1, a2, a3) sharelite_log(__FILE__, __LINE__, fmt, a1, a2, a3) static void sharelite_log_active( LOG_ARGS ); static void sharelite_log_nop( LOG_ARGS ); static void ( *sharelite_log ) ( LOG_ARGS ) = sharelite_log_active; static void sharelite_log_nop( LOG_ARGS ) { } static void sharelite_log_active( LOG_ARGS ) { if ( NULL == log_fh ) { const char *log_file = getenv( "IPC_SHARELITE_LOG" ); if ( NULL == log_file || ( log_fh = fopen( log_file, "a" ), NULL == log_fh ) ) { sharelite_log = sharelite_log_nop; return; } } { struct timeval now; char timebuf[40]; va_list ap; gettimeofday( &now, NULL ); strftime( timebuf, sizeof( timebuf ), "%Y/%m/%d %H:%M:%S", gmtime( &now.tv_sec ) ); fprintf( log_fh, "%s.%06lu %s, %d : ", timebuf, ( unsigned long ) now.tv_usec, file, line ); va_start( ap, fmt ); vfprintf( log_fh, fmt, ap ); va_end( ap ); fprintf( log_fh, "\n" ); fflush( log_fh ); } } /* USER INITIATED LOCK */ /* returns 0 on success -- requested operation performed * * returns -1 on error * * returns 1 if LOCK_NB specified and operation would block */ int sharelite_lock( Share * share, int flags ) { /* try to obtain exclusive lock by default */ if ( !flags ) { flags = LOCK_EX; } /* Check for invalid combination of flags. Invalid combinations * * are attempts to obtain *both* an exclusive and shared lock or * * to both obtain and release a lock at the same time */ if ( ( ( flags & LOCK_EX ) && ( flags & LOCK_SH ) ) || ( ( flags & LOCK_UN ) && ( ( flags & LOCK_EX ) || ( flags & LOCK_SH ) ) ) ) { return -1; } if ( flags & LOCK_EX ) { /*** WANTS EXCLUSIVE LOCK ***/ /* If they already have an exclusive lock, just return */ if ( share->lock & LOCK_EX ) { return 0; } /* If they currently have a shared lock, remove it */ if ( share->lock & LOCK_SH ) { if ( RM_SH_LOCK( share->semid ) < 0 ) { return -1; } share->lock = 0; } if ( flags & LOCK_NB ) { /* non-blocking request */ if ( GET_EX_LOCK_NB( share->semid ) < 0 ) { if ( errno == EAGAIN ) { /* would we have blocked? */ return 1; } return -1; } } else { /* blocking request */ if ( GET_EX_LOCK( share->semid ) < 0 ) { return -1; } } share->lock = LOCK_EX; return 0; } else if ( flags & LOCK_SH ) { /*** WANTS SHARED LOCK ***/ /* If they already have a shared lock, just return */ if ( share->lock & LOCK_SH ) { return 0; } /* If they currently have an exclusive lock, remove it */ if ( share->lock & LOCK_EX ) { if ( RM_EX_LOCK( share->semid ) < 0 ) { return -1; } share->lock = 0; } if ( flags & LOCK_NB ) { /* non-blocking request */ if ( GET_SH_LOCK_NB( share->semid ) < 0 ) { if ( errno == EAGAIN ) { /* would we have blocked? */ return 1; } return -1; } } else { /* blocking request */ if ( GET_SH_LOCK( share->semid ) < 0 ) { return -1; } } share->lock = LOCK_SH; return 0; } else if ( flags & LOCK_UN ) { /*** WANTS TO RELEASE LOCK ***/ if ( share->lock & LOCK_EX ) { if ( RM_EX_LOCK( share->semid ) < 0 ) { return -1; } } else if ( share->lock & LOCK_SH ) { if ( RM_SH_LOCK( share->semid ) < 0 ) { return -1; } } } return 0; } int sharelite_unlock( Share * share ) { if ( share->lock & LOCK_EX ) { if ( RM_EX_LOCK( share->semid ) < 0 ) { return -1; } } else if ( share->lock & LOCK_SH ) { if ( RM_SH_LOCK( share->semid ) < 0 ) { return -1; } } share->lock = 0; return 0; } Node * _add_segment( Share * share ) { Node *node; int flags; Newxz( node, 1, Node ); node->next = NULL; /* Does another shared memory segment already exist? */ if ( share->tail->shmaddr->next_shmid >= 0 ) { node->shmid = share->tail->shmaddr->next_shmid; if ( ( node->shmaddr = ( Header * ) shmat( node->shmid, ( char * ) 0, 0 ) ) == ( Header * ) - 1 ) { return NULL; } share->tail->next = node; share->tail = node; return node; } flags = share->flags | IPC_CREAT | IPC_EXCL; /* We need to create a new segment */ while ( 1 ) { node->shmid = shmget( share->next_key++, share->segment_size, flags ); if ( node->shmid >= 0 ) { break; } #ifdef EIDRM if ( errno == EEXIST || errno == EIDRM ) { continue; } #else if ( errno == EEXIST ) { continue; } #endif return NULL; } share->tail->shmaddr->next_shmid = node->shmid; share->tail->next = node; share->tail = node; if ( ( node->shmaddr = ( Header * ) shmat( node->shmid, ( char * ) 0, 0 ) ) == ( Header * ) - 1 ) { return NULL; } node->shmaddr->next_shmid = -1; node->shmaddr->length = 0; return node; } int _detach_segments( Node * node ) { Node *next_node; while ( node != NULL ) { next_node = node->next; if ( shmdt( ( char * ) node->shmaddr ) < 0 ) { return -1; } Safefree( node ); node = next_node; } return 0; } int _remove_segments( int shmid ) { int next_shmid; Header *shmaddr; while ( shmid >= 0 ) { if ( ( shmaddr = ( Header * ) shmat( shmid, ( char * ) 0, 0 ) ) == ( Header * ) - 1 ) { return -1; } next_shmid = shmaddr->next_shmid; if ( shmdt( ( char * ) shmaddr ) < 0 ) { return -1; } if ( shmctl( shmid, IPC_RMID, ( struct shmid_ds * ) 0 ) < 0 ) { return -1; } shmid = next_shmid; } return 0; } int _invalidate_segments( Share * share ) { if ( _detach_segments( share->head->next ) < 0 ) { return -1; } share->head->next = NULL; share->tail = share->head; share->shm_state = share->head->shmaddr->shm_state; return 0; } int write_share( Share * share, char *data, int length ) { char *shmaddr; int segments; int left; int chunk_size; Node *node; int shmid; if ( data == NULL ) { return -1; } if ( !( share->lock & LOCK_EX ) ) { if ( share->lock & LOCK_SH ) { if ( RM_SH_LOCK( share->semid ) < 0 ) { return -1; } } if ( GET_EX_LOCK( share->semid ) < 0 ) { return -1; } } if ( share->shm_state != share->head->shmaddr->shm_state ) { if ( _invalidate_segments( share ) < 0 ) { return -1; } } /* set the data length to zero. if we are interrupted or encounter * * an error during the write, this guarantees that we won't * * receive corrupt data in future reads. */ share->head->shmaddr->length = 0; /* compute number of segments necessary to hold data */ segments = ( length / share->data_size ) + ( length % share->data_size ? 1 : 0 ); node = share->head; left = length; while ( segments-- ) { if ( node == NULL ) { if ( ( node = _add_segment( share ) ) == NULL ) { return -1; } } chunk_size = ( left > share->data_size ? share->data_size : left ); shmaddr = ( char * ) node->shmaddr + sizeof( Header ); memcpy( shmaddr, data, chunk_size ); left -= chunk_size; data += chunk_size; if ( segments ) { node = node->next; } } /* set new length in header of first segment */ share->head->shmaddr->length = length; /* garbage collection -- remove unused segments */ if ( node->shmaddr->next_shmid >= 0 ) { shmid = node->shmaddr->next_shmid; if ( _detach_segments( node->next ) < 0 ) { return -1; } if ( _remove_segments( shmid ) < 0 ) { return -1; } node->shmaddr->next_shmid = -1; node->next = NULL; share->tail = node; share->head->shmaddr->shm_state++; } ++share->head->shmaddr->version; if ( !( share->lock & LOCK_EX ) ) { if ( RM_EX_LOCK( share->semid ) < 0 ) { return -1; } if ( share->lock & LOCK_SH ) { if ( GET_SH_LOCK( share->semid ) < 0 ) { return -1; } } } return 0; } int read_share( Share * share, char **data ) { char *shmaddr; char *pos; Node *node; int length; int left; int chunk_size; if ( !share->lock ) { if ( GET_SH_LOCK( share->semid ) < 0 ) { return -1; } } if ( share->shm_state != share->head->shmaddr->shm_state ) { if ( _invalidate_segments( share ) < 0 ) { return -1; } } node = share->head; left = length = node->shmaddr->length; /* Allocate extra byte for a null at the end */ Newxz( *data, length + 1, char ); pos = *data; pos[length] = '\0'; while ( left ) { if ( node == NULL ) { if ( ( node = _add_segment( share ) ) == NULL ) { goto fail; } } chunk_size = ( left > share->data_size ? share->data_size : left ); shmaddr = ( char * ) node->shmaddr + sizeof( Header ); memcpy( pos, shmaddr, chunk_size ); pos += chunk_size; left -= chunk_size; node = node->next; } if ( !share->lock ) { if ( RM_SH_LOCK( share->semid ) < 0 ) { goto fail; } } return length; fail: Safefree( *data ); return -1; } Share * new_share( key_t key, int segment_size, int flags ) { Share *share; Node *node; int semid; struct shmid_ds shmctl_arg; SEMUN semun_arg; again: if ( ( semid = semget( key, 3, flags ) ) < 0 ) { LOG1( "semget failed (%d)", errno ); return NULL; } /* It's possible for another process to obtain the semaphore, lock it, * * and remove it from the system before we have a chance to lock it. * * In this case (EINVAL) we just try to create it again. */ if ( GET_EX_LOCK( semid ) < 0 ) { if ( errno == EINVAL ) { goto again; } LOG1( "GET_EX_LOCK failed (%d)", errno ); return NULL; } /* XXX IS THIS THE RIGHT THING TO DO? */ if ( segment_size <= sizeof( Header ) ) { segment_size = SHM_SEGMENT_SIZE; } Newxz( node, 1, Node ); if ( ( node->shmid = shmget( key, segment_size, flags ) ) < 0 ) { LOG1( "shmget failed (%d)", errno ); return NULL; } if ( ( node->shmaddr = ( Header * ) shmat( node->shmid, ( char * ) 0, 0 ) ) == ( Header * ) - 1 ) { LOG1( "shmat failed (%d)", errno ); return NULL; } node->next = NULL; Newxz( share, 1, Share ); share->key = key; share->next_key = key + 1; share->flags = flags; share->semid = semid; share->lock = 0; share->head = node; share->tail = node; /* is this a newly created segment? if so, initialize it */ if ( ( semun_arg.val = semctl( share->semid, 0, GETVAL, semun_arg ) ) < 0 ) { LOG1( "shmctl failed (%d)", errno ); return NULL; } if ( semun_arg.val == 0 ) { semun_arg.val = 1; if ( semctl( share->semid, 0, SETVAL, semun_arg ) < 0 ) { LOG1( "shmctl failed (%d)", errno ); return NULL; } share->head->shmaddr->length = 0; share->head->shmaddr->next_shmid = -1; share->head->shmaddr->shm_state = 1; share->head->shmaddr->version = 1; } share->shm_state = share->head->shmaddr->shm_state; share->version = share->head->shmaddr->version; /* determine the true length of the segment. this may disagree * * with what the user requested, since shmget() calls will * * succeed if the requested size <= the existing size */ if ( shmctl( share->head->shmid, IPC_STAT, &shmctl_arg ) < 0 ) { LOG1( "shmctl failed (%d)", errno ); return NULL; } share->segment_size = shmctl_arg.shm_segsz; share->data_size = share->segment_size - sizeof( Header ); if ( RM_EX_LOCK( semid ) < 0 ) { LOG1( "RM_EX_LOCK failed (%d)", errno ); return NULL; } return share; } unsigned int sharelite_version( Share * share ) { return share->head->shmaddr->version; } int destroy_share( Share * share, int rmid ) { int semid; SEMUN semctl_arg; if ( !( share->lock & LOCK_EX ) ) { if ( share->lock & LOCK_SH ) { if ( RM_SH_LOCK( share->semid ) < 0 ) { return -1; } } if ( GET_EX_LOCK( share->semid ) < 0 ) { return -1; } } semid = share->head->shmid; if ( _detach_segments( share->head ) < 0 ) { return -1; } if ( rmid ) { if ( _remove_segments( semid ) < 0 ) { return -1; } semctl_arg.val = 0; if ( semctl( share->semid, 0, IPC_RMID, semctl_arg ) < 0 ) { return -1; } } else { if ( RM_EX_LOCK( share->semid ) < 0 ) { return -1; } } Safefree( share ); return 0; } int sharelite_num_segments( Share * share ) { int count = 0; int shmid; Header *shmaddr; shmid = share->head->shmid; while ( shmid >= 0 ) { count++; if ( ( shmaddr = ( Header * ) shmat( shmid, ( char * ) 0, 0 ) ) == ( Header * ) - 1 ) { return -1; } shmid = shmaddr->next_shmid; if ( shmdt( ( char * ) shmaddr ) < 0 ) { return -1; } } return count; } void _dump_list( Share * share ) { Node *node; node = share->head; while ( node != NULL ) { printf( "shmid: %i\n", node->shmid ); node = node->next; } } IPC-ShareLite-0.17/sharestuff.h0000644000076500000240000000430611154610712015074 0ustar andystaff /* Default shared memory segment size. Each segment is the * * same size. Maximum size is system-dependent (SHMMAX). */ #define SHM_SEGMENT_SIZE 65536 /* Maximum value of a semaphore. This is system-dependent (SEMVMX). */ #define MAX_SEM 32766 /* Lock constants used internally by us. They happen to be the same * * as for flock(), but that's purely coincidental */ #ifndef LOCK_SH #define LOCK_SH 1 #endif #ifndef LOCK_EX #define LOCK_EX 2 #endif #ifndef LOCK_NB #define LOCK_NB 4 #endif #ifndef LOCK_UN #define LOCK_UN 8 #endif /* Structure at the top of every shared memory segment. * * next_shmid is used to construct a linked-list of * * segments. length is unused, except for the first * * segment. */ typedef struct { key_t next_shmid; int length; unsigned int shm_state; unsigned int version; } Header; /* Structure for the per-process segment list. This list * * is similar to the shared memory linked-list, but contains * * the actual shared memory addresses returned from the * * shmat() calls. Since the addresses are mapped into each * * process's data segment, we cannot make them global. * * This linked-list may be shorter than the shared memory * * linked-list -- nodes are added on to this list on an * * as-needed basis */ typedef struct node { int shmid; Header *shmaddr; struct node *next; } Node; /* The primary structure for this library. We pass this back * * and forth to perl */ typedef struct { key_t key; key_t next_key; int segment_size; int data_size; int flags; int semid; short lock; Node *head; Node *tail; unsigned int shm_state; unsigned int version; } Share; /* prototypes */ Share *new_share( key_t key, int segment_size, int flags ); int write_share( Share * share, char *data, int length ); int read_share( Share * share, char **data ); int destroy_share( Share * share, int rmid ); int sharelite_lock( Share * share, int flags ); int sharelite_unlock( Share * share ); int sharelite_num_segments( Share * share ); unsigned int sharelite_version( Share * share ); IPC-ShareLite-0.17/t/0000755000076500000240000000000011155603661013017 5ustar andystaffIPC-ShareLite-0.17/t/00-load.t0000644000076500000240000000020011154610714014324 0ustar andystaffuse Test::More tests => 1; BEGIN { use_ok( 'IPC::ShareLite' ); } diag( "Testing IPC::ShareLite $IPC::ShareLite::VERSION" ); IPC-ShareLite-0.17/t/pod.t0000644000076500000240000000021411154610716013761 0ustar andystaff#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); IPC-ShareLite-0.17/t/sharelite.t0000644000076500000240000000334411155305546015171 0ustar andystaffuse strict; use warnings; use Test::More tests => 14; use File::Spec; my $log_file = $ENV{IPC_SHARELITE_LOG} = File::Spec->catfile( 't', "sl-$$.log" ); use_ok 'IPC::ShareLite', qw( LOCK_EX LOCK_SH LOCK_UN LOCK_NB ); ######################### End of black magic. # If a semaphore or shared memory segment already uses this # key, all tests will fail my $KEY = 192; # Test object construction ok my $share = IPC::ShareLite->new( -key => $KEY, -create => 'yes', -destroy => 'yes', -size => 100 ), 'new'; isa_ok $share, 'IPC::ShareLite'; is $share->version, 1, 'version'; # Store value ok $share->store( 'maurice' ), 'store'; is $share->version, 2, 'version inc'; # Retrieve value is $share->fetch, 'maurice', 'fetch'; # Fragmented store ok $share->store( "X" x 200 ), 'frag store'; is $share->version, 3, 'version inc'; # Check number of segments is $share->num_segments, 3, 'num_segments'; # Fragmented fetch is $share->fetch, ( 'X' x 200 ), 'frag fetch'; $share->store( 0 ); is $share->version, 4, 'version inc'; my $pid = fork; defined $pid or die $!; if ( $pid == 0 ) { $share->destroy( 0 ); for ( 1 .. 1000 ) { $share->lock( LOCK_EX() ) or die $!; my $val = $share->fetch; $share->store( ++$val ) or die $!; $share->unlock or die $!; } exit; } else { for ( 1 .. 1000 ) { $share->lock( LOCK_EX() ) or die $!; my $val = $share->fetch; $share->store( ++$val ) or die $!; $share->unlock or die $!; } wait; } is $share->fetch, 2000, 'lock'; is $share->version, 2004, 'version inc'; if ( -f $log_file ) { if ( -s $log_file ) { open my $lh, '<', $log_file or die "Can't read $log_file ($!)\n"; while ( <$lh> ) { chomp; diag $_; } } unlink $log_file; } IPC-ShareLite-0.17/t/unicode-key.t0000644000076500000240000000131011155603622015410 0ustar andystaff#!perl use strict; use warnings; use Test::More tests => 3; use IPC::ShareLite; my $share1 = eval { IPC::ShareLite->new( '-key' => "AAA\x{104}", # in hex it's 41 41 41 c4 84 '-create' => 'yes', '-destroy' => 'no', ); }; like $@, qr/not 8-bit clean/, '8-bit clean error (1)'; my $share2 = eval { IPC::ShareLite->new( '-key' => "AAA\x{118}", # in hex it's 41 41 41 c4 98 '-create' => 'yes', '-destroy' => 'no', ); }; like $@, qr/not 8-bit clean/, '8-bit clean error (2)'; if ( $share1 and $share2 ) { $share1->store( 'Hello world' ); ok !defined $share2->fetch, 'unicode key aliasing'; } else { pass 'unicode keys rejected'; } # vim:ts=2:sw=2:et:ft=perl IPC-ShareLite-0.17/typemap0000644000076500000240000000013710760102420014143 0ustar andystaffTYPEMAP Share* T_PTROBJ key_t KEY INPUT KEY $var = (key_t) SvIV($arg); OUTPUT