?????????? ????????? - ??????????????? - /home/agenciai/public_html/cd38d8/IPC.zip
???????
PK M=�[��� � � Open2.pmnu �[��� package IPC::Open2; use strict; our ($VERSION, @ISA, @EXPORT); require 5.000; require Exporter; $VERSION = 1.05; @ISA = qw(Exporter); @EXPORT = qw(open2); =head1 NAME IPC::Open2 - open a process for both reading and writing using open2() =head1 SYNOPSIS use IPC::Open2; my $pid = open2(my $chld_out, my $chld_in, 'some', 'cmd', 'and', 'args'); # or passing the command through the shell my $pid = open2(my $chld_out, my $chld_in, 'some cmd and args'); # read from parent STDIN and write to already open handle open my $outfile, '>', 'outfile.txt' or die "open failed: $!"; my $pid = open2($outfile, '<&STDIN', 'some', 'cmd', 'and', 'args'); # read from already open handle and write to parent STDOUT open my $infile, '<', 'infile.txt' or die "open failed: $!"; my $pid = open2('>&STDOUT', $infile, 'some', 'cmd', 'and', 'args'); # reap zombie and retrieve exit status waitpid( $pid, 0 ); my $child_exit_status = $? >> 8; =head1 DESCRIPTION The open2() function runs the given command and connects $chld_out for reading and $chld_in for writing. It's what you think should work when you try my $pid = open(my $fh, "|cmd args|"); The $chld_in filehandle will have autoflush turned on. If $chld_out is a string (that is, a bareword filehandle rather than a glob or a reference) and it begins with C<< >& >>, then the child will send output directly to that file handle. If $chld_in is a string that begins with C<< <& >>, then $chld_in will be closed in the parent, and the child will read from it directly. In both cases, there will be a L<dup(2)> instead of a L<pipe(2)> made. If either reader or writer is the empty string or undefined, this will be replaced by an autogenerated filehandle. If so, you must pass a valid lvalue in the parameter slot so it can be overwritten in the caller, or an exception will be raised. open2() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C</^open2:/>. However, C<exec> failures in the child are not detected. You'll have to trap SIGPIPE yourself. open2() does not wait for and reap the child process after it exits. Except for short programs where it's acceptable to let the operating system take care of this, you need to do this yourself. This is normally as simple as calling C<waitpid $pid, 0> when you're done with the process. Failing to do this can result in an accumulation of defunct or "zombie" processes. See L<perlfunc/waitpid> for more information. This whole affair is quite dangerous, as you may block forever. It assumes it's going to talk to something like L<bc(1)>, both writing to it and reading from it. This is presumably safe because you "know" that commands like L<bc(1)> will read a line at a time and output a line at a time. Programs like L<sort(1)> that read their entire input stream first, however, are quite apt to cause deadlock. The big problem with this approach is that if you don't have control over source code being run in the child process, you can't control what it does with pipe buffering. Thus you can't just open a pipe to C<cat -v> and continually read and write a line from it. The L<IO::Pty> and L<Expect> modules from CPAN can help with this, as they provide a real tty (well, a pseudo-tty, actually), which gets you back to line buffering in the invoked command again. =head1 WARNING The order of arguments differs from that of open3(). =head1 SEE ALSO See L<IPC::Open3> for an alternative that handles STDERR as well. This function is really just a wrapper around open3(). =cut # &open2: tom christiansen, <tchrist@convex.com> # # usage: $pid = open2('rdr', 'wtr', 'some cmd and args'); # or $pid = open2('rdr', 'wtr', 'some', 'cmd', 'and', 'args'); # # spawn the given $cmd and connect $rdr for # reading and $wtr for writing. return pid # of child, or 0 on failure. # # WARNING: this is dangerous, as you may block forever # unless you are very careful. # # $wtr is left unbuffered. # # abort program if # rdr or wtr are null # a system call fails require IPC::Open3; sub open2 { local $Carp::CarpLevel = $Carp::CarpLevel + 1; return IPC::Open3::_open3('open2', $_[1], $_[0], '>&STDERR', @_[2 .. $#_]); } 1 PK M=�[V��4 �4 Open3.pmnu �[��� package IPC::Open3; use strict; no strict 'refs'; # because users pass me bareword filehandles our ($VERSION, @ISA, @EXPORT); require Exporter; use Carp; use Symbol qw(gensym qualify); $VERSION = '1.21'; @ISA = qw(Exporter); @EXPORT = qw(open3); =head1 NAME IPC::Open3 - open a process for reading, writing, and error handling using open3() =head1 SYNOPSIS use Symbol 'gensym'; # vivify a separate handle for STDERR my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym, 'some', 'cmd', 'and', 'args'); # or pass the command through the shell my $pid = open3(my $chld_in, my $chld_out, my $chld_err = gensym, 'some cmd and args'); # read from parent STDIN # send STDOUT and STDERR to already open handle open my $outfile, '>>', 'output.txt' or die "open failed: $!"; my $pid = open3('<&STDIN', $outfile, undef, 'some', 'cmd', 'and', 'args'); # write to parent STDOUT and STDERR my $pid = open3(my $chld_in, '>&STDOUT', '>&STDERR', 'some', 'cmd', 'and', 'args'); # reap zombie and retrieve exit status waitpid( $pid, 0 ); my $child_exit_status = $? >> 8; =head1 DESCRIPTION Extremely similar to open2(), open3() spawns the given command and connects $chld_out for reading from the child, $chld_in for writing to the child, and $chld_err for errors. If $chld_err is false, or the same file descriptor as $chld_out, then STDOUT and STDERR of the child are on the same filehandle. This means that an autovivified lexical cannot be used for the STDERR filehandle, but gensym from L<Symbol> can be used to vivify a new glob reference, see L</SYNOPSIS>. The $chld_in will have autoflush turned on. If $chld_in begins with C<< <& >>, then $chld_in will be closed in the parent, and the child will read from it directly. If $chld_out or $chld_err begins with C<< >& >>, then the child will send output directly to that filehandle. In both cases, there will be a L<dup(2)> instead of a L<pipe(2)> made. If either reader or writer is the empty string or undefined, this will be replaced by an autogenerated filehandle. If so, you must pass a valid lvalue in the parameter slot so it can be overwritten in the caller, or an exception will be raised. The filehandles may also be integers, in which case they are understood as file descriptors. open3() returns the process ID of the child process. It doesn't return on failure: it just raises an exception matching C</^open3:/>. However, C<exec> failures in the child (such as no such file or permission denied), are just reported to $chld_err under Windows and OS/2, as it is not possible to trap them. If the child process dies for any reason, the next write to $chld_in is likely to generate a SIGPIPE in the parent, which is fatal by default. So you may wish to handle this signal. Note if you specify C<-> as the command, in an analogous fashion to C<open(my $fh, "-|")> the child process will just be the forked Perl process rather than an external command. This feature isn't yet supported on Win32 platforms. open3() does not wait for and reap the child process after it exits. Except for short programs where it's acceptable to let the operating system take care of this, you need to do this yourself. This is normally as simple as calling C<waitpid $pid, 0> when you're done with the process. Failing to do this can result in an accumulation of defunct or "zombie" processes. See L<perlfunc/waitpid> for more information. If you try to read from the child's stdout writer and their stderr writer, you'll have problems with blocking, which means you'll want to use select() or L<IO::Select>, which means you'd best use sysread() instead of readline() for normal stuff. This is very dangerous, as you may block forever. It assumes it's going to talk to something like L<bc(1)>, both writing to it and reading from it. This is presumably safe because you "know" that commands like L<bc(1)> will read a line at a time and output a line at a time. Programs like L<sort(1)> that read their entire input stream first, however, are quite apt to cause deadlock. The big problem with this approach is that if you don't have control over source code being run in the child process, you can't control what it does with pipe buffering. Thus you can't just open a pipe to C<cat -v> and continually read and write a line from it. =head1 See Also =over 4 =item L<IPC::Open2> Like Open3 but without STDERR capture. =item L<IPC::Run> This is a CPAN module that has better error handling and more facilities than Open3. =back =head1 WARNING The order of arguments differs from that of open2(). =cut # &open3: Marc Horowitz <marc@mit.edu> # derived mostly from &open2 by tom christiansen, <tchrist@convex.com> # fixed for 5.001 by Ulrich Kunitz <kunitz@mai-koeln.com> # ported to Win32 by Ron Schmidt, Merrill Lynch almost ended my career # fixed for autovivving FHs, tchrist again # allow fd numbers to be used, by Frank Tobin # allow '-' as command (c.f. open "-|"), by Adam Spiers <perl@adamspiers.org> # # usage: $pid = open3('wtr', 'rdr', 'err' 'some cmd and args', 'optarg', ...); # # spawn the given $cmd and connect rdr for # reading, wtr for writing, and err for errors. # if err is '', or the same as rdr, then stdout and # stderr of the child are on the same fh. returns pid # of child (or dies on failure). # if wtr begins with '<&', then wtr will be closed in the parent, and # the child will read from it directly. if rdr or err begins with # '>&', then the child will send output directly to that fd. In both # cases, there will be a dup() instead of a pipe() made. # WARNING: this is dangerous, as you may block forever # unless you are very careful. # # $wtr is left unbuffered. # # abort program if # rdr or wtr are null # a system call fails our $Me = 'open3 (bug)'; # you should never see this, it's always localized # Fatal.pm needs to be fixed WRT prototypes. sub xpipe { pipe $_[0], $_[1] or croak "$Me: pipe($_[0], $_[1]) failed: $!"; } # I tried using a * prototype character for the filehandle but it still # disallows a bareword while compiling under strict subs. sub xopen { open $_[0], $_[1], @_[2..$#_] and return; local $" = ', '; carp "$Me: open(@_) failed: $!"; } sub xclose { $_[0] =~ /\A=?(\d+)\z/ ? do { my $fh; open($fh, $_[1] . '&=' . $1) and close($fh); } : close $_[0] or croak "$Me: close($_[0]) failed: $!"; } sub xfileno { return $1 if $_[0] =~ /\A=?(\d+)\z/; # deal with fh just being an fd return fileno $_[0]; } use constant FORCE_DEBUG_SPAWN => 0; use constant DO_SPAWN => $^O eq 'os2' || $^O eq 'MSWin32' || FORCE_DEBUG_SPAWN; sub _open3 { local $Me = shift; # simulate autovivification of filehandles because # it's too ugly to use @_ throughout to make perl do it for us # tchrist 5-Mar-00 # Historically, open3(undef...) has silently worked, so keep # it working. splice @_, 0, 1, undef if \$_[0] == \undef; splice @_, 1, 1, undef if \$_[1] == \undef; unless (eval { $_[0] = gensym unless defined $_[0] && length $_[0]; $_[1] = gensym unless defined $_[1] && length $_[1]; 1; }) { # must strip crud for croak to add back, or looks ugly $@ =~ s/(?<=value attempted) at .*//s; croak "$Me: $@"; } my @handles = ({ mode => '<', handle => \*STDIN }, { mode => '>', handle => \*STDOUT }, { mode => '>', handle => \*STDERR }, ); foreach (@handles) { $_->{parent} = shift; $_->{open_as} = gensym; } if (@_ > 1 and $_[0] eq '-') { croak "Arguments don't make sense when the command is '-'" } $handles[2]{parent} ||= $handles[1]{parent}; $handles[2]{dup_of_out} = $handles[1]{parent} eq $handles[2]{parent}; my $package; foreach (@handles) { $_->{dup} = ($_->{parent} =~ s/^[<>]&//); if ($_->{parent} !~ /\A=?(\d+)\z/) { # force unqualified filehandles into caller's package $package //= caller 1; $_->{parent} = qualify $_->{parent}, $package; } next if $_->{dup} or $_->{dup_of_out}; if ($_->{mode} eq '<') { xpipe $_->{open_as}, $_->{parent}; } else { xpipe $_->{parent}, $_->{open_as}; } } my $kidpid; if (!DO_SPAWN) { # Used to communicate exec failures. xpipe my $stat_r, my $stat_w; $kidpid = fork; croak "$Me: fork failed: $!" unless defined $kidpid; if ($kidpid == 0) { # Kid eval { # A tie in the parent should not be allowed to cause problems. untie *STDIN; untie *STDOUT; untie *STDERR; close $stat_r; require Fcntl; my $flags = fcntl $stat_w, &Fcntl::F_GETFD, 0; croak "$Me: fcntl failed: $!" unless $flags; fcntl $stat_w, &Fcntl::F_SETFD, $flags|&Fcntl::FD_CLOEXEC or croak "$Me: fcntl failed: $!"; # If she wants to dup the kid's stderr onto her stdout I need to # save a copy of her stdout before I put something else there. if (!$handles[2]{dup_of_out} && $handles[2]{dup} && xfileno($handles[2]{parent}) == fileno \*STDOUT) { my $tmp = gensym; xopen($tmp, '>&', $handles[2]{parent}); $handles[2]{parent} = $tmp; } foreach (@handles) { if ($_->{dup_of_out}) { xopen \*STDERR, ">&STDOUT" if defined fileno STDERR && fileno STDERR != fileno STDOUT; } elsif ($_->{dup}) { xopen $_->{handle}, $_->{mode} . '&', $_->{parent} if fileno $_->{handle} != xfileno($_->{parent}); } else { xclose $_->{parent}, $_->{mode}; xopen $_->{handle}, $_->{mode} . '&=', fileno $_->{open_as}; } } return 1 if ($_[0] eq '-'); exec @_ or do { local($")=(" "); croak "$Me: exec of @_ failed: $!"; }; } and do { close $stat_w; return 0; }; my $bang = 0+$!; my $err = $@; utf8::encode $err if $] >= 5.008; print $stat_w pack('IIa*', $bang, length($err), $err); close $stat_w; eval { require POSIX; POSIX::_exit(255); }; exit 255; } else { # Parent close $stat_w; my $to_read = length(pack('I', 0)) * 2; my $bytes_read = read($stat_r, my $buf = '', $to_read); if ($bytes_read) { (my $bang, $to_read) = unpack('II', $buf); read($stat_r, my $err = '', $to_read); waitpid $kidpid, 0; # Reap child which should have exited if ($err) { utf8::decode $err if $] >= 5.008; } else { $err = "$Me: " . ($! = $bang); } $! = $bang; die($err); } } } else { # DO_SPAWN # All the bookkeeping of coincidence between handles is # handled in spawn_with_handles. my @close; foreach (@handles) { if ($_->{dup_of_out}) { $_->{open_as} = $handles[1]{open_as}; } elsif ($_->{dup}) { $_->{open_as} = $_->{parent} =~ /\A[0-9]+\z/ ? $_->{parent} : \*{$_->{parent}}; push @close, $_->{open_as}; } else { push @close, \*{$_->{parent}}, $_->{open_as}; } } require IO::Pipe; $kidpid = eval { spawn_with_handles(\@handles, \@close, @_); }; die "$Me: $@" if $@; } foreach (@handles) { next if $_->{dup} or $_->{dup_of_out}; xclose $_->{open_as}, $_->{mode}; } # If the write handle is a dup give it away entirely, close my copy # of it. xclose $handles[0]{parent}, $handles[0]{mode} if $handles[0]{dup}; select((select($handles[0]{parent}), $| = 1)[0]); # unbuffer pipe $kidpid; } sub open3 { if (@_ < 4) { local $" = ', '; croak "open3(@_): not enough arguments"; } return _open3 'open3', @_ } sub spawn_with_handles { my $fds = shift; # Fields: handle, mode, open_as my $close_in_child = shift; my ($fd, %saved, @errs); foreach $fd (@$fds) { $fd->{tmp_copy} = IO::Handle->new_from_fd($fd->{handle}, $fd->{mode}); $saved{fileno $fd->{handle}} = $fd->{tmp_copy} if $fd->{tmp_copy}; } foreach $fd (@$fds) { bless $fd->{handle}, 'IO::Handle' unless eval { $fd->{handle}->isa('IO::Handle') } ; # If some of handles to redirect-to coincide with handles to # redirect, we need to use saved variants: my $open_as = $fd->{open_as}; my $fileno = fileno($open_as); $fd->{handle}->fdopen(defined($fileno) ? $saved{$fileno} || $open_as : $open_as, $fd->{mode}); } unless ($^O eq 'MSWin32') { require Fcntl; # Stderr may be redirected below, so we save the err text: foreach $fd (@$close_in_child) { next unless fileno $fd; fcntl($fd, Fcntl::F_SETFD(), 1) or push @errs, "fcntl $fd: $!" unless $saved{fileno $fd}; # Do not close what we redirect! } } my $pid; unless (@errs) { if (FORCE_DEBUG_SPAWN) { pipe my $r, my $w or die "Pipe failed: $!"; $pid = fork; die "Fork failed: $!" unless defined $pid; if (!$pid) { { no warnings; exec @_ } print $w 0 + $!; close $w; require POSIX; POSIX::_exit(255); } close $w; my $bad = <$r>; if (defined $bad) { $! = $bad; undef $pid; } } else { $pid = eval { system 1, @_ }; # 1 == P_NOWAIT } if($@) { push @errs, "IO::Pipe: Can't spawn-NOWAIT: $@"; } elsif(!$pid || $pid < 0) { push @errs, "IO::Pipe: Can't spawn-NOWAIT: $!"; } } # Do this in reverse, so that STDERR is restored first: foreach $fd (reverse @$fds) { $fd->{handle}->fdopen($fd->{tmp_copy}, $fd->{mode}); } foreach (values %saved) { $_->close or croak "Can't close: $!"; } croak join "\n", @errs if @errs; return $pid; } 1; # so require is happy PK \`�['07� Semaphore.pmnu �[��� ################################################################################ # # Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>. # Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>. # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # ################################################################################ package IPC::Semaphore; use IPC::SysV qw(GETNCNT GETZCNT GETVAL SETVAL GETPID GETALL SETALL IPC_STAT IPC_SET IPC_RMID); use strict; use vars qw($VERSION); use Carp; $VERSION = '2.09'; # Figure out if we have support for native sized types my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; { package IPC::Semaphore::stat; use Class::Struct qw(struct); struct 'IPC::Semaphore::stat' => [ uid => '$', gid => '$', cuid => '$', cgid => '$', mode => '$', ctime => '$', otime => '$', nsems => '$', ]; } sub new { @_ == 4 || croak __PACKAGE__ . '->new( KEY, NSEMS, FLAGS )'; my $class = shift; my $id = semget($_[0],$_[1],$_[2]); defined($id) ? bless \$id, $class : undef; } sub id { my $self = shift; $$self; } sub remove { my $self = shift; my $result = semctl($$self,0,IPC_RMID,0); undef $$self; $result; } sub getncnt { @_ == 2 || croak '$sem->getncnt( SEM )'; my $self = shift; my $sem = shift; my $v = semctl($$self,$sem,GETNCNT,0); $v ? 0 + $v : undef; } sub getzcnt { @_ == 2 || croak '$sem->getzcnt( SEM )'; my $self = shift; my $sem = shift; my $v = semctl($$self,$sem,GETZCNT,0); $v ? 0 + $v : undef; } sub getval { @_ == 2 || croak '$sem->getval( SEM )'; my $self = shift; my $sem = shift; my $v = semctl($$self,$sem,GETVAL,0); $v ? 0 + $v : undef; } sub getpid { @_ == 2 || croak '$sem->getpid( SEM )'; my $self = shift; my $sem = shift; my $v = semctl($$self,$sem,GETPID,0); $v ? 0 + $v : undef; } sub op { @_ >= 4 || croak '$sem->op( OPLIST )'; my $self = shift; croak 'Bad arg count' if @_ % 3; my $data = pack("s$N*",@_); semop($$self,$data); } sub stat { my $self = shift; my $data = ""; semctl($$self,0,IPC_STAT,$data) or return undef; IPC::Semaphore::stat->new->unpack($data); } sub set { my $self = shift; my $ds; if(@_ == 1) { $ds = shift; } else { croak 'Bad arg count' if @_ % 2; my %arg = @_; $ds = $self->stat or return undef; my($key,$val); $ds->$key($val) while(($key,$val) = each %arg); } my $v = semctl($$self,0,IPC_SET,$ds->pack); $v ? 0 + $v : undef; } sub getall { my $self = shift; my $data = ""; semctl($$self,0,GETALL,$data) or return (); (unpack("s$N*",$data)); } sub setall { my $self = shift; my $data = pack("s$N*",@_); semctl($$self,0,SETALL,$data); } sub setval { @_ == 3 || croak '$sem->setval( SEM, VAL )'; my $self = shift; my $sem = shift; my $val = shift; semctl($$self,$sem,SETVAL,$val); } 1; __END__ =head1 NAME IPC::Semaphore - SysV Semaphore IPC object class =head1 SYNOPSIS use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR IPC_CREAT); use IPC::Semaphore; $sem = IPC::Semaphore->new(IPC_PRIVATE, 10, S_IRUSR | S_IWUSR | IPC_CREAT); $sem->setall( (0) x 10); @sem = $sem->getall; $ncnt = $sem->getncnt; $zcnt = $sem->getzcnt; $ds = $sem->stat; $sem->remove; =head1 DESCRIPTION A class providing an object based interface to SysV IPC semaphores. =head1 METHODS =over 4 =item new ( KEY , NSEMS , FLAGS ) Create a new semaphore set associated with C<KEY>. C<NSEMS> is the number of semaphores in the set. A new set is created if =over 4 =item * C<KEY> is equal to C<IPC_PRIVATE> =item * C<KEY> does not already have a semaphore identifier associated with it, and C<I<FLAGS> & IPC_CREAT> is true. =back On creation of a new semaphore set C<FLAGS> is used to set the permissions. Be careful not to set any flags that the Sys V IPC implementation does not allow: in some systems setting execute bits makes the operations fail. =item getall Returns the values of the semaphore set as an array. =item getncnt ( SEM ) Returns the number of processes waiting for the semaphore C<SEM> to become greater than its current value =item getpid ( SEM ) Returns the process id of the last process that performed an operation on the semaphore C<SEM>. =item getval ( SEM ) Returns the current value of the semaphore C<SEM>. =item getzcnt ( SEM ) Returns the number of processes waiting for the semaphore C<SEM> to become zero. =item id Returns the system identifier for the semaphore set. =item op ( OPLIST ) C<OPLIST> is a list of operations to pass to C<semop>. C<OPLIST> is a concatenation of smaller lists, each which has three values. The first is the semaphore number, the second is the operation and the last is a flags value. See L<semop(2)> for more details. For example $sem->op( 0, -1, IPC_NOWAIT, 1, 1, IPC_NOWAIT ); =item remove Remove and destroy the semaphore set from the system. =item set ( STAT ) =item set ( NAME => VALUE [, NAME => VALUE ...] ) C<set> will set the following values of the C<stat> structure associated with the semaphore set. uid gid mode (only the permission bits) C<set> accepts either a stat object, as returned by the C<stat> method, or a list of I<name>-I<value> pairs. =item setall ( VALUES ) Sets all values in the semaphore set to those given on the C<VALUES> list. C<VALUES> must contain the correct number of values. =item setval ( N , VALUE ) Set the C<N>th value in the semaphore set to C<VALUE> =item stat Returns an object of type C<IPC::Semaphore::stat> which is a sub-class of C<Class::Struct>. It provides the following fields. For a description of these fields see your system documentation. uid gid cuid cgid mode ctime otime nsems =back =head1 SEE ALSO L<IPC::SysV>, L<Class::Struct>, L<semget(2)>, L<semctl(2)>, L<semop(2)> =head1 AUTHORS Graham Barr <gbarr@pobox.com>, Marcus Holland-Moritz <mhx@cpan.org> =head1 COPYRIGHT Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz. Version 1.x, Copyright (c) 1997, Graham Barr. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK \`�[����� � SysV.pmnu �[��� ################################################################################ # # Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>. # Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>. # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # ################################################################################ package IPC::SysV; use strict; use vars qw(@ISA @EXPORT @EXPORT_OK %EXPORT_TAGS $VERSION $AUTOLOAD); use Carp; use Config; require Exporter; @ISA = qw(Exporter); $VERSION = '2.09'; # To support new constants, just add them to @EXPORT_OK # and the C/XS code will be generated automagically. @EXPORT_OK = (qw( GETALL GETNCNT GETPID GETVAL GETZCNT IPC_ALLOC IPC_CREAT IPC_EXCL IPC_GETACL IPC_INFO IPC_LOCKED IPC_M IPC_NOERROR IPC_NOWAIT IPC_PRIVATE IPC_R IPC_RMID IPC_SET IPC_SETACL IPC_SETLABEL IPC_STAT IPC_W IPC_WANTED MSG_EXCEPT MSG_FWAIT MSG_INFO MSG_LOCKED MSG_MWAIT MSG_NOERROR MSG_QWAIT MSG_R MSG_RWAIT MSG_STAT MSG_W MSG_WAIT MSG_WWAIT SEM_A SEM_ALLOC SEM_DEST SEM_ERR SEM_INFO SEM_ORDER SEM_R SEM_STAT SEM_UNDO SETALL SETVAL SHMLBA SHM_A SHM_CLEAR SHM_COPY SHM_DCACHE SHM_DEST SHM_ECACHE SHM_FMAP SHM_HUGETLB SHM_ICACHE SHM_INFO SHM_INIT SHM_LOCK SHM_LOCKED SHM_MAP SHM_NORESERVE SHM_NOSWAP SHM_R SHM_RDONLY SHM_REMAP SHM_REMOVED SHM_RND SHM_SHARE_MMU SHM_SHATTR SHM_SIZE SHM_STAT SHM_UNLOCK SHM_W S_IRUSR S_IWUSR S_IXUSR S_IRWXU S_IRGRP S_IWGRP S_IXGRP S_IRWXG S_IROTH S_IWOTH S_IXOTH S_IRWXO ENOSPC ENOSYS ENOMEM EACCES ), qw( ftok shmat shmdt memread memwrite )); %EXPORT_TAGS = ( all => [@EXPORT, @EXPORT_OK], ); sub AUTOLOAD { my $constname = $AUTOLOAD; $constname =~ s/.*:://; die "&IPC::SysV::_constant not defined" if $constname eq '_constant'; my ($error, $val) = _constant($constname); if ($error) { my (undef, $file, $line) = caller; die "$error at $file line $line.\n"; } { no strict 'refs'; *$AUTOLOAD = sub { $val }; } goto &$AUTOLOAD; } BOOT_XS: { # If I inherit DynaLoader then I inherit AutoLoader and I DON'T WANT TO use XSLoader (); XSLoader::load( 'IPC::SysV', $VERSION ); } 1; __END__ =head1 NAME IPC::SysV - System V IPC constants and system calls =head1 SYNOPSIS use IPC::SysV qw(IPC_STAT IPC_PRIVATE); =head1 DESCRIPTION C<IPC::SysV> defines and conditionally exports all the constants defined in your system include files which are needed by the SysV IPC calls. Common ones include IPC_CREAT IPC_EXCL IPC_NOWAIT IPC_PRIVATE IPC_RMID IPC_SET IPC_STAT GETVAL SETVAL GETPID GETNCNT GETZCNT GETALL SETALL SEM_A SEM_R SEM_UNDO SHM_RDONLY SHM_RND SHMLBA and auxiliary ones S_IRUSR S_IWUSR S_IRWXU S_IRGRP S_IWGRP S_IRWXG S_IROTH S_IWOTH S_IRWXO but your system might have more. =over 4 =item ftok( PATH ) =item ftok( PATH, ID ) Return a key based on PATH and ID, which can be used as a key for C<msgget>, C<semget> and C<shmget>. See L<ftok(3)>. If ID is omitted, it defaults to C<1>. If a single character is given for ID, the numeric value of that character is used. =item shmat( ID, ADDR, FLAG ) Attach the shared memory segment identified by ID to the address space of the calling process. See L<shmat(2)>. ADDR should be C<undef> unless you really know what you're doing. =item shmdt( ADDR ) Detach the shared memory segment located at the address specified by ADDR from the address space of the calling process. See L<shmdt(2)>. =item memread( ADDR, VAR, POS, SIZE ) Reads SIZE bytes from a memory segment at ADDR starting at position POS. VAR must be a variable that will hold the data read. Returns true if successful, or false if there is an error. memread() taints the variable. =item memwrite( ADDR, STRING, POS, SIZE ) Writes SIZE bytes from STRING to a memory segment at ADDR starting at position POS. If STRING is too long, only SIZE bytes are used; if STRING is too short, nulls are written to fill out SIZE bytes. Returns true if successful, or false if there is an error. =back =head1 SEE ALSO L<IPC::Msg>, L<IPC::Semaphore>, L<IPC::SharedMem>, L<ftok(3)>, L<shmat(2)>, L<shmdt(2)> =head1 AUTHORS Graham Barr <gbarr@pobox.com>, Jarkko Hietaniemi <jhi@iki.fi>, Marcus Holland-Moritz <mhx@cpan.org> =head1 COPYRIGHT Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz. Version 1.x, Copyright (c) 1997, Graham Barr. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK \`�[7 �� � Msg.pmnu �[��� ################################################################################ # # Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>. # Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>. # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # ################################################################################ package IPC::Msg; use IPC::SysV qw(IPC_STAT IPC_SET IPC_RMID); use strict; use vars qw($VERSION); use Carp; $VERSION = '2.09'; # Figure out if we have support for native sized types my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; { package IPC::Msg::stat; use Class::Struct qw(struct); struct 'IPC::Msg::stat' => [ uid => '$', gid => '$', cuid => '$', cgid => '$', mode => '$', qnum => '$', qbytes => '$', lspid => '$', lrpid => '$', stime => '$', rtime => '$', ctime => '$', ]; } sub new { @_ == 3 || croak 'IPC::Msg->new( KEY , FLAGS )'; my $class = shift; my $id = msgget($_[0],$_[1]); defined($id) ? bless \$id, $class : undef; } sub id { my $self = shift; $$self; } sub stat { my $self = shift; my $data = ""; msgctl($$self,IPC_STAT,$data) or return undef; IPC::Msg::stat->new->unpack($data); } sub set { my $self = shift; my $ds; if(@_ == 1) { $ds = shift; } else { croak 'Bad arg count' if @_ % 2; my %arg = @_; $ds = $self->stat or return undef; my($key,$val); $ds->$key($val) while(($key,$val) = each %arg); } msgctl($$self,IPC_SET,$ds->pack); } sub remove { my $self = shift; (msgctl($$self,IPC_RMID,0), undef $$self)[0]; } sub rcv { @_ <= 5 && @_ >= 3 or croak '$msg->rcv( BUF, LEN, TYPE, FLAGS )'; my $self = shift; my $buf = ""; msgrcv($$self,$buf,$_[1],$_[2] || 0, $_[3] || 0) or return; my $type; ($type,$_[0]) = unpack("l$N a*",$buf); $type; } sub snd { @_ <= 4 && @_ >= 3 or croak '$msg->snd( TYPE, BUF, FLAGS )'; my $self = shift; msgsnd($$self,pack("l$N a*",$_[0],$_[1]), $_[2] || 0); } 1; __END__ =head1 NAME IPC::Msg - SysV Msg IPC object class =head1 SYNOPSIS use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR); use IPC::Msg; $msg = IPC::Msg->new(IPC_PRIVATE, S_IRUSR | S_IWUSR); $msg->snd($msgtype, $msgdata); $msg->rcv($buf, 256); $ds = $msg->stat; $msg->remove; =head1 DESCRIPTION A class providing an object based interface to SysV IPC message queues. =head1 METHODS =over 4 =item new ( KEY , FLAGS ) Creates a new message queue associated with C<KEY>. A new queue is created if =over 4 =item * C<KEY> is equal to C<IPC_PRIVATE> =item * C<KEY> does not already have a message queue associated with it, and C<I<FLAGS> & IPC_CREAT> is true. =back On creation of a new message queue C<FLAGS> is used to set the permissions. Be careful not to set any flags that the Sys V IPC implementation does not allow: in some systems setting execute bits makes the operations fail. =item id Returns the system message queue identifier. =item rcv ( BUF, LEN [, TYPE [, FLAGS ]] ) Read a message from the queue. Returns the type of the message read. See L<msgrcv(2)>. The BUF becomes tainted. =item remove Remove and destroy the message queue from the system. =item set ( STAT ) =item set ( NAME => VALUE [, NAME => VALUE ...] ) C<set> will set the following values of the C<stat> structure associated with the message queue. uid gid mode (oly the permission bits) qbytes C<set> accepts either a stat object, as returned by the C<stat> method, or a list of I<name>-I<value> pairs. =item snd ( TYPE, MSG [, FLAGS ] ) Place a message on the queue with the data from C<MSG> and with type C<TYPE>. See L<msgsnd(2)>. =item stat Returns an object of type C<IPC::Msg::stat> which is a sub-class of C<Class::Struct>. It provides the following fields. For a description of these fields see you system documentation. uid gid cuid cgid mode qnum qbytes lspid lrpid stime rtime ctime =back =head1 SEE ALSO L<IPC::SysV>, L<Class::Struct> =head1 AUTHORS Graham Barr <gbarr@pobox.com>, Marcus Holland-Moritz <mhx@cpan.org> =head1 COPYRIGHT Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz. Version 1.x, Copyright (c) 1997, Graham Barr. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK \`�[F��b� � SharedMem.pmnu �[��� ################################################################################ # # Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz <mhx@cpan.org>. # Version 1.x, Copyright (C) 1997, Graham Barr <gbarr@pobox.com>. # # This program is free software; you can redistribute it and/or # modify it under the same terms as Perl itself. # ################################################################################ package IPC::SharedMem; use IPC::SysV qw(IPC_STAT IPC_RMID shmat shmdt memread memwrite); use strict; use vars qw($VERSION); use Carp; $VERSION = '2.09'; # Figure out if we have support for native sized types my $N = do { my $foo = eval { pack "L!", 0 }; $@ ? '' : '!' }; { package IPC::SharedMem::stat; use Class::Struct qw(struct); struct 'IPC::SharedMem::stat' => [ uid => '$', gid => '$', cuid => '$', cgid => '$', mode => '$', segsz => '$', lpid => '$', cpid => '$', nattch => '$', atime => '$', dtime => '$', ctime => '$', ]; } sub new { @_ == 4 or croak 'IPC::SharedMem->new(KEY, SIZE, FLAGS)'; my($class, $key, $size, $flags) = @_; my $id = shmget $key, $size, $flags; return undef unless defined $id; bless { _id => $id, _addr => undef, _isrm => 0 }, $class } sub id { my $self = shift; $self->{_id}; } sub addr { my $self = shift; $self->{_addr}; } sub stat { my $self = shift; my $data = ''; shmctl $self->id, IPC_STAT, $data or return undef; IPC::SharedMem::stat->new->unpack($data); } sub attach { @_ >= 1 && @_ <= 2 or croak '$shm->attach([FLAG])'; my($self, $flag) = @_; defined $self->addr and return undef; $self->{_addr} = shmat($self->id, undef, $flag || 0); defined $self->addr; } sub detach { my $self = shift; defined $self->addr or return undef; my $rv = defined shmdt($self->addr); undef $self->{_addr} if $rv; $rv; } sub remove { my $self = shift; return undef if $self->is_removed; my $rv = shmctl $self->id, IPC_RMID, 0; $self->{_isrm} = 1 if $rv; return $rv; } sub is_removed { my $self = shift; $self->{_isrm}; } sub read { @_ == 3 or croak '$shm->read(POS, SIZE)'; my($self, $pos, $size) = @_; my $buf = ''; if (defined $self->addr) { memread($self->addr, $buf, $pos, $size) or return undef; } else { shmread($self->id, $buf, $pos, $size) or return undef; } $buf; } sub write { @_ == 4 or croak '$shm->write(STRING, POS, SIZE)'; my($self, $str, $pos, $size) = @_; if (defined $self->addr) { return memwrite($self->addr, $str, $pos, $size); } else { return shmwrite($self->id, $str, $pos, $size); } } 1; __END__ =head1 NAME IPC::SharedMem - SysV Shared Memory IPC object class =head1 SYNOPSIS use IPC::SysV qw(IPC_PRIVATE S_IRUSR S_IWUSR); use IPC::SharedMem; $shm = IPC::SharedMem->new(IPC_PRIVATE, 8, S_IRWXU); $shm->write(pack("S", 4711), 2, 2); $data = $shm->read(0, 2); $ds = $shm->stat; $shm->remove; =head1 DESCRIPTION A class providing an object based interface to SysV IPC shared memory. =head1 METHODS =over 4 =item new ( KEY , SIZE , FLAGS ) Creates a new shared memory segment of C<SIZE> bytes size associated with C<KEY>. A new segment is created if =over 4 =item * C<KEY> is equal to C<IPC_PRIVATE> =item * C<KEY> does not already have a shared memory segment associated with it, and C<I<FLAGS> & IPC_CREAT> is true. =back On creation of a new shared memory segment C<FLAGS> is used to set the permissions. Be careful not to set any flags that the Sys V IPC implementation does not allow: in some systems setting execute bits makes the operations fail. =item id Returns the shared memory identifier. =item read ( POS, SIZE ) Read C<SIZE> bytes from the shared memory segment at C<POS>. Returns the string read, or C<undef> if there was an error. The return value becomes tainted. See L<shmread>. =item write ( STRING, POS, SIZE ) Write C<SIZE> bytes to the shared memory segment at C<POS>. Returns true if successful, or false if there is an error. See L<shmwrite>. =item remove Remove the shared memory segment from the system or mark it as removed as long as any processes are still attached to it. =item is_removed Returns true if the shared memory segment has been removed or marked for removal. =item stat Returns an object of type C<IPC::SharedMem::stat> which is a sub-class of C<Class::Struct>. It provides the following fields. For a description of these fields see you system documentation. uid gid cuid cgid mode segsz lpid cpid nattch atime dtime ctime =item attach ( [FLAG] ) Permanently attach to the shared memory segment. When a C<IPC::SharedMem> object is attached, it will use L<memread> and L<memwrite> instead of L<shmread> and L<shmwrite> for accessing the shared memory segment. Returns true if successful, or false on error. See L<shmat(2)>. =item detach Detach from the shared memory segment that previously has been attached to. Returns true if successful, or false on error. See L<shmdt(2)>. =item addr Returns the address of the shared memory that has been attached to in a format suitable for use with C<pack('P')>. Returns C<undef> if the shared memory has not been attached. =back =head1 SEE ALSO L<IPC::SysV>, L<Class::Struct> =head1 AUTHORS Marcus Holland-Moritz <mhx@cpan.org> =head1 COPYRIGHT Version 2.x, Copyright (C) 2007-2013, Marcus Holland-Moritz. Version 1.x, Copyright (c) 1997, Graham Barr. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut PK M=�[��� � � Open2.pmnu �[��� PK M=�[V��4 �4 � Open3.pmnu �[��� PK \`�['07� �E Semaphore.pmnu �[��� PK \`�[����� � _ SysV.pmnu �[��� PK \`�[7 �� � ,q Msg.pmnu �[��� PK \`�[F��b� � � SharedMem.pmnu �[��� PK � )�
| ver. 1.6 |
Github
|
.
| PHP 8.2.30 | ??????????? ?????????: 0 |
proxy
|
phpinfo
|
???????????