| 1 | package POSIX; |
| 2 | use strict; |
| 3 | use warnings; |
| 4 | |
| 5 | our ($AUTOLOAD, %SIGRT); |
| 6 | |
| 7 | our $VERSION = '1.28_001'; |
| 8 | |
| 9 | require XSLoader; |
| 10 | |
| 11 | use Fcntl qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD |
| 12 | F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK O_ACCMODE O_APPEND |
| 13 | O_CREAT O_EXCL O_NOCTTY O_NONBLOCK O_RDONLY O_RDWR O_TRUNC |
| 14 | O_WRONLY SEEK_CUR SEEK_END SEEK_SET |
| 15 | S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISREG |
| 16 | S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU S_ISGID S_ISUID |
| 17 | S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR); |
| 18 | |
| 19 | my $loaded; |
| 20 | |
| 21 | sub import { |
| 22 | my $pkg = shift; |
| 23 | |
| 24 | load_imports() unless $loaded++; |
| 25 | |
| 26 | # Grandfather old foo_h form to new :foo_h form |
| 27 | s/^(?=\w+_h$)/:/ for my @list = @_; |
| 28 | |
| 29 | local $Exporter::ExportLevel = 1; |
| 30 | Exporter::import($pkg,@list); |
| 31 | } |
| 32 | |
| 33 | sub croak { require Carp; goto &Carp::croak } |
| 34 | sub usage { croak "Usage: POSIX::$_[0]" } |
| 35 | |
| 36 | XSLoader::load(); |
| 37 | |
| 38 | my %replacement = ( |
| 39 | atexit => 'END {}', |
| 40 | atof => undef, |
| 41 | atoi => undef, |
| 42 | atol => undef, |
| 43 | bsearch => \'not supplied', |
| 44 | calloc => undef, |
| 45 | clearerr => 'IO::Handle::clearerr', |
| 46 | div => '/, % and int', |
| 47 | execl => undef, |
| 48 | execle => undef, |
| 49 | execlp => undef, |
| 50 | execv => undef, |
| 51 | execve => undef, |
| 52 | execvp => undef, |
| 53 | fclose => 'IO::Handle::close', |
| 54 | fdopen => 'IO::Handle::new_from_fd', |
| 55 | feof => 'IO::Handle::eof', |
| 56 | ferror => 'IO::Handle::error', |
| 57 | fflush => 'IO::Handle::flush', |
| 58 | fgetc => 'IO::Handle::getc', |
| 59 | fgetpos => 'IO::Seekable::getpos', |
| 60 | fgets => 'IO::Handle::gets', |
| 61 | fileno => 'IO::Handle::fileno', |
| 62 | fopen => 'IO::File::open', |
| 63 | fprintf => 'printf', |
| 64 | fputc => 'print', |
| 65 | fputs => 'print', |
| 66 | fread => 'read', |
| 67 | free => undef, |
| 68 | freopen => 'open', |
| 69 | fscanf => '<> and regular expressions', |
| 70 | fseek => 'IO::Seekable::seek', |
| 71 | fsetpos => 'IO::Seekable::setpos', |
| 72 | fsync => 'IO::Handle::sync', |
| 73 | ftell => 'IO::Seekable::tell', |
| 74 | fwrite => 'print', |
| 75 | labs => 'abs', |
| 76 | ldiv => '/, % and int', |
| 77 | longjmp => 'die', |
| 78 | malloc => undef, |
| 79 | memchr => 'index()', |
| 80 | memcmp => 'eq', |
| 81 | memcpy => '=', |
| 82 | memmove => '=', |
| 83 | memset => 'x', |
| 84 | offsetof => undef, |
| 85 | putc => 'print', |
| 86 | putchar => 'print', |
| 87 | puts => 'print', |
| 88 | qsort => 'sort', |
| 89 | rand => \'non-portable, use Perl\'s rand instead', |
| 90 | realloc => undef, |
| 91 | scanf => '<> and regular expressions', |
| 92 | setbuf => 'IO::Handle::setbuf', |
| 93 | setjmp => 'eval {}', |
| 94 | setvbuf => 'IO::Handle::setvbuf', |
| 95 | siglongjmp => 'die', |
| 96 | sigsetjmp => 'eval {}', |
| 97 | srand => \'not supplied; refer to Perl\'s srand documentation', |
| 98 | sscanf => 'regular expressions', |
| 99 | strcat => '.=', |
| 100 | strchr => 'index()', |
| 101 | strcmp => 'eq', |
| 102 | strcpy => '=', |
| 103 | strcspn => 'regular expressions', |
| 104 | strlen => 'length', |
| 105 | strncat => '.=', |
| 106 | strncmp => 'eq', |
| 107 | strncpy => '=', |
| 108 | strpbrk => undef, |
| 109 | strrchr => 'rindex()', |
| 110 | strspn => undef, |
| 111 | strtok => undef, |
| 112 | tmpfile => 'IO::File::new_tmpfile', |
| 113 | ungetc => 'IO::Handle::ungetc', |
| 114 | vfprintf => undef, |
| 115 | vprintf => undef, |
| 116 | vsprintf => undef, |
| 117 | ); |
| 118 | |
| 119 | my %reimpl = ( |
| 120 | assert => 'expr => croak "Assertion failed" if !$_[0]', |
| 121 | tolower => 'string => lc($_[0])', |
| 122 | toupper => 'string => uc($_[0])', |
| 123 | closedir => 'dirhandle => CORE::closedir($_[0])', |
| 124 | opendir => 'directory => my $dh; CORE::opendir($dh, $_[0]) ? $dh : undef', |
| 125 | readdir => 'dirhandle => CORE::readdir($_[0])', |
| 126 | rewinddir => 'dirhandle => CORE::rewinddir($_[0])', |
| 127 | errno => '$! + 0', |
| 128 | creat => 'filename, mode => &open($_[0], &O_WRONLY | &O_CREAT | &O_TRUNC, $_[1])', |
| 129 | fcntl => 'filehandle, cmd, arg => CORE::fcntl($_[0], $_[1], $_[2])', |
| 130 | getgrgid => 'gid => CORE::getgrgid($_[0])', |
| 131 | getgrnam => 'name => CORE::getgrnam($_[0])', |
| 132 | atan2 => 'x, y => CORE::atan2($_[0], $_[1])', |
| 133 | cos => 'x => CORE::cos($_[0])', |
| 134 | exp => 'x => CORE::exp($_[0])', |
| 135 | fabs => 'x => CORE::abs($_[0])', |
| 136 | log => 'x => CORE::log($_[0])', |
| 137 | pow => 'x, exponent => $_[0] ** $_[1]', |
| 138 | sin => 'x => CORE::sin($_[0])', |
| 139 | sqrt => 'x => CORE::sqrt($_[0])', |
| 140 | getpwnam => 'name => CORE::getpwnam($_[0])', |
| 141 | getpwuid => 'uid => CORE::getpwuid($_[0])', |
| 142 | kill => 'pid, sig => CORE::kill $_[1], $_[0]', |
| 143 | raise => 'sig => CORE::kill $_[0], $$; # Is this good enough', |
| 144 | getc => 'handle => CORE::getc($_[0])', |
| 145 | getchar => 'CORE::getc(STDIN)', |
| 146 | gets => 'scalar <STDIN>', |
| 147 | remove => 'filename => (-d $_[0]) ? CORE::rmdir($_[0]) : CORE::unlink($_[0])', |
| 148 | rename => 'oldfilename, newfilename => CORE::rename($_[0], $_[1])', |
| 149 | rewind => 'filehandle => CORE::seek($_[0],0,0)', |
| 150 | abs => 'x => CORE::abs($_[0])', |
| 151 | exit => 'status => CORE::exit($_[0])', |
| 152 | getenv => 'name => $ENV{$_[0]}', |
| 153 | system => 'command => CORE::system($_[0])', |
| 154 | strerror => 'errno => local $! = $_[0]; "$!"', |
| 155 | strstr => 'big, little => CORE::index($_[0], $_[1])', |
| 156 | chmod => 'mode, filename => CORE::chmod($_[0], $_[1])', |
| 157 | fstat => 'fd => CORE::open my $dup, "<&", $_[0]; CORE::stat($dup)', # Gross. |
| 158 | mkdir => 'directoryname, mode => CORE::mkdir($_[0], $_[1])', |
| 159 | stat => 'filename => CORE::stat($_[0])', |
| 160 | umask => 'mask => CORE::umask($_[0])', |
| 161 | wait => 'CORE::wait()', |
| 162 | waitpid => 'pid, options => CORE::waitpid($_[0], $_[1])', |
| 163 | gmtime => 'time => CORE::gmtime($_[0])', |
| 164 | localtime => 'time => CORE::localtime($_[0])', |
| 165 | time => 'CORE::time', |
| 166 | alarm => 'seconds => CORE::alarm($_[0])', |
| 167 | chdir => 'directory => CORE::chdir($_[0])', |
| 168 | chown => 'uid, gid, filename => CORE::chown($_[0], $_[1], $_[2])', |
| 169 | fork => 'CORE::fork', |
| 170 | getegid => '$) + 0', |
| 171 | geteuid => '$> + 0', |
| 172 | getgid => '$( + 0', |
| 173 | getgroups => 'my %seen; grep !$seen{$_}++, split " ", $)', |
| 174 | getlogin => 'CORE::getlogin()', |
| 175 | getpgrp => 'CORE::getpgrp', |
| 176 | getpid => '$$', |
| 177 | getppid => 'CORE::getppid', |
| 178 | getuid => '$<', |
| 179 | isatty => 'filehandle => -t $_[0]', |
| 180 | link => 'oldfilename, newfilename => CORE::link($_[0], $_[1])', |
| 181 | rmdir => 'directoryname => CORE::rmdir($_[0])', |
| 182 | unlink => 'filename => CORE::unlink($_[0])', |
| 183 | utime => 'filename, atime, mtime => CORE::utime($_[1], $_[2], $_[0])', |
| 184 | ); |
| 185 | |
| 186 | eval join ';', map "sub $_", keys %replacement, keys %reimpl; |
| 187 | |
| 188 | sub AUTOLOAD { |
| 189 | my ($func) = ($AUTOLOAD =~ /.*::(.*)/); |
| 190 | |
| 191 | if (my $code = $reimpl{$func}) { |
| 192 | my ($num, $arg) = (0, ''); |
| 193 | if ($code =~ s/^(.*?) *=> *//) { |
| 194 | $arg = $1; |
| 195 | $num = 1 + $arg =~ tr/,//; |
| 196 | } |
| 197 | # no warnings to be consistent with the old implementation, where each |
| 198 | # function was in its own little AutoSplit world: |
| 199 | eval qq{ sub $func { |
| 200 | no warnings; |
| 201 | usage "$func($arg)" if \@_ != $num; |
| 202 | $code |
| 203 | } }; |
| 204 | no strict; |
| 205 | goto &$AUTOLOAD; |
| 206 | } |
| 207 | if (exists $replacement{$func}) { |
| 208 | my $how = $replacement{$func}; |
| 209 | croak "Unimplemented: POSIX::$func() is C-specific, stopped" |
| 210 | unless defined $how; |
| 211 | croak "Unimplemented: POSIX::$func() is $$how" if ref $how; |
| 212 | croak "Use method $how() instead of POSIX::$func()" if $how =~ /::/; |
| 213 | croak "Unimplemented: POSIX::$func() is C-specific: use $how instead"; |
| 214 | } |
| 215 | |
| 216 | constant($func); |
| 217 | } |
| 218 | |
| 219 | sub perror { |
| 220 | print STDERR "@_: " if @_; |
| 221 | print STDERR $!,"\n"; |
| 222 | } |
| 223 | |
| 224 | sub printf { |
| 225 | usage "printf(pattern, args...)" if @_ < 1; |
| 226 | CORE::printf STDOUT @_; |
| 227 | } |
| 228 | |
| 229 | sub sprintf { |
| 230 | usage "sprintf(pattern, args...)" if @_ == 0; |
| 231 | CORE::sprintf(shift,@_); |
| 232 | } |
| 233 | |
| 234 | sub load_imports { |
| 235 | our %EXPORT_TAGS = ( |
| 236 | |
| 237 | assert_h => [qw(assert NDEBUG)], |
| 238 | |
| 239 | ctype_h => [qw(isalnum isalpha iscntrl isdigit isgraph islower |
| 240 | isprint ispunct isspace isupper isxdigit tolower toupper)], |
| 241 | |
| 242 | dirent_h => [], |
| 243 | |
| 244 | errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT |
| 245 | EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED |
| 246 | ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT |
| 247 | EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS |
| 248 | EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK |
| 249 | EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH |
| 250 | ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM |
| 251 | ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR |
| 252 | ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM |
| 253 | EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE |
| 254 | ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT |
| 255 | ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY |
| 256 | EUSERS EWOULDBLOCK EXDEV errno)], |
| 257 | |
| 258 | fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK |
| 259 | F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK |
| 260 | O_ACCMODE O_APPEND O_CREAT O_EXCL O_NOCTTY O_NONBLOCK |
| 261 | O_RDONLY O_RDWR O_TRUNC O_WRONLY |
| 262 | creat |
| 263 | SEEK_CUR SEEK_END SEEK_SET |
| 264 | S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU |
| 265 | S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG S_ISUID |
| 266 | S_IWGRP S_IWOTH S_IWUSR)], |
| 267 | |
| 268 | float_h => [qw(DBL_DIG DBL_EPSILON DBL_MANT_DIG |
| 269 | DBL_MAX DBL_MAX_10_EXP DBL_MAX_EXP |
| 270 | DBL_MIN DBL_MIN_10_EXP DBL_MIN_EXP |
| 271 | FLT_DIG FLT_EPSILON FLT_MANT_DIG |
| 272 | FLT_MAX FLT_MAX_10_EXP FLT_MAX_EXP |
| 273 | FLT_MIN FLT_MIN_10_EXP FLT_MIN_EXP |
| 274 | FLT_RADIX FLT_ROUNDS |
| 275 | LDBL_DIG LDBL_EPSILON LDBL_MANT_DIG |
| 276 | LDBL_MAX LDBL_MAX_10_EXP LDBL_MAX_EXP |
| 277 | LDBL_MIN LDBL_MIN_10_EXP LDBL_MIN_EXP)], |
| 278 | |
| 279 | grp_h => [], |
| 280 | |
| 281 | limits_h => [qw( ARG_MAX CHAR_BIT CHAR_MAX CHAR_MIN CHILD_MAX |
| 282 | INT_MAX INT_MIN LINK_MAX LONG_MAX LONG_MIN MAX_CANON |
| 283 | MAX_INPUT MB_LEN_MAX NAME_MAX NGROUPS_MAX OPEN_MAX |
| 284 | PATH_MAX PIPE_BUF SCHAR_MAX SCHAR_MIN SHRT_MAX SHRT_MIN |
| 285 | SSIZE_MAX STREAM_MAX TZNAME_MAX UCHAR_MAX UINT_MAX |
| 286 | ULONG_MAX USHRT_MAX _POSIX_ARG_MAX _POSIX_CHILD_MAX |
| 287 | _POSIX_LINK_MAX _POSIX_MAX_CANON _POSIX_MAX_INPUT |
| 288 | _POSIX_NAME_MAX _POSIX_NGROUPS_MAX _POSIX_OPEN_MAX |
| 289 | _POSIX_PATH_MAX _POSIX_PIPE_BUF _POSIX_SSIZE_MAX |
| 290 | _POSIX_STREAM_MAX _POSIX_TZNAME_MAX)], |
| 291 | |
| 292 | locale_h => [qw(LC_ALL LC_COLLATE LC_CTYPE LC_MESSAGES |
| 293 | LC_MONETARY LC_NUMERIC LC_TIME NULL |
| 294 | localeconv setlocale)], |
| 295 | |
| 296 | math_h => [qw(HUGE_VAL acos asin atan ceil cosh fabs floor fmod |
| 297 | frexp ldexp log10 modf pow sinh tan tanh)], |
| 298 | |
| 299 | pwd_h => [], |
| 300 | |
| 301 | setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], |
| 302 | |
| 303 | signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK |
| 304 | SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM |
| 305 | SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL |
| 306 | SIGPIPE %SIGRT SIGRTMIN SIGRTMAX SIGQUIT SIGSEGV SIGSTOP |
| 307 | SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIGBUS |
| 308 | SIGPOLL SIGPROF SIGSYS SIGTRAP SIGURG SIGVTALRM SIGXCPU SIGXFSZ |
| 309 | SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK |
| 310 | raise sigaction signal sigpending sigprocmask sigsuspend)], |
| 311 | |
| 312 | stdarg_h => [], |
| 313 | |
| 314 | stddef_h => [qw(NULL offsetof)], |
| 315 | |
| 316 | stdio_h => [qw(BUFSIZ EOF FILENAME_MAX L_ctermid L_cuserid |
| 317 | L_tmpname NULL SEEK_CUR SEEK_END SEEK_SET |
| 318 | STREAM_MAX TMP_MAX stderr stdin stdout |
| 319 | clearerr fclose fdopen feof ferror fflush fgetc fgetpos |
| 320 | fgets fopen fprintf fputc fputs fread freopen |
| 321 | fscanf fseek fsetpos ftell fwrite getchar gets |
| 322 | perror putc putchar puts remove rewind |
| 323 | scanf setbuf setvbuf sscanf tmpfile tmpnam |
| 324 | ungetc vfprintf vprintf vsprintf)], |
| 325 | |
| 326 | stdlib_h => [qw(EXIT_FAILURE EXIT_SUCCESS MB_CUR_MAX NULL RAND_MAX |
| 327 | abort atexit atof atoi atol bsearch calloc div |
| 328 | free getenv labs ldiv malloc mblen mbstowcs mbtowc |
| 329 | qsort realloc strtod strtol strtoul wcstombs wctomb)], |
| 330 | |
| 331 | string_h => [qw(NULL memchr memcmp memcpy memmove memset strcat |
| 332 | strchr strcmp strcoll strcpy strcspn strerror strlen |
| 333 | strncat strncmp strncpy strpbrk strrchr strspn strstr |
| 334 | strtok strxfrm)], |
| 335 | |
| 336 | sys_stat_h => [qw(S_IRGRP S_IROTH S_IRUSR S_IRWXG S_IRWXO S_IRWXU |
| 337 | S_ISBLK S_ISCHR S_ISDIR S_ISFIFO S_ISGID S_ISREG |
| 338 | S_ISUID S_IWGRP S_IWOTH S_IWUSR S_IXGRP S_IXOTH S_IXUSR |
| 339 | fstat mkfifo)], |
| 340 | |
| 341 | sys_times_h => [], |
| 342 | |
| 343 | sys_types_h => [], |
| 344 | |
| 345 | sys_utsname_h => [qw(uname)], |
| 346 | |
| 347 | sys_wait_h => [qw(WEXITSTATUS WIFEXITED WIFSIGNALED WIFSTOPPED |
| 348 | WNOHANG WSTOPSIG WTERMSIG WUNTRACED)], |
| 349 | |
| 350 | termios_h => [qw( B0 B110 B1200 B134 B150 B1800 B19200 B200 B2400 |
| 351 | B300 B38400 B4800 B50 B600 B75 B9600 BRKINT CLOCAL |
| 352 | CREAD CS5 CS6 CS7 CS8 CSIZE CSTOPB ECHO ECHOE ECHOK |
| 353 | ECHONL HUPCL ICANON ICRNL IEXTEN IGNBRK IGNCR IGNPAR |
| 354 | INLCR INPCK ISIG ISTRIP IXOFF IXON NCCS NOFLSH OPOST |
| 355 | PARENB PARMRK PARODD TCIFLUSH TCIOFF TCIOFLUSH TCION |
| 356 | TCOFLUSH TCOOFF TCOON TCSADRAIN TCSAFLUSH TCSANOW |
| 357 | TOSTOP VEOF VEOL VERASE VINTR VKILL VMIN VQUIT VSTART |
| 358 | VSTOP VSUSP VTIME |
| 359 | cfgetispeed cfgetospeed cfsetispeed cfsetospeed tcdrain |
| 360 | tcflow tcflush tcgetattr tcsendbreak tcsetattr )], |
| 361 | |
| 362 | time_h => [qw(CLK_TCK CLOCKS_PER_SEC NULL asctime clock ctime |
| 363 | difftime mktime strftime strptime tzset tzname)], |
| 364 | |
| 365 | unistd_h => [qw(F_OK NULL R_OK SEEK_CUR SEEK_END SEEK_SET |
| 366 | STDERR_FILENO STDIN_FILENO STDOUT_FILENO W_OK X_OK |
| 367 | _PC_CHOWN_RESTRICTED _PC_LINK_MAX _PC_MAX_CANON |
| 368 | _PC_MAX_INPUT _PC_NAME_MAX _PC_NO_TRUNC _PC_PATH_MAX |
| 369 | _PC_PIPE_BUF _PC_VDISABLE _POSIX_CHOWN_RESTRICTED |
| 370 | _POSIX_JOB_CONTROL _POSIX_NO_TRUNC _POSIX_SAVED_IDS |
| 371 | _POSIX_VDISABLE _POSIX_VERSION _SC_ARG_MAX |
| 372 | _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL |
| 373 | _SC_NGROUPS_MAX _SC_OPEN_MAX _SC_PAGESIZE _SC_SAVED_IDS |
| 374 | _SC_STREAM_MAX _SC_TZNAME_MAX _SC_VERSION |
| 375 | _exit access ctermid cuserid |
| 376 | dup2 dup execl execle execlp execv execve execvp |
| 377 | fpathconf fsync getcwd getegid geteuid getgid getgroups |
| 378 | getpid getuid isatty lseek pathconf pause setgid setpgid |
| 379 | setsid setuid sysconf tcgetpgrp tcsetpgrp ttyname)], |
| 380 | |
| 381 | utime_h => [], |
| 382 | ); |
| 383 | |
| 384 | # Exporter::export_tags(); |
| 385 | { |
| 386 | # De-duplicate the export list: |
| 387 | my %export; |
| 388 | @export{map {@$_} values %EXPORT_TAGS} = (); |
| 389 | |
| 390 | our @EXPORT_OK = (qw(close lchown nice open pipe read sleep times write |
| 391 | printf sprintf), |
| 392 | grep {!exists $export{$_}} keys %reimpl, keys %replacement); |
| 393 | |
| 394 | # Symbols that should not be exported by default because they are recently |
| 395 | # added. It would upset too much of CPAN to export these by default |
| 396 | foreach (qw(strptime)) { |
| 397 | delete $export{$_}; |
| 398 | push @EXPORT_OK, $_; |
| 399 | } |
| 400 | |
| 401 | # Doing the de-dup with a temporary hash has the advantage that the SVs in |
| 402 | # @EXPORT are actually shared hash key scalars, which will save some memory. |
| 403 | our @EXPORT = keys %export; |
| 404 | } |
| 405 | |
| 406 | require Exporter; |
| 407 | } |
| 408 | |
| 409 | package POSIX::SigAction; |
| 410 | |
| 411 | sub new { bless {HANDLER => $_[1], MASK => $_[2], FLAGS => $_[3] || 0, SAFE => 0}, $_[0] } |
| 412 | sub handler { $_[0]->{HANDLER} = $_[1] if @_ > 1; $_[0]->{HANDLER} }; |
| 413 | sub mask { $_[0]->{MASK} = $_[1] if @_ > 1; $_[0]->{MASK} }; |
| 414 | sub flags { $_[0]->{FLAGS} = $_[1] if @_ > 1; $_[0]->{FLAGS} }; |
| 415 | sub safe { $_[0]->{SAFE} = $_[1] if @_ > 1; $_[0]->{SAFE} }; |
| 416 | |
| 417 | { |
| 418 | package POSIX::SigSet; |
| 419 | # This package is here entirely to make sure that POSIX::SigSet is seen by the |
| 420 | # PAUSE indexer, so that it will always be clearly indexed in core. This is to |
| 421 | # prevent the accidental case where a third-party distribution can accidentally |
| 422 | # claim the POSIX::SigSet package, as occurred in 2011-12. -- rjbs, 2011-12-30 |
| 423 | } |
| 424 | |
| 425 | package POSIX::SigRt; |
| 426 | |
| 427 | require Tie::Hash; |
| 428 | |
| 429 | our @ISA = 'Tie::StdHash'; |
| 430 | |
| 431 | our ($_SIGRTMIN, $_SIGRTMAX, $_sigrtn); |
| 432 | |
| 433 | our $SIGACTION_FLAGS = 0; |
| 434 | |
| 435 | sub _init { |
| 436 | $_SIGRTMIN = &POSIX::SIGRTMIN; |
| 437 | $_SIGRTMAX = &POSIX::SIGRTMAX; |
| 438 | $_sigrtn = $_SIGRTMAX - $_SIGRTMIN; |
| 439 | } |
| 440 | |
| 441 | sub _croak { |
| 442 | &_init unless defined $_sigrtn; |
| 443 | die "POSIX::SigRt not available" unless defined $_sigrtn && $_sigrtn > 0; |
| 444 | } |
| 445 | |
| 446 | sub _getsig { |
| 447 | &_croak; |
| 448 | my $rtsig = $_[0]; |
| 449 | # Allow (SIGRT)?MIN( + n)?, a common idiom when doing these things in C. |
| 450 | $rtsig = $_SIGRTMIN + ($1 || 0) |
| 451 | if $rtsig =~ /^(?:(?:SIG)?RT)?MIN(\s*\+\s*(\d+))?$/; |
| 452 | return $rtsig; |
| 453 | } |
| 454 | |
| 455 | sub _exist { |
| 456 | my $rtsig = _getsig($_[1]); |
| 457 | my $ok = $rtsig >= $_SIGRTMIN && $rtsig <= $_SIGRTMAX; |
| 458 | ($rtsig, $ok); |
| 459 | } |
| 460 | |
| 461 | sub _check { |
| 462 | my ($rtsig, $ok) = &_exist; |
| 463 | die "No POSIX::SigRt signal $_[1] (valid range SIGRTMIN..SIGRTMAX, or $_SIGRTMIN..$_SIGRTMAX)" |
| 464 | unless $ok; |
| 465 | return $rtsig; |
| 466 | } |
| 467 | |
| 468 | sub new { |
| 469 | my ($rtsig, $handler, $flags) = @_; |
| 470 | my $sigset = POSIX::SigSet->new($rtsig); |
| 471 | my $sigact = POSIX::SigAction->new($handler, $sigset, $flags); |
| 472 | POSIX::sigaction($rtsig, $sigact); |
| 473 | } |
| 474 | |
| 475 | sub EXISTS { &_exist } |
| 476 | sub FETCH { my $rtsig = &_check; |
| 477 | my $oa = POSIX::SigAction->new(); |
| 478 | POSIX::sigaction($rtsig, undef, $oa); |
| 479 | return $oa->{HANDLER} } |
| 480 | sub STORE { my $rtsig = &_check; new($rtsig, $_[2], $SIGACTION_FLAGS) } |
| 481 | sub DELETE { delete $SIG{ &_check } } |
| 482 | sub CLEAR { &_exist; delete @SIG{ &POSIX::SIGRTMIN .. &POSIX::SIGRTMAX } } |
| 483 | sub SCALAR { &_croak; $_sigrtn + 1 } |
| 484 | |
| 485 | tie %POSIX::SIGRT, 'POSIX::SigRt'; |
| 486 | # and the expression on the line above is true, so we return true. |