1 /* vmsish.h 2 * 3 * VMS-specific C header file for perl5. 4 * 5 * Last revised: 16-Sep-1998 by Charles Bailey bailey@newman.upenn.edu 6 * Version: 5.5.2 7 */ 8 9 #ifndef __vmsish_h_included 10 #define __vmsish_h_included 11 12 #include <descrip.h> /* for dirent struct definitions */ 13 #include <libdef.h> /* status codes for various places */ 14 #include <rmsdef.h> /* at which errno and vaxc$errno are */ 15 #include <ssdef.h> /* explicitly set in the perl source code */ 16 #include <stsdef.h> /* bitmasks for exit status testing */ 17 18 /* Suppress compiler warnings from DECC for VMS-specific extensions: 19 * ADDRCONSTEXT,NEEDCONSTEXT: initialization of data with non-constant values 20 * (e.g. pointer fields of descriptors) 21 */ 22 #if defined(__DECC) || defined(__DECCXX) 23 # pragma message disable (ADDRCONSTEXT,NEEDCONSTEXT) 24 #endif 25 26 /* DEC's C compilers and gcc use incompatible definitions of _to(upp|low)er() */ 27 #ifdef _toupper 28 # undef _toupper 29 #endif 30 #define _toupper(c) (((c) < 'a' || (c) > 'z') ? (c) : (c) & ~040) 31 #ifdef _tolower 32 # undef _tolower 33 #endif 34 #define _tolower(c) (((c) < 'A' || (c) > 'Z') ? (c) : (c) | 040) 35 /* DECC 1.3 has a funny definition of abs; it's fixed in DECC 4.0, so this 36 * can go away once DECC 1.3 isn't in use any more. */ 37 #if defined(__ALPHA) && (defined(__DECC) || defined(__DECCXX)) 38 #undef abs 39 #define abs(__x) __ABS(__x) 40 #undef labs 41 #define labs(__x) __LABS(__x) 42 #endif /* __ALPHA && __DECC */ 43 44 /* Assorted things to look like Unix */ 45 #ifdef __GNUC__ 46 #ifndef _IOLBF /* gcc's stdio.h doesn't define this */ 47 #define _IOLBF 1 48 #endif 49 #endif 50 #include <processes.h> /* for vfork() */ 51 #include <unixio.h> 52 #include <unixlib.h> 53 #include <file.h> /* it's not <sys/file.h>, so don't use I_SYS_FILE */ 54 #if (defined(__DECC) && defined(__DECC_VER) && __DECC_VER > 20000000) || defined(__DECCXX) 55 # include <unistd.h> /* DECC has this; gcc doesn't */ 56 #endif 57 58 #ifdef NO_PERL_TYPEDEFS /* a2p; we don't want Perl's special routines */ 59 # define DONT_MASK_RTL_CALLS 60 #endif 61 62 /* Note that we do, in fact, have this */ 63 #define HAS_GETENV_SV 64 #define HAS_GETENV_LEN 65 66 /* All this stiff is for the x2P programs. Hopefully they'll still work */ 67 #if defined(PERL_FOR_X2P) 68 #ifndef aTHX_ 69 #define aTHX_ 70 #endif 71 #ifndef pTHX_ 72 #define pTHX_ 73 #endif 74 #ifndef pTHX 75 #define pTHX 76 #endif 77 #endif 78 79 #ifndef DONT_MASK_RTL_CALLS 80 # ifdef getenv 81 # undef getenv 82 # endif 83 /* getenv used for regular logical names */ 84 # define getenv(v) Perl_my_getenv(aTHX_ v,TRUE) 85 #endif 86 #ifdef getenv_len 87 # undef getenv_len 88 #endif 89 #define getenv_len(v,l) Perl_my_getenv_len(aTHX_ v,l,TRUE) 90 91 /* DECC introduces this routine in the RTL as of VMS 7.0; for now, 92 * we'll use ours, since it gives us the full VMS exit status. */ 93 #define waitpid my_waitpid 94 95 /* Don't redeclare standard RTL routines in Perl's header files; 96 * VMS history or extensions makes some of the formal protoypes 97 * differ from the common Unix forms. 98 */ 99 #define DONT_DECLARE_STD 1 100 101 /* Our own contribution to PerlShr's global symbols . . . */ 102 #define prime_env_iter Perl_prime_env_iter 103 #define vms_image_init Perl_vms_image_init 104 #define my_tmpfile Perl_my_tmpfile 105 #define vmstrnenv Perl_vmstrnenv 106 #if !defined(PERL_IMPLICIT_CONTEXT) 107 #define my_getenv_len Perl_my_getenv_len 108 #define vmssetenv Perl_vmssetenv 109 #define my_trnlnm Perl_my_trnlnm 110 #define my_setenv Perl_my_setenv 111 #define my_getenv Perl_my_getenv 112 #define tounixspec Perl_tounixspec 113 #define tounixspec_ts Perl_tounixspec_ts 114 #define tovmsspec Perl_tovmsspec 115 #define tovmsspec_ts Perl_tovmsspec_ts 116 #define tounixpath Perl_tounixpath 117 #define tounixpath_ts Perl_tounixpath_ts 118 #define tovmspath Perl_tovmspath 119 #define tovmspath_ts Perl_tovmspath_ts 120 #define do_rmdir Perl_do_rmdir 121 #define fileify_dirspec Perl_fileify_dirspec 122 #define fileify_dirspec_ts Perl_fileify_dirspec_ts 123 #define pathify_dirspec Perl_pathify_dirspec 124 #define pathify_dirspec_ts Perl_pathify_dirspec_ts 125 #define trim_unixpath Perl_trim_unixpath 126 #define opendir Perl_opendir 127 #define rmscopy Perl_rmscopy 128 #define my_mkdir Perl_my_mkdir 129 #define vms_do_aexec Perl_vms_do_aexec 130 #define vms_do_exec Perl_vms_do_exec 131 #define my_waitpid Perl_my_waitpid 132 #define my_crypt Perl_my_crypt 133 #define kill_file Perl_kill_file 134 #define my_utime Perl_my_utime 135 #define my_chdir Perl_my_chdir 136 #define do_aspawn Perl_do_aspawn 137 #define seekdir Perl_seekdir 138 #define my_gmtime Perl_my_gmtime 139 #define my_localtime Perl_my_localtime 140 #define my_time Perl_my_time 141 #define do_spawn Perl_do_spawn 142 #define flex_fstat Perl_flex_fstat 143 #define flex_stat Perl_flex_stat 144 #define cando_by_name Perl_cando_by_name 145 #define my_getpwnam Perl_my_getpwnam 146 #define my_getpwuid Perl_my_getpwuid 147 #define my_flush Perl_my_flush 148 #define readdir Perl_readdir 149 #define readdir_r Perl_readdir_r 150 #else 151 #define my_getenv_len(a,b,c) Perl_my_getenv_len(aTHX_ a,b,c) 152 #define vmssetenv(a,b,c) Perl_vmssetenv(aTHX_ a,b,c) 153 #define my_trnlnm(a,b,c) Perl_my_trnlnm(aTHX_ a,b,c) 154 #define my_setenv(a,b) Perl_my_setenv(aTHX_ a,b) 155 #define my_getenv(a,b) Perl_my_getenv(aTHX_ a,b) 156 #define tounixspec(a,b) Perl_tounixspec(aTHX_ a,b) 157 #define tounixspec_ts(a,b) Perl_tounixspec_ts(aTHX_ a,b) 158 #define tovmsspec(a,b) Perl_tovmsspec(aTHX_ a,b) 159 #define tovmsspec_t(a,b) Perl_tovmsspec_ts(aTHX_ a,b) 160 #define tounixpath(a,b) Perl_tounixpath(aTHX_ a,b) 161 #define tounixpath_ts(a,b) Perl_tounixpath_ts(aTHX_ a,b) 162 #define tovmspath(a,b) Perl_tovmspath(aTHX_ a,b) 163 #define tovmspath_ts(a,b) Perl_tovmspath_ts(aTHX_ a,b) 164 #define do_rmdir(a) Perl_do_rmdir(aTHX_ a) 165 #define fileify_dirspec(a,b) Perl_fileify_dirspec(aTHX_ a,b) 166 #define fileify_dirspec_ts(a,b) Perl_fileify_dirspec_ts(aTHX_ a,b) 167 #define pathify_dirspec Perl_pathify_dirspec 168 #define pathify_dirspec_ts Perl_pathify_dirspec_ts 169 #define rmsexpand(a,b,c,d) Perl_rmsexpand(aTHX_ a,b,c,d) 170 #define rmsexpand_ts(a,b,c,d) Perl_rmsexpand_ts(aTHX_ a,b,c,d) 171 #define trim_unixpath(a,b,c) Perl_trim_unixpath(aTHX_ a,b,c) 172 #define opendir(a) Perl_opendir(aTHX_ a) 173 #define rmscopy(a,b,c) Perl_rmscopy(aTHX_ a,b,c) 174 #define my_mkdir(a,b) Perl_my_mkdir(aTHX_ a,b) 175 #define vms_do_aexec(a,b,c) Perl_vms_do_aexec(aTHX_ a,b,c) 176 #define vms_do_exec(a) Perl_vms_do_exec(aTHX_ a) 177 #define my_waitpid(a,b,c) Perl_my_waitpid(aTHX_ a,b,c) 178 #define my_crypt(a,b) Perl_my_crypt(aTHX_ a,b) 179 #define kill_file(a) Perl_kill_file(aTHX_ a) 180 #define my_utime(a,b) Perl_my_utime(aTHX_ a,b) 181 #define my_chdir(a) Perl_my_chdir(aTHX_ a) 182 #define do_aspawn(a,b,c) Perl_do_aspawn(aTHX_ a,b,c) 183 #define seekdir(a,b) Perl_seekdir(aTHX_ a,b) 184 #define my_gmtime(a) Perl_my_gmtime(aTHX_ a) 185 #define my_localtime(a) Perl_my_localtime(aTHX_ a) 186 #define my_time(a) Perl_my_time(aTHX_ a) 187 #define do_spawn(a) Perl_do_spawn(aTHX_ a) 188 #define flex_fstat(a,b) Perl_flex_fstat(aTHX_ a,b) 189 #define cando_by_name(a,b,c) Perl_cando_by_name(aTHX_ a,b,c) 190 #define flex_stat(a,b) Perl_flex_stat(aTHX_ a,b) 191 #define my_getpwnam(a) Perl_my_getpwnam(aTHX_ a) 192 #define my_getpwuid(a) Perl_my_getpwuid(aTHX_ a) 193 #define my_flush(a) Perl_my_flush(aTHX_ a) 194 #define readdir(a) Perl_readdir(aTHX_ a) 195 #define readdir_r(a,b,c) Perl_readdir_r(aTHX_ a,b,c) 196 #endif 197 #define my_gconvert Perl_my_gconvert 198 #define telldir Perl_telldir 199 #define closedir Perl_closedir 200 #define vmsreaddirversions Perl_vmsreaddirversions 201 #define my_sigemptyset Perl_my_sigemptyset 202 #define my_sigfillset Perl_my_sigfillset 203 #define my_sigaddset Perl_my_sigaddset 204 #define my_sigdelset Perl_my_sigdelset 205 #define my_sigismember Perl_my_sigismember 206 #define my_sigprocmask Perl_my_sigprocmask 207 #define my_vfork Perl_my_vfork 208 #define my_fdopen Perl_my_fdopen 209 #define my_fclose Perl_my_fclose 210 #define my_fwrite Perl_my_fwrite 211 #define my_getpwent() Perl_my_getpwent(aTHX) 212 #define my_endpwent() Perl_my_endpwent(aTHX) 213 #define my_getlogin Perl_my_getlogin 214 #define init_os_extras Perl_init_os_extras 215 216 /* Delete if at all possible, changing protections if necessary. */ 217 #define unlink kill_file 218 219 /* 220 * Intercept calls to fork, so we know whether subsequent calls to 221 * exec should be handled in VMSish or Unixish style. 222 */ 223 #define fork my_vfork 224 #ifndef DONT_MASK_RTL_CALLS /* #defined in vms.c so we see real vfork */ 225 # ifdef vfork 226 # undef vfork 227 # endif 228 # define vfork my_vfork 229 #endif 230 231 /* 232 * Toss in a shim to tmpfile which creates a plain temp file if the 233 * RMS tmp mechanism won't work (e.g. if someone is relying on ACLs 234 * from a specific directory to permit creation of files). 235 */ 236 #ifndef DONT_MASK_RTL_CALLS 237 # define tmpfile Perl_my_tmpfile 238 #endif 239 240 241 /* BIG_TIME: 242 * This symbol is defined if Time_t is an unsigned type on this system. 243 */ 244 #define BIG_TIME 245 246 /* ACME_MESS: 247 * This symbol, if defined, indicates that error messages should be 248 * should be generated in a format that allows the use of the Acme 249 * GUI/editor's autofind feature. 250 */ 251 #undef ACME_MESS /**/ 252 253 /* ALTERNATE_SHEBANG: 254 * This symbol, if defined, contains a "magic" string which may be used 255 * as the first line of a Perl program designed to be executed directly 256 * by name, instead of the standard Unix #!. If ALTERNATE_SHEBANG 257 * begins with a character other then #, then Perl will only treat 258 * it as a command line if if finds the string "perl" in the first 259 * word; otherwise it's treated as the first line of code in the script. 260 * (IOW, Perl won't hand off to another interpreter via an alternate 261 * shebang sequence that might be legal Perl code.) 262 */ 263 #define ALTERNATE_SHEBANG "$" 264 265 /* Lower case entry points for these are missing in some earlier RTLs 266 * so we borrow the defines and declares from errno.h and upcase them. 267 */ 268 #if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 50500000) 269 # define errno (*CMA$TIS_ERRNO_GET_ADDR()) 270 # define vaxc$errno (*CMA$TIS_VMSERRNO_GET_ADDR()) 271 int *CMA$TIS_ERRNO_GET_ADDR (void); /* UNIX style error code */ 272 int *CMA$TIS_VMSERRNO_GET_ADDR (void); /* VMS error (errno == EVMSERR) */ 273 #endif 274 275 /* Macros to set errno using the VAX thread-safe calls, if present */ 276 #if (defined(__DECC) || defined(__DECCXX)) && !defined(__ALPHA) 277 # define set_errno(v) (cma$tis_errno_set_value(v)) 278 void cma$tis_errno_set_value(int __value); /* missing in some errno.h */ 279 # define set_vaxc_errno(v) (vaxc$errno = (v)) 280 #else 281 # define set_errno(v) (errno = (v)) 282 # define set_vaxc_errno(v) (vaxc$errno = (v)) 283 #endif 284 285 /* Support for 'vmsish' behaviors enabled with C<use vmsish> pragma */ 286 287 #define COMPLEX_STATUS 1 /* We track both "POSIX" and VMS values */ 288 289 #define HINT_V_VMSISH 24 290 #define HINT_M_VMSISH_STATUS 0x40000000 /* system, $? return VMS status */ 291 #define HINT_M_VMSISH_TIME 0x80000000 /* times are local, not UTC */ 292 #define NATIVE_HINTS (PL_hints >> HINT_V_VMSISH) /* used in op.c */ 293 294 #define TEST_VMSISH(h) (PL_curcop->op_private & ((h) >> HINT_V_VMSISH)) 295 #define VMSISH_STATUS TEST_VMSISH(HINT_M_VMSISH_STATUS) 296 #define VMSISH_TIME TEST_VMSISH(HINT_M_VMSISH_TIME) 297 298 /* VMS-specific data storage */ 299 300 #define HAVE_INTERP_INTERN 301 struct interp_intern { 302 int hushed; 303 double inv_rand_max; 304 }; 305 #define VMSISH_HUSHED (PL_sys_intern.hushed) 306 #define MY_INV_RAND_MAX (PL_sys_intern.inv_rand_max) 307 308 /* Flags for vmstrnenv() */ 309 #define PERL__TRNENV_SECURE 0x01 310 #define PERL__TRNENV_JOIN_SEARCHLIST 0x02 311 312 /* Handy way to vet calls to VMS system services and RTL routines. */ 313 #define _ckvmssts(call) STMT_START { register unsigned long int __ckvms_sts; \ 314 if (!((__ckvms_sts=(call))&1)) { \ 315 set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \ 316 Perl_croak(aTHX_ "Fatal VMS error (status=%d) at %s, line %d", \ 317 __ckvms_sts,__FILE__,__LINE__); } } STMT_END 318 319 /* Same thing, but don't call back to Perl's croak(); useful for errors 320 * occurring during startup, before Perl's state is initialized */ 321 #define _ckvmssts_noperl(call) STMT_START { register unsigned long int __ckvms_sts; \ 322 if (!((__ckvms_sts=(call))&1)) { \ 323 set_errno(EVMSERR); set_vaxc_errno(__ckvms_sts); \ 324 fprintf(stderr,"Fatal VMS error (status=%d) at %s, line %d", \ 325 __ckvms_sts,__FILE__,__LINE__); lib$signal(__ckvms_sts); } } STMT_END 326 327 #ifdef VMS_DO_SOCKETS 328 #include "sockadapt.h" 329 #define PERL_SOCK_SYSREAD_IS_RECV 330 #define PERL_SOCK_SYSWRITE_IS_SEND 331 #endif 332 333 #define BIT_BUCKET "_NLA0:" 334 #define PERL_SYS_INIT(c,v) MALLOC_CHECK_TAINT2(*c,*v) vms_image_init((c),(v)); MALLOC_INIT 335 #define PERL_SYS_TERM() OP_REFCNT_TERM; MALLOC_TERM 336 #define dXSUB_SYS 337 #define HAS_KILL 338 #define HAS_WAIT 339 340 #define PERL_FS_VER_FMT "%d_%d_%d" 341 /* Temporary; we need to add support for this to Configure.Com */ 342 #ifdef PERL_INC_VERSION_LIST 343 # undef PERL_INC_VERSION_LIST 344 #endif 345 346 /* VMS: 347 * This symbol, if defined, indicates that the program is running under 348 * VMS. It's a symbol automagically defined by all VMS C compilers I've seen. 349 * Just in case, however . . . */ 350 #ifndef VMS 351 #define VMS /**/ 352 #endif 353 354 /* HAS_IOCTL: 355 * This symbol, if defined, indicates that the ioctl() routine is 356 * available to set I/O characteristics 357 */ 358 #if defined(__CRTL_VER) && __CRTL_VER >= 70000000 359 #define HAS_IOCTL /**/ 360 #else 361 #undef HAS_IOCTL /**/ 362 #endif 363 364 /* HAS_UTIME: 365 * This symbol, if defined, indicates that the routine utime() is 366 * available to update the access and modification times of files. 367 */ 368 #define HAS_UTIME /**/ 369 370 /* HAS_GROUP 371 * This symbol, if defined, indicates that the getgrnam() and 372 * getgrgid() routines are available to get group entries. 373 * The getgrent() has a separate definition, HAS_GETGRENT. 374 */ 375 #undef HAS_GROUP /**/ 376 377 /* HAS_PASSWD 378 * This symbol, if defined, indicates that the getpwnam() and 379 * getpwuid() routines are available to get password entries. 380 * The getpwent() has a separate definition, HAS_GETPWENT. 381 */ 382 #define HAS_PASSWD /**/ 383 384 #define HAS_KILL 385 #define HAS_WAIT 386 387 /* USEMYBINMODE 388 * This symbol, if defined, indicates that the program should 389 * use the routine my_binmode(FILE *fp, char iotype, int mode) to insure 390 * that a file is in "binary" mode -- that is, that no translation 391 * of bytes occurs on read or write operations. 392 */ 393 #undef USEMYBINMODE 394 395 /* Stat_t: 396 * This symbol holds the type used to declare buffers for information 397 * returned by stat(). It's usually just struct stat. It may be necessary 398 * to include <sys/stat.h> and <sys/types.h> to get any typedef'ed 399 * information. 400 */ 401 /* VMS: 402 * We need this typedef to point to the new type even if DONT_MASK_RTL_CALLS 403 * is in effect, since Perl's thread.h embeds one of these structs in its 404 * thread data struct, and our struct mystat is a different size from the 405 * regular struct stat (cf. note above about having to pad struct to work 406 * around bug in compiler.) 407 * It's OK to pass one of these to the RTL's stat(), though, since the 408 * fields it fills are the same in each struct. 409 */ 410 #define Stat_t struct mystat 411 412 /* USE_STAT_RDEV: 413 * This symbol is defined if this system has a stat structure declaring 414 * st_rdev 415 * VMS: Field exists in POSIXish version of struct stat(), but is not used. 416 */ 417 #undef USE_STAT_RDEV /**/ 418 419 /* 420 * fwrite1() should be a routine with the same calling sequence as fwrite(), 421 * but which outputs all of the bytes requested as a single stream (unlike 422 * fwrite() itself, which on some systems outputs several distinct records 423 * if the number_of_items parameter is >1). 424 */ 425 #define fwrite1 my_fwrite 426 427 428 #ifndef DONT_MASK_RTL_CALLS 429 # define fwrite my_fwrite /* for PerlSIO_fwrite */ 430 # define fdopen my_fdopen 431 # define fclose my_fclose 432 #endif 433 434 435 /* By default, flush data all the way to disk, not just to RMS buffers */ 436 #define Fflush(fp) my_flush(fp) 437 438 /* Use our own rmdir() */ 439 #define rmdir(name) do_rmdir(name) 440 441 /* Assorted fiddling with sigs . . . */ 442 # include <signal.h> 443 #define ABORT() abort() 444 445 /* Used with our my_utime() routine in vms.c */ 446 struct utimbuf { 447 time_t actime; 448 time_t modtime; 449 }; 450 #define utime my_utime 451 452 /* This is what times() returns, but <times.h> calls it tbuffer_t on VMS 453 * prior to v7.0. We check the DECC manifest to see whether it's already 454 * done this for us, relying on the fact that perl.h #includes <time.h> 455 * before it #includes "vmsish.h". 456 */ 457 458 #ifndef __TMS 459 struct tms { 460 clock_t tms_utime; /* user time */ 461 clock_t tms_stime; /* system time - always 0 on VMS */ 462 clock_t tms_cutime; /* user time, children */ 463 clock_t tms_cstime; /* system time, children - always 0 on VMS */ 464 }; 465 #else 466 /* The new headers change the times() prototype to tms from tbuffer */ 467 # define tbuffer_t struct tms 468 #endif 469 470 /* Substitute our own routines for gmtime(), localtime(), and time(), 471 * which allow us to implement the vmsish 'time' pragma, and work 472 * around absence of system-level UTC support on old versions of VMS. 473 */ 474 #define gmtime(t) my_gmtime(t) 475 #define localtime(t) my_localtime(t) 476 #define time(t) my_time(t) 477 478 /* If we're using an older version of VMS whose Unix signal emulation 479 * isn't very POSIXish, then roll our own. 480 */ 481 #if __VMS_VER < 70000000 || __DECC_VER < 50200000 482 # define HOMEGROWN_POSIX_SIGNALS 483 #endif 484 #ifdef HOMEGROWN_POSIX_SIGNALS 485 # define sigemptyset(t) my_sigemptyset(t) 486 # define sigfillset(t) my_sigfillset(t) 487 # define sigaddset(t, u) my_sigaddset(t, u) 488 # define sigdelset(t, u) my_sigdelset(t, u) 489 # define sigismember(t, u) my_sigismember(t, u) 490 # define sigprocmask(t, u, v) my_sigprocmask(t, u, v) 491 # ifndef _SIGSET_T 492 typedef int sigset_t; 493 # endif 494 /* The tools for sigprocmask() are there, just not the routine itself */ 495 # ifndef SIG_UNBLOCK 496 # define SIG_UNBLOCK 1 497 # endif 498 # ifndef SIG_BLOCK 499 # define SIG_BLOCK 2 500 # endif 501 # ifndef SIG_SETMASK 502 # define SIG_SETMASK 3 503 # endif 504 # define sigaction sigvec 505 # define sa_flags sv_onstack 506 # define sa_handler sv_handler 507 # define sa_mask sv_mask 508 # define sigsuspend(set) sigpause(*set) 509 # define sigpending(a) (not_here("sigpending"),0) 510 #else 511 /* 512 * The C RTL's sigaction fails to check for invalid signal numbers so we 513 * help it out a bit. 514 */ 515 # ifndef DONT_MASK_RTL_CALLS 516 # define sigaction(a,b,c) Perl_my_sigaction(aTHX_ a,b,c) 517 # endif 518 #endif 519 #ifdef KILL_BY_SIGPRC 520 # define kill Perl_my_kill 521 #endif 522 523 524 /* VMS doesn't use a real sys_nerr, but we need this when scanning for error 525 * messages in text strings . . . 526 */ 527 528 #define sys_nerr EVMSERR /* EVMSERR is as high as we can go. */ 529 530 /* Look up new %ENV values on the fly */ 531 #define DYNAMIC_ENV_FETCH 1 532 /* Special getenv function for retrieving %ENV elements. */ 533 #define ENVgetenv(v) my_getenv(v,FALSE) 534 #define ENVgetenv_len(v,l) my_getenv_len(v,l,FALSE) 535 536 537 /* Thin jacket around cuserid() to match Unix' calling sequence */ 538 #define getlogin my_getlogin 539 540 /* Ditto for sys$hash_password() . . . */ 541 #define crypt(a,b) Perl_my_crypt(aTHX_ a,b) 542 543 /* Tweak arg to mkdir & chdir first, so we can tolerate trailing /. */ 544 #define Mkdir(dir,mode) Perl_my_mkdir(aTHX_ (dir),(mode)) 545 #define Chdir(dir) my_chdir((dir)) 546 547 /* Use our own stat() clones, which handle Unix-style directory names */ 548 #define Stat(name,bufptr) flex_stat(name,bufptr) 549 #define Fstat(fd,bufptr) Perl_flex_fstat(aTHX_ fd,bufptr) 550 551 /* Setup for the dirent routines: 552 * opendir(), closedir(), readdir(), seekdir(), telldir(), and 553 * vmsreaddirversions(), and preprocessor stuff on which these depend: 554 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990. 555 */ 556 /* Data structure returned by READDIR(). */ 557 struct dirent { 558 char d_name[256]; /* File name */ 559 int d_namlen; /* Length of d_name */ 560 int vms_verscount; /* Number of versions */ 561 int vms_versions[20]; /* Version numbers */ 562 }; 563 564 /* Handle returned by opendir(), used by the other routines. You 565 * are not supposed to care what's inside this structure. */ 566 typedef struct _dirdesc { 567 long context; 568 int vms_wantversions; 569 unsigned long int count; 570 char *pattern; 571 struct dirent entry; 572 struct dsc$descriptor_s pat; 573 void *mutex; 574 } DIR; 575 576 #define rewinddir(dirp) seekdir((dirp), 0) 577 578 /* used for our emulation of getpw* */ 579 struct passwd { 580 char *pw_name; /* Username */ 581 char *pw_passwd; 582 Uid_t pw_uid; /* UIC member number */ 583 Gid_t pw_gid; /* UIC group number */ 584 char *pw_comment; /* Default device/directory (Unix-style) */ 585 char *pw_gecos; /* Owner */ 586 char *pw_dir; /* Default device/directory (VMS-style) */ 587 char *pw_shell; /* Default CLI name (eg. DCL) */ 588 }; 589 #define pw_unixdir pw_comment /* Default device/directory (Unix-style) */ 590 #define getpwnam my_getpwnam 591 #define getpwuid my_getpwuid 592 #define getpwent my_getpwent 593 #define endpwent my_endpwent 594 #define setpwent my_endpwent 595 596 /* Our own stat_t substitute, since we play with st_dev and st_ino - 597 * we want atomic types so Unix-bound code which compares these fields 598 * for two files will work most of the time under VMS. 599 * N.B. 1. The st_ino hack assumes that sizeof(unsigned short[3]) == 600 * sizeof(unsigned) + sizeof(unsigned short). We can't use a union type 601 * to map the unsigned int we want and the unsigned short[3] the CRTL 602 * returns into the same member, since gcc has different ideas than DECC 603 * and VAXC about sizing union types. 604 * N.B. 2. The routine cando() in vms.c assumes that &stat.st_ino is the 605 * address of a FID. 606 */ 607 /* First, grab the system types, so we don't clobber them later */ 608 #include <stat.h> 609 /* Since we've got to match the size of the CRTL's stat_t, we need 610 * to mimic DECC's alignment settings. 611 */ 612 #ifdef USE_LARGE_FILES 613 /* Mimic the new stat structure, filler fields, and alignment. */ 614 #if defined(__DECC) || defined(__DECCXX) 615 # pragma __member_alignment __save 616 # pragma member_alignment 617 #endif 618 619 struct mystat 620 { 621 char *st_devnam; /* pointer to device name */ 622 char *st_fill_dev; 623 unsigned st_ino; /* hack - CRTL uses unsigned short[3] for */ 624 unsigned short rvn; /* FID (num,seq,rvn) */ 625 unsigned short st_fill_ino; 626 unsigned short st_mode; /* file "mode" i.e. prot, dir, reg, etc. */ 627 unsigned short st_fill_mode; 628 int st_nlink; /* for compatibility - not really used */ 629 unsigned st_uid; /* from ACP - QIO uic field */ 630 unsigned short st_gid; /* group number extracted from st_uid */ 631 unsigned short st_fill_gid; 632 dev_t st_rdev; /* for compatibility - always zero */ 633 off_t st_size; /* file size in bytes */ 634 unsigned st_atime; /* file access time; always same as st_mtime */ 635 unsigned st_fill_atime; 636 unsigned st_mtime; /* last modification time */ 637 unsigned st_fill_mtime; 638 unsigned st_ctime; /* file creation time */ 639 unsigned st_fill_ctime; 640 char st_fab_rfm; /* record format */ 641 char st_fab_rat; /* record attributes */ 642 char st_fab_fsz; /* fixed header size */ 643 char st_fab_fill; 644 unsigned st_fab_mrs; /* record size */ 645 int st_fill_expand[7]; /* will probably fill from beginning, so put our st_dev at end */ 646 unsigned st_dev; /* encoded device name */ 647 }; 648 649 #else /* !defined(USE_LARGE_FILES) */ 650 651 #if defined(__DECC) || defined(__DECCXX) 652 # pragma __member_alignment __save 653 # pragma __nomember_alignment 654 #endif 655 #if defined(__DECC) 656 # pragma __message __save 657 # pragma __message disable (__MISALGNDSTRCT) 658 # pragma __message disable (__MISALGNDMEM) 659 #endif 660 661 struct mystat 662 { 663 char *st_devnam; /* pointer to device name */ 664 unsigned st_ino; /* hack - CRTL uses unsigned short[3] for */ 665 unsigned short rvn; /* FID (num,seq,rvn) */ 666 unsigned short st_mode; /* file "mode" i.e. prot, dir, reg, etc. */ 667 int st_nlink; /* for compatibility - not really used */ 668 unsigned st_uid; /* from ACP - QIO uic field */ 669 unsigned short st_gid; /* group number extracted from st_uid */ 670 dev_t st_rdev; /* for compatibility - always zero */ 671 off_t st_size; /* file size in bytes */ 672 unsigned st_atime; /* file access time; always same as st_mtime */ 673 unsigned st_mtime; /* last modification time */ 674 unsigned st_ctime; /* file creation time */ 675 char st_fab_rfm; /* record format */ 676 char st_fab_rat; /* record attributes */ 677 char st_fab_fsz; /* fixed header size */ 678 unsigned st_dev; /* encoded device name */ 679 /* Pad struct out to integral number of longwords, since DECC 5.6/VAX 680 * has a bug in dealing with offsets in structs in which are embedded 681 * other structs whose size is an odd number of bytes. (An even 682 * number of bytes is enough to make it happy, but we go for natural 683 * alignment anyhow.) 684 */ 685 char st_fill1[sizeof(void *) - (3*sizeof(unsigned short) + 3*sizeof(char))%sizeof(void *)]; 686 }; 687 688 #if defined(__DECC) 689 # pragma __message __restore 690 #endif 691 692 #endif /* defined(USE_LARGE_FILES) */ 693 694 #if defined(__DECC) || defined(__DECCXX) 695 # pragma __member_alignment __restore 696 #endif 697 698 typedef unsigned mydev_t; 699 typedef unsigned myino_t; 700 701 /* 702 * DEC C previous to 6.0 corrupts the behavior of the /prefix 703 * qualifier with the extern prefix pragma. This provisional 704 * hack circumvents this prefix pragma problem in previous 705 * precompilers. 706 */ 707 #if defined(__VMS_VER) && __VMS_VER >= 70000000 708 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000) 709 # pragma __extern_prefix save 710 # pragma __extern_prefix "" /* set to empty to prevent prefixing */ 711 # define geteuid decc$__unix_geteuid 712 # define getuid decc$__unix_getuid 713 # define stat(__p1,__p2) decc$__utc_stat(__p1,__p2) 714 # define fstat(__p1,__p2) decc$__utc_fstat(__p1,__p2) 715 # pragma __extern_prefix restore 716 # endif 717 #endif 718 719 #ifndef DONT_MASK_RTL_CALLS /* defined for vms.c so we can see RTL calls */ 720 # ifdef stat 721 # undef stat 722 # endif 723 # define stat mystat 724 # define dev_t mydev_t 725 # define ino_t myino_t 726 #endif 727 /* Cons up a 'delete' bit for testing access */ 728 #define S_IDUSR (S_IWUSR | S_IXUSR) 729 #define S_IDGRP (S_IWGRP | S_IXGRP) 730 #define S_IDOTH (S_IWOTH | S_IXOTH) 731 732 733 /* Prototypes for functions unique to vms.c. Don't include replacements 734 * for routines in the mainline source files excluded by #ifndef VMS; 735 * their prototypes are already in proto.h. 736 * 737 * In order to keep Gen_ShrFls.Pl happy, functions which are to be made 738 * available to images linked to PerlShr.Exe must be declared between the 739 * __VMS_PROTOTYPES__ and __VMS_SEPYTOTORP__ lines, and must be in the form 740 * <data type><TAB>name<WHITESPACE>(<prototype args>); 741 */ 742 743 #ifdef NO_PERL_TYPEDEFS 744 /* We don't have Perl typedefs available (e.g. when building a2p), so 745 we fake them here. N.B. There is *no* guarantee that the faked 746 prototypes will actually match the real routines. If you want to 747 call Perl routines, include perl.h to get the real typedefs. */ 748 # ifndef bool 749 # define bool int 750 # define __MY_BOOL_TYPE_FAKE 751 # endif 752 # ifndef I32 753 # define I32 int 754 # define __MY_I32_TYPE_FAKE 755 # endif 756 # ifndef SV 757 # define SV void /* Since we only see SV * in prototypes */ 758 # define __MY_SV_TYPE_FAKE 759 # endif 760 #endif 761 762 void prime_env_iter (void); 763 void init_os_extras (); 764 /* prototype section start marker; `typedef' passes through cpp */ 765 typedef char __VMS_PROTOTYPES__; 766 int Perl_vmstrnenv (const char *, char *, unsigned long int, struct dsc$descriptor_s **, unsigned long int); 767 #if !defined(PERL_IMPLICIT_CONTEXT) 768 char * Perl_my_getenv (const char *, bool); 769 int Perl_my_trnlnm (const char *, char *, unsigned long int); 770 char * Perl_tounixspec (char *, char *); 771 char * Perl_tounixspec_ts (char *, char *); 772 char * Perl_tovmsspec (char *, char *); 773 char * Perl_tovmsspec_ts (char *, char *); 774 char * Perl_tounixpath (char *, char *); 775 char * Perl_tounixpath_ts (char *, char *); 776 char * Perl_tovmspath (char *, char *); 777 char * Perl_tovmspath_ts (char *, char *); 778 int Perl_do_rmdir (char *); 779 char * Perl_fileify_dirspec (char *, char *); 780 char * Perl_fileify_dirspec_ts (char *, char *); 781 char * Perl_pathify_dirspec (char *, char *); 782 char * Perl_pathify_dirspec_ts (char *, char *); 783 char * Perl_rmsexpand (char *, char *, char *, unsigned); 784 char * Perl_rmsexpand_ts (char *, char *, char *, unsigned); 785 int Perl_trim_unixpath (char *, char*, int); 786 DIR * Perl_opendir (char *); 787 int Perl_rmscopy (char *, char *, int); 788 int Perl_my_mkdir (char *, Mode_t); 789 bool Perl_vms_do_aexec (SV *, SV **, SV **); 790 #else 791 char * Perl_my_getenv (pTHX_ const char *, bool); 792 int Perl_my_trnlnm (pTHX_ const char *, char *, unsigned long int); 793 char * Perl_tounixspec (pTHX_ char *, char *); 794 char * Perl_tounixspec_ts (pTHX_ char *, char *); 795 char * Perl_tovmsspec (pTHX_ char *, char *); 796 char * Perl_tovmsspec_ts (pTHX_ char *, char *); 797 char * Perl_tounixpath (pTHX_ char *, char *); 798 char * Perl_tounixpath_ts (pTHX_ char *, char *); 799 char * Perl_tovmspath (pTHX_ char *, char *); 800 char * Perl_tovmspath_ts (pTHX_ char *, char *); 801 int Perl_do_rmdir (pTHX_ char *); 802 char * Perl_fileify_dirspec (pTHX_ char *, char *); 803 char * Perl_fileify_dirspec_ts (pTHX_ char *, char *); 804 char * Perl_pathify_dirspec (pTHX_ char *, char *); 805 char * Perl_pathify_dirspec_ts (pTHX_ char *, char *); 806 char * Perl_rmsexpand (pTHX_ char *, char *, char *, unsigned); 807 char * Perl_rmsexpand_ts (pTHX_ char *, char *, char *, unsigned); 808 int Perl_trim_unixpath (pTHX_ char *, char*, int); 809 DIR * Perl_opendir (pTHX_ char *); 810 int Perl_rmscopy (pTHX_ char *, char *, int); 811 int Perl_my_mkdir (pTHX_ char *, Mode_t); 812 bool Perl_vms_do_aexec (pTHX_ SV *, SV **, SV **); 813 #endif 814 char * Perl_my_getenv_len (pTHX_ const char *, unsigned long *, bool); 815 int Perl_vmssetenv (pTHX_ char *, char *, struct dsc$descriptor_s **); 816 void Perl_vmssetuserlnm(pTHX_ char *name, char *eqv); 817 char * Perl_my_crypt (pTHX_ const char *, const char *); 818 Pid_t Perl_my_waitpid (pTHX_ Pid_t, int *, int); 819 char * my_gconvert (double, int, int, char *); 820 int Perl_kill_file (pTHX_ char *); 821 int Perl_my_chdir (pTHX_ char *); 822 FILE * Perl_my_tmpfile (); 823 #ifndef HOMEGROWN_POSIX_SIGNALS 824 int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*); 825 #endif 826 #ifdef KILL_BY_SIGPRC 827 unsigned int Perl_sig_to_vmscondition (int); 828 int Perl_my_kill (int, int); 829 void Perl_csighandler_init (void); 830 #endif 831 int Perl_my_utime (pTHX_ char *, struct utimbuf *); 832 void Perl_vms_image_init (int *, char ***); 833 struct dirent * Perl_readdir (pTHX_ DIR *); 834 int Perl_readdir_r(pTHX_ DIR *, struct dirent *, struct dirent **); 835 long telldir (DIR *); 836 void Perl_seekdir (pTHX_ DIR *, long); 837 void closedir (DIR *); 838 void vmsreaddirversions (DIR *, int); 839 struct tm * Perl_my_gmtime (pTHX_ const time_t *); 840 struct tm * Perl_my_localtime (pTHX_ const time_t *); 841 time_t Perl_my_time (pTHX_ time_t *); 842 #ifdef HOMEGROWN_POSIX_SIGNALS 843 int my_sigemptyset (sigset_t *); 844 int my_sigfillset (sigset_t *); 845 int my_sigaddset (sigset_t *, int); 846 int my_sigdelset (sigset_t *, int); 847 int my_sigismember (sigset_t *, int); 848 int my_sigprocmask (int, sigset_t *, sigset_t *); 849 #endif 850 I32 Perl_cando_by_name (pTHX_ I32, Uid_t, char *); 851 int Perl_flex_fstat (pTHX_ int, Stat_t *); 852 int Perl_flex_stat (pTHX_ const char *, Stat_t *); 853 int my_vfork (); 854 bool Perl_vms_do_exec (pTHX_ char *); 855 unsigned long int Perl_do_aspawn (pTHX_ void *, void **, void **); 856 unsigned long int Perl_do_spawn (pTHX_ char *); 857 FILE * my_fdopen (int, const char *); 858 int my_fclose (FILE *); 859 int my_fwrite (const void *, size_t, size_t, FILE *); 860 int Perl_my_flush (pTHX_ FILE *); 861 struct passwd * Perl_my_getpwnam (pTHX_ char *name); 862 struct passwd * Perl_my_getpwuid (pTHX_ Uid_t uid); 863 void Perl_my_endpwent (pTHX); 864 char * my_getlogin (void); 865 typedef char __VMS_SEPYTOTORP__; 866 /* prototype section end marker; `typedef' passes through cpp */ 867 868 #ifdef NO_PERL_TYPEDEFS /* We'll try not to scramble later files */ 869 # ifdef __MY_BOOL_TYPE_FAKE 870 # undef bool 871 # undef __MY_BOOL_TYPE_FAKE 872 # endif 873 # ifdef __MY_I32_TYPE_FAKE 874 # undef I32 875 # undef __MY_I32_TYPE_FAKE 876 # endif 877 # ifdef __MY_SV_TYPE_FAKE 878 # undef SV 879 # undef __MY_SV_TYPE_FAKE 880 # endif 881 #endif 882 883 #ifndef VMS_DO_SOCKETS 884 /* This relies on tricks in perl.h to pick up that these manifest constants 885 * are undefined and set up conversion routines. It will then redefine 886 * these manifest constants, so the actual values will match config.h 887 */ 888 #undef HAS_HTONS 889 #undef HAS_NTOHS 890 #undef HAS_HTONL 891 #undef HAS_NTOHL 892 #endif 893 894 /* The C RTL manual says to undef the macro for DEC C 5.2 and lower. */ 895 #if defined(fileno) && defined(__DECC_VER) && __DECC_VER < 50300000 896 # undef fileno 897 #endif 898 899 #define NO_ENVIRON_ARRAY 900 901 #endif /* __vmsish_h_included */ 902