sub unimplemented_message { my $func = shift; my $how = $replacement{$func}; return "C-specific, stopped" unless defined $how; return "$$how" if ref $how; return "$how instead" if $how =~ /^use /; return "Use method $how() instead" if $how =~ /::/; return "C-specific: use $how instead"; }
sub AUTOLOAD { my ($func) = ($AUTOLOAD =~ /.*::(.*)/);
die "POSIX.xs has failed to load\n" if $func eq 'constant';
if (my $code = $reimpl{$func}) { my ($num, $arg) = (0, ''); if ($code =~ s/^(.*?) *=> *//) { $arg = $1; $num = 1 + $arg =~ tr/,//; } # no warnings to be consistent with the old implementation, where each # function was in its own little AutoSplit world: eval qq{ sub $func { no warnings; usage "$func($arg)" if \@_ != $num; $code } }; no strict; goto &$AUTOLOAD; } if (exists $replacement{$func}) { croak "Unimplemented: POSIX::$func(): ", unimplemented_message($func); }
constant($func); }
sub perror { print STDERR "@_: " if @_; print STDERR $!,"\n"; }
sub printf { usage "printf(pattern, args...)" if @_ < 1; CORE::printf STDOUT @_; }
sub sprintf { usage "sprintf(pattern, args...)" if @_ == 0; CORE::sprintf(shift,@_); }
sub load_imports { my %default_export_tags = ( # cf. exports policy below
# exports policy: # - new functions may not be added to @EXPORT, only to @EXPORT_OK # - new SHOUTYCONSTANTS are OK to add to @EXPORT
{ # De-duplicate the export list: my ( %export, %export_ok ); @export {map {@$_} values %default_export_tags} = (); @export_ok{map {@$_} values %other_export_tags} = (); # Doing the de-dup with a temporary hash has the advantage that the SVs in # @EXPORT are actually shared hash key scalars, which will save some memory. our @EXPORT = keys %export;
# you do not want to add symbols to the following list. add a new tag instead our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write printf sprintf), grep {!exists $export{$_}} keys %reimpl, keys %replacement, keys %export_ok);
sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] } sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} }; sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} }; sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} }; sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} };
{ package POSIX::SigSet; # This package is here entirely to make sure that POSIX::SigSet is seen by the # PAUSE indexer, so that it will always be clearly indexed in core. This is to # prevent the accidental case where a third-party distribution can accidentally # claim the POSIX::SigSet package, as occurred in 2011-12. -- rjbs, 2011-12-30 }
sub _croak { &_init unless defined $_sigrtn; die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0; }
sub _getsig { &_croak; my $rtsig = $_[0]; # Allow (SIGRT)?MIN( + n)?, a common idiom when doing these things in C. $rtsig = $_SIGRTMIN + ($1 || 0) if $rtsig =~ /^(?:(?:SIG)?RT)?MIN(\s*\+\s*(\d+))?$/; return $rtsig; }
sub _exist { my $rtsig = _getsig($_[1]); my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX; ($rtsig, $ok); }
sub _check { my ($rtsig, $ok) = &_exist; die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)" unless $ok; return $rtsig; }
sub new { my ($rtsig, $handler, $flags) = @_; my $sigset = POSIX::SigSet->new($rtsig); my $sigact = POSIX::SigAction->new($handler, $sigset, $flags); POSIX::sigaction($rtsig, $sigact); }
sub EXISTS { &_exist } sub FETCH { my $rtsig = &_check; my $oa = POSIX::SigAction->new(); POSIX::sigaction($rtsig, undef, $oa); return $oa->{HANDLER} } sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) } sub DELETE { delete $SIG{ &_check } } sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } } sub SCALAR { &_croak; $_sigrtn + 1 }
tie %POSIX::SIGRT, 'POSIX::SigRt'; # and the expression on the line above is true, so we return true.