3 * VMS-specific routines for perl5
5 * Copyright (C) 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001,
6 * 2002, 2003, 2004, 2005, 2006, 2007 by Charles Bailey and others.
8 * You may distribute under the terms of either the GNU General Public
9 * License or the Artistic License, as specified in the README file.
11 * Please see Changes*.* or the Perl Repository Browser for revision history.
15 * Yet small as was their hunted band
16 * still fell and fearless was each hand,
17 * and strong deeds they wrought yet oft,
18 * and loved the woods, whose ways more soft
19 * them seemed than thralls of that black throne
20 * to live and languish in halls of stone.
21 * "The Lay of Leithian", Canto II, lines 135-40
23 * [p.162 of _The Lays of Beleriand_]
32 #include <climsgdef.h>
43 #include <libclidef.h>
45 #include <lib$routines.h>
49 #if __CRTL_VER >= 70301000 && !defined(__VAX)
59 #include <str$routines.h>
66 #if __CRTL_VER >= 70000000 /* FIXME to earliest version */
68 #define NO_EFN EFN$C_ENF
73 #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000
74 int decc$feature_get_index(const char *name);
75 char* decc$feature_get_name(int index);
76 int decc$feature_get_value(int index, int mode);
77 int decc$feature_set_value(int index, int mode, int value);
82 #pragma member_alignment save
83 #pragma nomember_alignment longword
88 unsigned short * retadr;
90 #pragma member_alignment restore
92 /* More specific prototype than in starlet_c.h makes programming errors
100 const struct dsc$descriptor_s * devnam,
101 const struct item_list_3 * itmlst,
103 void * (astadr)(unsigned long),
108 #ifdef sys$get_security
109 #undef sys$get_security
111 (const struct dsc$descriptor_s * clsnam,
112 const struct dsc$descriptor_s * objnam,
113 const unsigned int *objhan,
115 const struct item_list_3 * itmlst,
116 unsigned int * contxt,
117 const unsigned int * acmode);
120 #ifdef sys$set_security
121 #undef sys$set_security
123 (const struct dsc$descriptor_s * clsnam,
124 const struct dsc$descriptor_s * objnam,
125 const unsigned int *objhan,
127 const struct item_list_3 * itmlst,
128 unsigned int * contxt,
129 const unsigned int * acmode);
132 #ifdef lib$find_image_symbol
133 #undef lib$find_image_symbol
134 int lib$find_image_symbol
135 (const struct dsc$descriptor_s * imgname,
136 const struct dsc$descriptor_s * symname,
138 const struct dsc$descriptor_s * defspec,
142 #ifdef lib$rename_file
143 #undef lib$rename_file
145 (const struct dsc$descriptor_s * old_file_dsc,
146 const struct dsc$descriptor_s * new_file_dsc,
147 const struct dsc$descriptor_s * default_file_dsc,
148 const struct dsc$descriptor_s * related_file_dsc,
149 const unsigned long * flags,
150 void * (success)(const struct dsc$descriptor_s * old_dsc,
151 const struct dsc$descriptor_s * new_dsc,
153 void * (error)(const struct dsc$descriptor_s * old_dsc,
154 const struct dsc$descriptor_s * new_dsc,
157 const int * error_src,
158 const void * usr_arg),
159 int (confirm)(const struct dsc$descriptor_s * old_dsc,
160 const struct dsc$descriptor_s * new_dsc,
161 const void * old_fab,
162 const void * usr_arg),
164 struct dsc$descriptor_s * old_result_name_dsc,
165 struct dsc$descriptor_s * new_result_name_dsc,
166 unsigned long * file_scan_context);
169 #if __CRTL_VER >= 70300000 && !defined(__VAX)
171 static int set_feature_default(const char *name, int value)
176 index = decc$feature_get_index(name);
178 status = decc$feature_set_value(index, 1, value);
179 if (index == -1 || (status == -1)) {
183 status = decc$feature_get_value(index, 1);
184 if (status != value) {
192 /* Older versions of ssdef.h don't have these */
193 #ifndef SS$_INVFILFOROP
194 # define SS$_INVFILFOROP 3930
196 #ifndef SS$_NOSUCHOBJECT
197 # define SS$_NOSUCHOBJECT 2696
200 /* We implement I/O here, so we will be mixing PerlIO and stdio calls. */
201 #define PERLIO_NOT_STDIO 0
203 /* Don't replace system definitions of vfork, getenv, lstat, and stat,
204 * code below needs to get to the underlying CRTL routines. */
205 #define DONT_MASK_RTL_CALLS
209 /* Anticipating future expansion in lexical warnings . . . */
210 #ifndef WARN_INTERNAL
211 # define WARN_INTERNAL WARN_MISC
214 #ifdef VMS_LONGNAME_SUPPORT
215 #include <libfildef.h>
218 #if defined(__VMS_VER) && __VMS_VER >= 70000000 && __DECC_VER >= 50200000
219 # define RTL_USES_UTC 1
222 /* Routine to create a decterm for use with the Perl debugger */
223 /* No headers, this information was found in the Programming Concepts Manual */
225 static int (*decw_term_port)
226 (const struct dsc$descriptor_s * display,
227 const struct dsc$descriptor_s * setup_file,
228 const struct dsc$descriptor_s * customization,
229 struct dsc$descriptor_s * result_device_name,
230 unsigned short * result_device_name_length,
233 void * char_change_buffer) = 0;
235 /* gcc's header files don't #define direct access macros
236 * corresponding to VAXC's variant structs */
238 # define uic$v_format uic$r_uic_form.uic$v_format
239 # define uic$v_group uic$r_uic_form.uic$v_group
240 # define uic$v_member uic$r_uic_form.uic$v_member
241 # define prv$v_bypass prv$r_prvdef_bits0.prv$v_bypass
242 # define prv$v_grpprv prv$r_prvdef_bits0.prv$v_grpprv
243 # define prv$v_readall prv$r_prvdef_bits0.prv$v_readall
244 # define prv$v_sysprv prv$r_prvdef_bits0.prv$v_sysprv
247 #if defined(NEED_AN_H_ERRNO)
252 #pragma message disable pragma
253 #pragma member_alignment save
254 #pragma nomember_alignment longword
256 #pragma message disable misalgndmem
259 unsigned short int buflen;
260 unsigned short int itmcode;
262 unsigned short int *retlen;
265 struct filescan_itmlst_2 {
266 unsigned short length;
267 unsigned short itmcode;
272 unsigned short length;
277 #pragma message restore
278 #pragma member_alignment restore
281 #define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d)
282 #define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d)
283 #define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d)
284 #define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d)
285 #define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g)
286 #define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c)
287 #define do_vms_realname(a,b,c) mp_do_vms_realname(aTHX_ a,b,c)
288 #define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d)
289 #define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d)
290 #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a)
291 #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d)
292 #define getredirection(a,b) mp_getredirection(aTHX_ a,b)
294 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *);
295 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *);
296 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
297 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *);
299 static char * int_rmsexpand_vms(
300 const char * filespec, char * outbuf, unsigned opts);
301 static char * int_rmsexpand_tovms(
302 const char * filespec, char * outbuf, unsigned opts);
303 static char *int_tovmsspec
304 (const char *path, char *buf, int dir_flag, int * utf8_flag);
305 static char * int_tounixspec(const char *spec, char *buf, int * utf8_fl);
307 /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */
308 #define PERL_LNM_MAX_ALLOWED_INDEX 127
310 /* OpenVMS User's Guide says at least 9 iterative translations will be performed,
311 * depending on the facility. SHOW LOGICAL does 10, so we'll imitate that for
314 #define PERL_LNM_MAX_ITER 10
316 /* New values with 7.3-2*/ /* why does max DCL have 4 byte subtracted from it? */
317 #if __CRTL_VER >= 70302000 && !defined(__VAX)
318 #define MAX_DCL_SYMBOL (8192)
319 #define MAX_DCL_LINE_LENGTH (4096 - 4)
321 #define MAX_DCL_SYMBOL (1024)
322 #define MAX_DCL_LINE_LENGTH (1024 - 4)
325 static char *__mystrtolower(char *str)
327 if (str) for (; *str; ++str) *str= tolower(*str);
331 static struct dsc$descriptor_s fildevdsc =
332 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "LNM$FILE_DEV" };
333 static struct dsc$descriptor_s crtlenvdsc =
334 { 8, DSC$K_DTYPE_T, DSC$K_CLASS_S, "CRTL_ENV" };
335 static struct dsc$descriptor_s *fildev[] = { &fildevdsc, NULL };
336 static struct dsc$descriptor_s *defenv[] = { &fildevdsc, &crtlenvdsc, NULL };
337 static struct dsc$descriptor_s **env_tables = defenv;
338 static bool will_taint = FALSE; /* tainting active, but no PL_curinterp yet */
340 /* True if we shouldn't treat barewords as logicals during directory */
342 static int no_translate_barewords;
345 static int tz_updated = 1;
348 /* DECC Features that may need to affect how Perl interprets
349 * displays filename information
351 static int decc_disable_to_vms_logname_translation = 1;
352 static int decc_disable_posix_root = 1;
353 int decc_efs_case_preserve = 0;
354 static int decc_efs_charset = 0;
355 static int decc_efs_charset_index = -1;
356 static int decc_filename_unix_no_version = 0;
357 static int decc_filename_unix_only = 0;
358 int decc_filename_unix_report = 0;
359 int decc_posix_compliant_pathnames = 0;
360 int decc_readdir_dropdotnotype = 0;
361 static int vms_process_case_tolerant = 1;
362 int vms_vtf7_filenames = 0;
363 int gnv_unix_shell = 0;
364 static int vms_unlink_all_versions = 0;
365 static int vms_posix_exit = 0;
367 /* bug workarounds if needed */
368 int decc_bug_devnull = 1;
369 int decc_dir_barename = 0;
370 int vms_bug_stat_filename = 0;
372 static int vms_debug_on_exception = 0;
373 static int vms_debug_fileify = 0;
375 /* Simple logical name translation */
376 static int simple_trnlnm
377 (const char * logname,
381 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
382 const unsigned long attr = LNM$M_CASE_BLIND;
383 struct dsc$descriptor_s name_dsc;
385 unsigned short result;
386 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
389 name_dsc.dsc$w_length = strlen(logname);
390 name_dsc.dsc$a_pointer = (char *)logname;
391 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
392 name_dsc.dsc$b_class = DSC$K_CLASS_S;
394 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
396 if ($VMS_STATUS_SUCCESS(status)) {
398 /* Null terminate and return the string */
399 /*--------------------------------------*/
408 /* Is this a UNIX file specification?
409 * No longer a simple check with EFS file specs
410 * For now, not a full check, but need to
411 * handle POSIX ^UP^ specifications
412 * Fixing to handle ^/ cases would require
413 * changes to many other conversion routines.
416 static int is_unix_filespec(const char *path)
422 if (strncmp(path,"\"^UP^",5) != 0) {
423 pch1 = strchr(path, '/');
428 /* If the user wants UNIX files, "." needs to be treated as in UNIX */
429 if (decc_filename_unix_report || decc_filename_unix_only) {
430 if (strcmp(path,".") == 0)
438 /* This routine converts a UCS-2 character to be VTF-7 encoded.
441 static void ucs2_to_vtf7
443 unsigned long ucs2_char,
446 unsigned char * ucs_ptr;
449 ucs_ptr = (unsigned char *)&ucs2_char;
453 hex = (ucs_ptr[1] >> 4) & 0xf;
455 outspec[2] = hex + '0';
457 outspec[2] = (hex - 9) + 'A';
458 hex = ucs_ptr[1] & 0xF;
460 outspec[3] = hex + '0';
462 outspec[3] = (hex - 9) + 'A';
464 hex = (ucs_ptr[0] >> 4) & 0xf;
466 outspec[4] = hex + '0';
468 outspec[4] = (hex - 9) + 'A';
469 hex = ucs_ptr[1] & 0xF;
471 outspec[5] = hex + '0';
473 outspec[5] = (hex - 9) + 'A';
479 /* This handles the conversion of a UNIX extended character set to a ^
480 * escaped VMS character.
481 * in a UNIX file specification.
483 * The output count variable contains the number of characters added
484 * to the output string.
486 * The return value is the number of characters read from the input string
488 static int copy_expand_unix_filename_escape
489 (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl)
497 utf8_flag = *utf8_fl;
501 if (*inspec >= 0x80) {
502 if (utf8_fl && vms_vtf7_filenames) {
503 unsigned long ucs_char;
507 if ((*inspec & 0xE0) == 0xC0) {
509 ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f);
510 if (ucs_char >= 0x80) {
511 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
514 } else if ((*inspec & 0xF0) == 0xE0) {
516 ucs_char = ((inspec[0] & 0xF) << 12) +
517 ((inspec[1] & 0x3f) << 6) +
519 if (ucs_char >= 0x800) {
520 ucs2_to_vtf7(outspec, ucs_char, output_cnt);
524 #if 0 /* I do not see longer sequences supported by OpenVMS */
525 /* Maybe some one can fix this later */
526 } else if ((*inspec & 0xF8) == 0xF0) {
529 } else if ((*inspec & 0xFC) == 0xF8) {
532 } else if ((*inspec & 0xFE) == 0xFC) {
539 /* High bit set, but not a Unicode character! */
541 /* Non printing DECMCS or ISO Latin-1 character? */
542 if (*inspec <= 0x9F) {
546 hex = (*inspec >> 4) & 0xF;
548 outspec[1] = hex + '0';
550 outspec[1] = (hex - 9) + 'A';
554 outspec[2] = hex + '0';
556 outspec[2] = (hex - 9) + 'A';
560 } else if (*inspec == 0xA0) {
566 } else if (*inspec == 0xFF) {
578 /* Is this a macro that needs to be passed through?
579 * Macros start with $( and an alpha character, followed
580 * by a string of alpha numeric characters ending with a )
581 * If this does not match, then encode it as ODS-5.
583 if ((inspec[0] == '$') && (inspec[1] == '(')) {
586 if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) {
588 outspec[0] = inspec[0];
589 outspec[1] = inspec[1];
590 outspec[2] = inspec[2];
592 while(isalnum(inspec[tcnt]) ||
593 (inspec[2] == '.') || (inspec[2] == '_')) {
594 outspec[tcnt] = inspec[tcnt];
597 if (inspec[tcnt] == ')') {
598 outspec[tcnt] = inspec[tcnt];
615 if (decc_efs_charset == 0)
642 /* Don't escape again if following character is
643 * already something we escape.
645 if (strchr(".~!#&\'`()+@{},;[]%^=_\\", *(inspec+1))) {
651 /* But otherwise fall through and escape it. */
653 /* Assume that this is to be escaped */
655 outspec[1] = *inspec;
659 case ' ': /* space */
660 /* Assume that this is to be escaped */
675 /* This handles the expansion of a '^' prefix to the proper character
676 * in a UNIX file specification.
678 * The output count variable contains the number of characters added
679 * to the output string.
681 * The return value is the number of characters read from the input
684 static int copy_expand_vms_filename_escape
685 (char *outspec, const char *inspec, int *output_cnt)
692 if (*inspec == '^') {
695 /* Spaces and non-trailing dots should just be passed through,
696 * but eat the escape character.
703 case '_': /* space */
709 /* Hmm. Better leave the escape escaped. */
715 case 'U': /* Unicode - FIX-ME this is wrong. */
718 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
721 scnt = sscanf(inspec, "%2x%2x", &c1, &c2);
722 outspec[0] == c1 & 0xff;
723 outspec[1] == c2 & 0xff;
730 /* Error - do best we can to continue */
740 scnt = strspn(inspec, "0123456789ABCDEFabcdef");
744 scnt = sscanf(inspec, "%2x", &c1);
745 outspec[0] = c1 & 0xff;
769 (const struct dsc$descriptor_s * srcstr,
770 struct filescan_itmlst_2 * valuelist,
771 unsigned long * fldflags,
772 struct dsc$descriptor_s *auxout,
773 unsigned short * retlen);
776 /* vms_split_path - Verify that the input file specification is a
777 * VMS format file specification, and provide pointers to the components of
778 * it. With EFS format filenames, this is virtually the only way to
779 * parse a VMS path specification into components.
781 * If the sum of the components do not add up to the length of the
782 * string, then the passed file specification is probably a UNIX style
785 static int vms_split_path
800 struct dsc$descriptor path_desc;
804 struct filescan_itmlst_2 item_list[9];
805 const int filespec = 0;
806 const int nodespec = 1;
807 const int devspec = 2;
808 const int rootspec = 3;
809 const int dirspec = 4;
810 const int namespec = 5;
811 const int typespec = 6;
812 const int verspec = 7;
814 /* Assume the worst for an easy exit */
829 path_desc.dsc$a_pointer = (char *)path; /* cast ok */
830 path_desc.dsc$w_length = strlen(path);
831 path_desc.dsc$b_dtype = DSC$K_DTYPE_T;
832 path_desc.dsc$b_class = DSC$K_CLASS_S;
834 /* Get the total length, if it is shorter than the string passed
835 * then this was probably not a VMS formatted file specification
837 item_list[filespec].itmcode = FSCN$_FILESPEC;
838 item_list[filespec].length = 0;
839 item_list[filespec].component = NULL;
841 /* If the node is present, then it gets considered as part of the
842 * volume name to hopefully make things simple.
844 item_list[nodespec].itmcode = FSCN$_NODE;
845 item_list[nodespec].length = 0;
846 item_list[nodespec].component = NULL;
848 item_list[devspec].itmcode = FSCN$_DEVICE;
849 item_list[devspec].length = 0;
850 item_list[devspec].component = NULL;
852 /* root is a special case, adding it to either the directory or
853 * the device components will probalby complicate things for the
854 * callers of this routine, so leave it separate.
856 item_list[rootspec].itmcode = FSCN$_ROOT;
857 item_list[rootspec].length = 0;
858 item_list[rootspec].component = NULL;
860 item_list[dirspec].itmcode = FSCN$_DIRECTORY;
861 item_list[dirspec].length = 0;
862 item_list[dirspec].component = NULL;
864 item_list[namespec].itmcode = FSCN$_NAME;
865 item_list[namespec].length = 0;
866 item_list[namespec].component = NULL;
868 item_list[typespec].itmcode = FSCN$_TYPE;
869 item_list[typespec].length = 0;
870 item_list[typespec].component = NULL;
872 item_list[verspec].itmcode = FSCN$_VERSION;
873 item_list[verspec].length = 0;
874 item_list[verspec].component = NULL;
876 item_list[8].itmcode = 0;
877 item_list[8].length = 0;
878 item_list[8].component = NULL;
880 status = sys$filescan
881 ((const struct dsc$descriptor_s *)&path_desc, item_list,
883 _ckvmssts_noperl(status); /* All failure status values indicate a coding error */
885 /* If we parsed it successfully these two lengths should be the same */
886 if (path_desc.dsc$w_length != item_list[filespec].length)
889 /* If we got here, then it is a VMS file specification */
892 /* set the volume name */
893 if (item_list[nodespec].length > 0) {
894 *volume = item_list[nodespec].component;
895 *vol_len = item_list[nodespec].length + item_list[devspec].length;
898 *volume = item_list[devspec].component;
899 *vol_len = item_list[devspec].length;
902 *root = item_list[rootspec].component;
903 *root_len = item_list[rootspec].length;
905 *dir = item_list[dirspec].component;
906 *dir_len = item_list[dirspec].length;
908 /* Now fun with versions and EFS file specifications
909 * The parser can not tell the difference when a "." is a version
910 * delimiter or a part of the file specification.
912 if ((decc_efs_charset) &&
913 (item_list[verspec].length > 0) &&
914 (item_list[verspec].component[0] == '.')) {
915 *name = item_list[namespec].component;
916 *name_len = item_list[namespec].length + item_list[typespec].length;
917 *ext = item_list[verspec].component;
918 *ext_len = item_list[verspec].length;
923 *name = item_list[namespec].component;
924 *name_len = item_list[namespec].length;
925 *ext = item_list[typespec].component;
926 *ext_len = item_list[typespec].length;
927 *version = item_list[verspec].component;
928 *ver_len = item_list[verspec].length;
933 /* Routine to determine if the file specification ends with .dir */
934 static int is_dir_ext(char * e_spec, int e_len, char * vs_spec, int vs_len) {
936 /* e_len must be 4, and version must be <= 2 characters */
937 if (e_len != 4 || vs_len > 2)
940 /* If a version number is present, it needs to be one */
941 if ((vs_len == 2) && (vs_spec[1] != '1'))
944 /* Look for the DIR on the extension */
945 if (vms_process_case_tolerant) {
946 if ((toupper(e_spec[1]) == 'D') &&
947 (toupper(e_spec[2]) == 'I') &&
948 (toupper(e_spec[3]) == 'R')) {
952 /* Directory extensions are supposed to be in upper case only */
953 /* I would not be surprised if this rule can not be enforced */
954 /* if and when someone fully debugs the case sensitive mode */
955 if ((e_spec[1] == 'D') &&
956 (e_spec[2] == 'I') &&
957 (e_spec[3] == 'R')) {
966 * Routine to retrieve the maximum equivalence index for an input
967 * logical name. Some calls to this routine have no knowledge if
968 * the variable is a logical or not. So on error we return a max
971 /*{{{int my_maxidx(const char *lnm) */
973 my_maxidx(const char *lnm)
977 int attr = LNM$M_CASE_BLIND;
978 struct dsc$descriptor lnmdsc;
979 struct itmlst_3 itlst[2] = {{sizeof(midx), LNM$_MAX_INDEX, &midx, 0},
982 lnmdsc.dsc$w_length = strlen(lnm);
983 lnmdsc.dsc$b_dtype = DSC$K_DTYPE_T;
984 lnmdsc.dsc$b_class = DSC$K_CLASS_S;
985 lnmdsc.dsc$a_pointer = (char *) lnm; /* Cast ok for read only parameter */
987 status = sys$trnlnm(&attr, &fildevdsc, &lnmdsc, 0, itlst);
988 if ((status & 1) == 0)
995 /*{{{int vmstrnenv(const char *lnm, char *eqv, unsigned long int idx, struct dsc$descriptor_s **tabvec, unsigned long int flags) */
997 Perl_vmstrnenv(const char *lnm, char *eqv, unsigned long int idx,
998 struct dsc$descriptor_s **tabvec, unsigned long int flags)
1001 char uplnm[LNM$C_NAMLENGTH+1], *cp2;
1002 unsigned short int eqvlen, curtab, ivlnm = 0, ivsym = 0, ivenv = 0, secure;
1003 unsigned long int retsts, attr = LNM$M_CASE_BLIND;
1005 unsigned char acmode;
1006 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1007 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1008 struct itmlst_3 lnmlst[3] = {{sizeof idx, LNM$_INDEX, &idx, 0},
1009 {LNM$C_NAMLENGTH, LNM$_STRING, eqv, &eqvlen},
1011 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1012 #if defined(PERL_IMPLICIT_CONTEXT)
1015 aTHX = PERL_GET_INTERP;
1021 if (!lnm || !eqv || ((idx != 0) && ((idx-1) > PERL_LNM_MAX_ALLOWED_INDEX))) {
1022 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return 0;
1024 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1025 *cp2 = _toupper(*cp1);
1026 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1027 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1031 lnmdsc.dsc$w_length = cp1 - lnm;
1032 lnmdsc.dsc$a_pointer = uplnm;
1033 uplnm[lnmdsc.dsc$w_length] = '\0';
1034 secure = flags & PERL__TRNENV_SECURE;
1035 acmode = secure ? PSL$C_EXEC : PSL$C_USER;
1036 if (!tabvec || !*tabvec) tabvec = env_tables;
1038 for (curtab = 0; tabvec[curtab]; curtab++) {
1039 if (!str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1040 if (!ivenv && !secure) {
1045 #if defined(PERL_IMPLICIT_CONTEXT)
1048 "%%PERL-W-VMS_INIT Can't read CRTL environ\n");
1051 Perl_warn(aTHX_ "Can't read CRTL environ\n");
1054 retsts = SS$_NOLOGNAM;
1055 for (i = 0; environ[i]; i++) {
1056 if ((eq = strchr(environ[i],'=')) &&
1057 lnmdsc.dsc$w_length == (eq - environ[i]) &&
1058 !strncmp(environ[i],uplnm,eq - environ[i])) {
1060 for (eqvlen = 0; eq[eqvlen]; eqvlen++) eqv[eqvlen] = eq[eqvlen];
1061 if (!eqvlen) continue;
1062 retsts = SS$_NORMAL;
1066 if (retsts != SS$_NOLOGNAM) break;
1069 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1070 !str$case_blind_compare(&tmpdsc,&clisym)) {
1071 if (!ivsym && !secure) {
1072 unsigned short int deflen = LNM$C_NAMLENGTH;
1073 struct dsc$descriptor_d eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1074 /* dynamic dsc to accomodate possible long value */
1075 _ckvmssts_noperl(lib$sget1_dd(&deflen,&eqvdsc));
1076 retsts = lib$get_symbol(&lnmdsc,&eqvdsc,&eqvlen,0);
1078 if (eqvlen > MAX_DCL_SYMBOL) {
1079 set_errno(EVMSERR); set_vaxc_errno(LIB$_STRTRU);
1080 eqvlen = MAX_DCL_SYMBOL;
1081 /* Special hack--we might be called before the interpreter's */
1082 /* fully initialized, in which case either thr or PL_curcop */
1083 /* might be bogus. We have to check, since ckWARN needs them */
1084 /* both to be valid if running threaded */
1085 #if defined(PERL_IMPLICIT_CONTEXT)
1088 "%Perl-VMS-Init, Value of CLI symbol \"%s\" too long",lnm);
1091 if (ckWARN(WARN_MISC)) {
1092 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of CLI symbol \"%s\" too long",lnm);
1095 strncpy(eqv,eqvdsc.dsc$a_pointer,eqvlen);
1097 _ckvmssts_noperl(lib$sfree1_dd(&eqvdsc));
1098 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1099 if (retsts == LIB$_NOSUCHSYM) continue;
1104 if ( (idx == 0) && (flags & PERL__TRNENV_JOIN_SEARCHLIST) ) {
1105 midx = my_maxidx(lnm);
1106 for (idx = 0, cp2 = eqv; idx <= midx; idx++) {
1107 lnmlst[1].bufadr = cp2;
1109 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1110 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; break; }
1111 if (retsts == SS$_NOLOGNAM) break;
1112 /* PPFs have a prefix */
1115 *((int *)uplnm) == *((int *)"SYS$") &&
1117 eqvlen >= 4 && eqv[0] == 0x1b && eqv[1] == 0x00 &&
1118 ( (uplnm[4] == 'O' && !strcmp(uplnm,"SYS$OUTPUT")) ||
1119 (uplnm[4] == 'I' && !strcmp(uplnm,"SYS$INPUT")) ||
1120 (uplnm[4] == 'E' && !strcmp(uplnm,"SYS$ERROR")) ||
1121 (uplnm[4] == 'C' && !strcmp(uplnm,"SYS$COMMAND")) ) ) {
1122 memmove(eqv,eqv+4,eqvlen-4);
1128 if ((retsts == SS$_IVLOGNAM) ||
1129 (retsts == SS$_NOLOGNAM)) { continue; }
1132 retsts = sys$trnlnm(&attr,tabvec[curtab],&lnmdsc,&acmode,lnmlst);
1133 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1134 if (retsts == SS$_NOLOGNAM) continue;
1137 eqvlen = strlen(eqv);
1141 if (retsts & 1) { eqv[eqvlen] = '\0'; return eqvlen; }
1142 else if (retsts == LIB$_NOSUCHSYM || retsts == LIB$_INVSYMNAM ||
1143 retsts == SS$_IVLOGNAM || retsts == SS$_IVLOGTAB ||
1144 retsts == SS$_NOLOGNAM) {
1145 set_errno(EINVAL); set_vaxc_errno(retsts);
1147 else _ckvmssts_noperl(retsts);
1149 } /* end of vmstrnenv */
1152 /*{{{ int my_trnlnm(const char *lnm, char *eqv, unsigned long int idx)*/
1153 /* Define as a function so we can access statics. */
1154 int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx)
1158 #if defined(PERL_IMPLICIT_CONTEXT)
1161 #ifdef SECURE_INTERNAL_GETENV
1162 flags = (PL_curinterp ? PL_tainting : will_taint) ?
1163 PERL__TRNENV_SECURE : 0;
1166 return vmstrnenv(lnm, eqv, idx, fildev, flags);
1171 * Note: Uses Perl temp to store result so char * can be returned to
1172 * caller; this pointer will be invalidated at next Perl statement
1174 * We define this as a function rather than a macro in terms of my_getenv_len()
1175 * so that it'll work when PL_curinterp is undefined (and we therefore can't
1178 /*{{{ char *my_getenv(const char *lnm, bool sys)*/
1180 Perl_my_getenv(pTHX_ const char *lnm, bool sys)
1183 static char *__my_getenv_eqv = NULL;
1184 char uplnm[LNM$C_NAMLENGTH+1], *cp2, *eqv;
1185 unsigned long int idx = 0;
1186 int trnsuccess, success, secure, saverr, savvmserr;
1190 midx = my_maxidx(lnm) + 1;
1192 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1193 /* Set up a temporary buffer for the return value; Perl will
1194 * clean it up at the next statement transition */
1195 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1196 if (!tmpsv) return NULL;
1200 /* Assume no interpreter ==> single thread */
1201 if (__my_getenv_eqv != NULL) {
1202 Renew(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1205 Newx(__my_getenv_eqv,LNM$C_NAMLENGTH*midx+1,char);
1207 eqv = __my_getenv_eqv;
1210 for (cp1 = lnm, cp2 = eqv; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1211 if (cp1 - lnm == 7 && !strncmp(eqv,"DEFAULT",7)) {
1213 getcwd(eqv,LNM$C_NAMLENGTH);
1217 /* Get rid of "000000/ in rooted filespecs */
1220 zeros = strstr(eqv, "/000000/");
1221 if (zeros != NULL) {
1223 mlen = len - (zeros - eqv) - 7;
1224 memmove(zeros, &zeros[7], mlen);
1232 /* Impose security constraints only if tainting */
1234 /* Impose security constraints only if tainting */
1235 secure = PL_curinterp ? PL_tainting : will_taint;
1236 saverr = errno; savvmserr = vaxc$errno;
1243 #ifdef SECURE_INTERNAL_GETENV
1244 secure ? PERL__TRNENV_SECURE : 0
1250 /* For the getenv interface we combine all the equivalence names
1251 * of a search list logical into one value to acquire a maximum
1252 * value length of 255*128 (assuming %ENV is using logicals).
1254 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1256 /* If the name contains a semicolon-delimited index, parse it
1257 * off and make sure we only retrieve the equivalence name for
1259 if ((cp2 = strchr(lnm,';')) != NULL) {
1261 uplnm[cp2-lnm] = '\0';
1262 idx = strtoul(cp2+1,NULL,0);
1264 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1267 success = vmstrnenv(lnm,eqv,idx,secure ? fildev : NULL,flags);
1269 /* Discard NOLOGNAM on internal calls since we're often looking
1270 * for an optional name, and this "error" often shows up as the
1271 * (bogus) exit status for a die() call later on. */
1272 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1273 return success ? eqv : NULL;
1276 } /* end of my_getenv() */
1280 /*{{{ SV *my_getenv_len(const char *lnm, bool sys)*/
1282 Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys)
1286 unsigned long idx = 0;
1288 static char *__my_getenv_len_eqv = NULL;
1289 int secure, saverr, savvmserr;
1292 midx = my_maxidx(lnm) + 1;
1294 if (PL_curinterp) { /* Perl interpreter running -- may be threaded */
1295 /* Set up a temporary buffer for the return value; Perl will
1296 * clean it up at the next statement transition */
1297 tmpsv = sv_2mortal(newSVpv("",(LNM$C_NAMLENGTH*midx)+1));
1298 if (!tmpsv) return NULL;
1302 /* Assume no interpreter ==> single thread */
1303 if (__my_getenv_len_eqv != NULL) {
1304 Renew(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1307 Newx(__my_getenv_len_eqv,LNM$C_NAMLENGTH*midx+1,char);
1309 buf = __my_getenv_len_eqv;
1312 for (cp1 = lnm, cp2 = buf; *cp1; cp1++,cp2++) *cp2 = _toupper(*cp1);
1313 if (cp1 - lnm == 7 && !strncmp(buf,"DEFAULT",7)) {
1316 getcwd(buf,LNM$C_NAMLENGTH);
1319 /* Get rid of "000000/ in rooted filespecs */
1321 zeros = strstr(buf, "/000000/");
1322 if (zeros != NULL) {
1324 mlen = *len - (zeros - buf) - 7;
1325 memmove(zeros, &zeros[7], mlen);
1334 /* Impose security constraints only if tainting */
1335 secure = PL_curinterp ? PL_tainting : will_taint;
1336 saverr = errno; savvmserr = vaxc$errno;
1343 #ifdef SECURE_INTERNAL_GETENV
1344 secure ? PERL__TRNENV_SECURE : 0
1350 flags |= PERL__TRNENV_JOIN_SEARCHLIST;
1352 if ((cp2 = strchr(lnm,';')) != NULL) {
1354 buf[cp2-lnm] = '\0';
1355 idx = strtoul(cp2+1,NULL,0);
1357 flags &= ~PERL__TRNENV_JOIN_SEARCHLIST;
1360 *len = vmstrnenv(lnm,buf,idx,secure ? fildev : NULL,flags);
1362 /* Get rid of "000000/ in rooted filespecs */
1365 zeros = strstr(buf, "/000000/");
1366 if (zeros != NULL) {
1368 mlen = *len - (zeros - buf) - 7;
1369 memmove(zeros, &zeros[7], mlen);
1375 /* Discard NOLOGNAM on internal calls since we're often looking
1376 * for an optional name, and this "error" often shows up as the
1377 * (bogus) exit status for a die() call later on. */
1378 if (sys && vaxc$errno == SS$_NOLOGNAM) SETERRNO(saverr,savvmserr);
1379 return *len ? buf : NULL;
1382 } /* end of my_getenv_len() */
1385 static void create_mbx(unsigned short int *, struct dsc$descriptor_s *);
1387 static void riseandshine(unsigned long int dummy) { sys$wake(0,0); }
1389 /*{{{ void prime_env_iter() */
1391 prime_env_iter(void)
1392 /* Fill the %ENV associative array with all logical names we can
1393 * find, in preparation for iterating over it.
1396 static int primed = 0;
1397 HV *seenhv = NULL, *envhv;
1399 char cmd[LNM$C_NAMLENGTH+24], mbxnam[LNM$C_NAMLENGTH], *buf = NULL;
1400 unsigned short int chan;
1401 #ifndef CLI$M_TRUSTED
1402 # define CLI$M_TRUSTED 0x40 /* Missing from VAXC headers */
1404 unsigned long int defflags = CLI$M_NOWAIT | CLI$M_NOKEYPAD | CLI$M_TRUSTED;
1405 unsigned long int mbxbufsiz, flags, retsts, subpid = 0, substs = 0, wakect = 0;
1407 bool have_sym = FALSE, have_lnm = FALSE;
1408 struct dsc$descriptor_s tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1409 $DESCRIPTOR(cmddsc,cmd); $DESCRIPTOR(nldsc,"_NLA0:");
1410 $DESCRIPTOR(clidsc,"DCL"); $DESCRIPTOR(clitabdsc,"DCLTABLES");
1411 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1412 $DESCRIPTOR(local,"_LOCAL"); $DESCRIPTOR(mbxdsc,mbxnam);
1413 #if defined(PERL_IMPLICIT_CONTEXT)
1416 #if defined(USE_ITHREADS)
1417 static perl_mutex primenv_mutex;
1418 MUTEX_INIT(&primenv_mutex);
1421 #if defined(PERL_IMPLICIT_CONTEXT)
1422 /* We jump through these hoops because we can be called at */
1423 /* platform-specific initialization time, which is before anything is */
1424 /* set up--we can't even do a plain dTHX since that relies on the */
1425 /* interpreter structure to be initialized */
1427 aTHX = PERL_GET_INTERP;
1429 /* we never get here because the NULL pointer will cause the */
1430 /* several of the routines called by this routine to access violate */
1432 /* This routine is only called by hv.c/hv_iterinit which has a */
1433 /* context, so the real fix may be to pass it through instead of */
1434 /* the hoops above */
1439 if (primed || !PL_envgv) return;
1440 MUTEX_LOCK(&primenv_mutex);
1441 if (primed) { MUTEX_UNLOCK(&primenv_mutex); return; }
1442 envhv = GvHVn(PL_envgv);
1443 /* Perform a dummy fetch as an lval to insure that the hash table is
1444 * set up. Otherwise, the hv_store() will turn into a nullop. */
1445 (void) hv_fetch(envhv,"DEFAULT",7,TRUE);
1447 for (i = 0; env_tables[i]; i++) {
1448 if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1449 !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1;
1450 if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1;
1452 if (have_sym || have_lnm) {
1453 long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM;
1454 _ckvmssts(lib$getsyi(&syiitm, &mbxbufsiz, 0, 0, 0, 0));
1455 _ckvmssts(sys$crembx(0,&chan,mbxbufsiz,mbxbufsiz,0xff0f,0,0));
1456 _ckvmssts(lib$getdvi(&dviitm, &chan, NULL, NULL, &mbxdsc, &mbxdsc.dsc$w_length));
1459 for (i--; i >= 0; i--) {
1460 if (!str$case_blind_compare(env_tables[i],&crtlenv)) {
1463 for (j = 0; environ[j]; j++) {
1464 if (!(start = strchr(environ[j],'='))) {
1465 if (ckWARN(WARN_INTERNAL))
1466 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed CRTL environ value \"%s\"\n",environ[j]);
1470 sv = newSVpv(start,0);
1472 (void) hv_store(envhv,environ[j],start - environ[j] - 1,sv,0);
1477 else if ((tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) &&
1478 !str$case_blind_compare(&tmpdsc,&clisym)) {
1479 strcpy(cmd,"Show Symbol/Global *");
1480 cmddsc.dsc$w_length = 20;
1481 if (env_tables[i]->dsc$w_length == 12 &&
1482 (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer + 6) &&
1483 !str$case_blind_compare(&tmpdsc,&local)) strcpy(cmd+12,"Local *");
1484 flags = defflags | CLI$M_NOLOGNAM;
1487 strcpy(cmd,"Show Logical *");
1488 if (str$case_blind_compare(env_tables[i],&fildevdsc)) {
1489 strcat(cmd," /Table=");
1490 strncat(cmd,env_tables[i]->dsc$a_pointer,env_tables[i]->dsc$w_length);
1491 cmddsc.dsc$w_length = strlen(cmd);
1493 else cmddsc.dsc$w_length = 14; /* N.B. We test this below */
1494 flags = defflags | CLI$M_NOCLISYM;
1497 /* Create a new subprocess to execute each command, to exclude the
1498 * remote possibility that someone could subvert a mbx or file used
1499 * to write multiple commands to a single subprocess.
1502 retsts = lib$spawn(&cmddsc,&nldsc,&mbxdsc,&flags,0,&subpid,&substs,
1503 0,&riseandshine,0,0,&clidsc,&clitabdsc);
1504 flags &= ~CLI$M_TRUSTED; /* Just in case we hit a really old version */
1505 defflags &= ~CLI$M_TRUSTED;
1506 } while (retsts == LIB$_INVARG && (flags | CLI$M_TRUSTED));
1508 if (!buf) Newx(buf,mbxbufsiz + 1,char);
1509 if (seenhv) SvREFCNT_dec(seenhv);
1512 char *cp1, *cp2, *key;
1513 unsigned long int sts, iosb[2], retlen, keylen;
1516 sts = sys$qiow(0,chan,IO$_READVBLK,iosb,0,0,buf,mbxbufsiz,0,0,0,0);
1517 if (sts & 1) sts = iosb[0] & 0xffff;
1518 if (sts == SS$_ENDOFFILE) {
1520 while (substs == 0) { sys$hiber(); wakect++;}
1521 if (wakect > 1) sys$wake(0,0); /* Stole someone else's wake */
1526 retlen = iosb[0] >> 16;
1527 if (!retlen) continue; /* blank line */
1529 if (iosb[1] != subpid) {
1531 Perl_croak(aTHX_ "Unknown process %x sent message to prime_env_iter: %s",buf);
1535 if (sts == SS$_BUFFEROVF && ckWARN(WARN_INTERNAL))
1536 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Buffer overflow in prime_env_iter: %s",buf);
1538 for (cp1 = buf; *cp1 && isspace(*cp1); cp1++) ;
1539 if (*cp1 == '(' || /* Logical name table name */
1540 *cp1 == '=' /* Next eqv of searchlist */) continue;
1541 if (*cp1 == '"') cp1++;
1542 for (cp2 = cp1; *cp2 && *cp2 != '"' && *cp2 != ' '; cp2++) ;
1543 key = cp1; keylen = cp2 - cp1;
1544 if (keylen && hv_exists(seenhv,key,keylen)) continue;
1545 while (*cp2 && *cp2 != '=') cp2++;
1546 while (*cp2 && *cp2 == '=') cp2++;
1547 while (*cp2 && *cp2 == ' ') cp2++;
1548 if (*cp2 == '"') { /* String translation; may embed "" */
1549 for (cp1 = buf + retlen; *cp1 != '"'; cp1--) ;
1550 cp2++; cp1--; /* Skip "" surrounding translation */
1552 else { /* Numeric translation */
1553 for (cp1 = cp2; *cp1 && *cp1 != ' '; cp1++) ;
1554 cp1--; /* stop on last non-space char */
1556 if ((!keylen || (cp1 - cp2 < -1)) && ckWARN(WARN_INTERNAL)) {
1557 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"Ill-formed message in prime_env_iter: |%s|",buf);
1560 PERL_HASH(hash,key,keylen);
1562 if (cp1 == cp2 && *cp2 == '.') {
1563 /* A single dot usually means an unprintable character, such as a null
1564 * to indicate a zero-length value. Get the actual value to make sure.
1566 char lnm[LNM$C_NAMLENGTH+1];
1567 char eqv[MAX_DCL_SYMBOL+1];
1569 strncpy(lnm, key, keylen);
1570 trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0);
1571 sv = newSVpvn(eqv, strlen(eqv));
1574 sv = newSVpvn(cp2,cp1 - cp2 + 1);
1578 hv_store(envhv,key,keylen,sv,hash);
1579 hv_store(seenhv,key,keylen,&PL_sv_yes,hash);
1581 if (cmddsc.dsc$w_length == 14) { /* We just read LNM$FILE_DEV */
1582 /* get the PPFs for this process, not the subprocess */
1583 const char *ppfs[] = {"SYS$COMMAND", "SYS$INPUT", "SYS$OUTPUT", "SYS$ERROR", NULL};
1584 char eqv[LNM$C_NAMLENGTH+1];
1586 for (i = 0; ppfs[i]; i++) {
1587 trnlen = vmstrnenv(ppfs[i],eqv,0,fildev,0);
1588 sv = newSVpv(eqv,trnlen);
1590 hv_store(envhv,ppfs[i],strlen(ppfs[i]),sv,0);
1595 if (have_sym || have_lnm) _ckvmssts(sys$dassgn(chan));
1596 if (buf) Safefree(buf);
1597 if (seenhv) SvREFCNT_dec(seenhv);
1598 MUTEX_UNLOCK(&primenv_mutex);
1601 } /* end of prime_env_iter */
1605 /*{{{ int vmssetenv(const char *lnm, const char *eqv)*/
1606 /* Define or delete an element in the same "environment" as
1607 * vmstrnenv(). If an element is to be deleted, it's removed from
1608 * the first place it's found. If it's to be set, it's set in the
1609 * place designated by the first element of the table vector.
1610 * Like setenv() returns 0 for success, non-zero on error.
1613 Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s **tabvec)
1616 char uplnm[LNM$C_NAMLENGTH], *cp2, *c;
1617 unsigned short int curtab, ivlnm = 0, ivsym = 0, ivenv = 0;
1619 unsigned long int retsts, usermode = PSL$C_USER;
1620 struct itmlst_3 *ile, *ilist;
1621 struct dsc$descriptor_s lnmdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,uplnm},
1622 eqvdsc = {0,DSC$K_DTYPE_T,DSC$K_CLASS_S,0},
1623 tmpdsc = {6,DSC$K_DTYPE_T,DSC$K_CLASS_S,0};
1624 $DESCRIPTOR(crtlenv,"CRTL_ENV"); $DESCRIPTOR(clisym,"CLISYM");
1625 $DESCRIPTOR(local,"_LOCAL");
1628 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1629 return SS$_IVLOGNAM;
1632 for (cp1 = lnm, cp2 = uplnm; *cp1; cp1++, cp2++) {
1633 *cp2 = _toupper(*cp1);
1634 if (cp1 - lnm > LNM$C_NAMLENGTH) {
1635 set_errno(EINVAL); set_vaxc_errno(SS$_IVLOGNAM);
1636 return SS$_IVLOGNAM;
1639 lnmdsc.dsc$w_length = cp1 - lnm;
1640 if (!tabvec || !*tabvec) tabvec = env_tables;
1642 if (!eqv) { /* we're deleting n element */
1643 for (curtab = 0; tabvec[curtab]; curtab++) {
1644 if (!ivenv && !str$case_blind_compare(tabvec[curtab],&crtlenv)) {
1646 for (i = 0; environ[i]; i++) { /* If it's an environ elt, reset */
1647 if ((cp1 = strchr(environ[i],'=')) &&
1648 lnmdsc.dsc$w_length == (cp1 - environ[i]) &&
1649 !strncmp(environ[i],lnm,cp1 - environ[i])) {
1651 return setenv(lnm,"",1) ? vaxc$errno : 0;
1654 ivenv = 1; retsts = SS$_NOLOGNAM;
1656 if (ckWARN(WARN_INTERNAL))
1657 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't reset CRTL environ elements (%s)",lnm);
1658 ivenv = 1; retsts = SS$_NOSUCHPGM;
1664 else if ((tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer) &&
1665 !str$case_blind_compare(&tmpdsc,&clisym)) {
1666 unsigned int symtype;
1667 if (tabvec[curtab]->dsc$w_length == 12 &&
1668 (tmpdsc.dsc$a_pointer = tabvec[curtab]->dsc$a_pointer + 6) &&
1669 !str$case_blind_compare(&tmpdsc,&local))
1670 symtype = LIB$K_CLI_LOCAL_SYM;
1671 else symtype = LIB$K_CLI_GLOBAL_SYM;
1672 retsts = lib$delete_symbol(&lnmdsc,&symtype);
1673 if (retsts == LIB$_INVSYMNAM) { ivsym = 1; continue; }
1674 if (retsts == LIB$_NOSUCHSYM) continue;
1678 retsts = sys$dellnm(tabvec[curtab],&lnmdsc,&usermode); /* try user mode first */
1679 if (retsts == SS$_IVLOGNAM) { ivlnm = 1; continue; }
1680 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1681 retsts = lib$delete_logical(&lnmdsc,tabvec[curtab]); /* then supervisor mode */
1682 if (retsts != SS$_NOLOGNAM && retsts != SS$_NOLOGTAB) break;
1686 else { /* we're defining a value */
1687 if (!ivenv && !str$case_blind_compare(tabvec[0],&crtlenv)) {
1689 return setenv(lnm,eqv,1) ? vaxc$errno : 0;
1691 if (ckWARN(WARN_INTERNAL))
1692 Perl_warner(aTHX_ packWARN(WARN_INTERNAL),"This Perl can't set CRTL environ elements (%s=%s)",lnm,eqv);
1693 retsts = SS$_NOSUCHPGM;
1697 eqvdsc.dsc$a_pointer = (char *) eqv; /* cast ok to readonly parameter */
1698 eqvdsc.dsc$w_length = strlen(eqv);
1699 if ((tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer) &&
1700 !str$case_blind_compare(&tmpdsc,&clisym)) {
1701 unsigned int symtype;
1702 if (tabvec[0]->dsc$w_length == 12 &&
1703 (tmpdsc.dsc$a_pointer = tabvec[0]->dsc$a_pointer + 6) &&
1704 !str$case_blind_compare(&tmpdsc,&local))
1705 symtype = LIB$K_CLI_LOCAL_SYM;
1706 else symtype = LIB$K_CLI_GLOBAL_SYM;
1707 retsts = lib$set_symbol(&lnmdsc,&eqvdsc,&symtype);
1710 if (!*eqv) eqvdsc.dsc$w_length = 1;
1711 if (eqvdsc.dsc$w_length > LNM$C_NAMLENGTH) {
1713 nseg = (eqvdsc.dsc$w_length + LNM$C_NAMLENGTH - 1) / LNM$C_NAMLENGTH;
1714 if (nseg > PERL_LNM_MAX_ALLOWED_INDEX + 1) {
1715 Perl_warner(aTHX_ packWARN(WARN_MISC),"Value of logical \"%s\" too long. Truncating to %i bytes",
1716 lnm, LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1));
1717 eqvdsc.dsc$w_length = LNM$C_NAMLENGTH * (PERL_LNM_MAX_ALLOWED_INDEX+1);
1718 nseg = PERL_LNM_MAX_ALLOWED_INDEX + 1;
1721 Newx(ilist,nseg+1,struct itmlst_3);
1724 set_errno(ENOMEM); set_vaxc_errno(SS$_INSFMEM);
1727 memset(ilist, 0, (sizeof(struct itmlst_3) * (nseg+1)));
1729 for (j = 0, c = eqvdsc.dsc$a_pointer; j < nseg; j++, ile++, c += LNM$C_NAMLENGTH) {
1730 ile->itmcode = LNM$_STRING;
1732 if ((j+1) == nseg) {
1733 ile->buflen = strlen(c);
1734 /* in case we are truncating one that's too long */
1735 if (ile->buflen > LNM$C_NAMLENGTH) ile->buflen = LNM$C_NAMLENGTH;
1738 ile->buflen = LNM$C_NAMLENGTH;
1742 retsts = lib$set_logical(&lnmdsc,0,tabvec[0],0,ilist);
1746 retsts = lib$set_logical(&lnmdsc,&eqvdsc,tabvec[0],0,0);
1751 if (!(retsts & 1)) {
1753 case LIB$_AMBSYMDEF: case LIB$_INSCLIMEM:
1754 case SS$_NOLOGTAB: case SS$_TOOMANYLNAM: case SS$_IVLOGTAB:
1755 set_errno(EVMSERR); break;
1756 case LIB$_INVARG: case LIB$_INVSYMNAM: case SS$_IVLOGNAM:
1757 case LIB$_NOSUCHSYM: case SS$_NOLOGNAM:
1758 set_errno(EINVAL); break;
1760 set_errno(EACCES); break;
1765 set_vaxc_errno(retsts);
1766 return (int) retsts || 44; /* retsts should never be 0, but just in case */
1769 /* We reset error values on success because Perl does an hv_fetch()
1770 * before each hv_store(), and if the thing we're setting didn't
1771 * previously exist, we've got a leftover error message. (Of course,
1772 * this fails in the face of
1773 * $foo = $ENV{nonexistent}; $ENV{existent} = 'foo';
1774 * in that the error reported in $! isn't spurious,
1775 * but it's right more often than not.)
1777 set_errno(0); set_vaxc_errno(retsts);
1781 } /* end of vmssetenv() */
1784 /*{{{ void my_setenv(const char *lnm, const char *eqv)*/
1785 /* This has to be a function since there's a prototype for it in proto.h */
1787 Perl_my_setenv(pTHX_ const char *lnm, const char *eqv)
1790 int len = strlen(lnm);
1794 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1795 if (!strcmp(uplnm,"DEFAULT")) {
1796 if (eqv && *eqv) my_chdir(eqv);
1800 #ifndef RTL_USES_UTC
1801 if (len == 6 || len == 2) {
1804 for (i = 0; lnm[i]; i++) uplnm[i] = _toupper(lnm[i]);
1806 if (!strcmp(uplnm,"UCX$TZ")) tz_updated = 1;
1807 if (!strcmp(uplnm,"TZ")) tz_updated = 1;
1811 (void) vmssetenv(lnm,eqv,NULL);
1815 /*{{{static void vmssetuserlnm(char *name, char *eqv); */
1817 * sets a user-mode logical in the process logical name table
1818 * used for redirection of sys$error
1821 Perl_vmssetuserlnm(pTHX_ const char *name, const char *eqv)
1823 $DESCRIPTOR(d_tab, "LNM$PROCESS");
1824 struct dsc$descriptor_d d_name = {0,DSC$K_DTYPE_T,DSC$K_CLASS_D,0};
1825 unsigned long int iss, attr = LNM$M_CONFINE;
1826 unsigned char acmode = PSL$C_USER;
1827 struct itmlst_3 lnmlst[2] = {{0, LNM$_STRING, 0, 0},
1829 d_name.dsc$a_pointer = (char *)name; /* Cast OK for read only parameter */
1830 d_name.dsc$w_length = strlen(name);
1832 lnmlst[0].buflen = strlen(eqv);
1833 lnmlst[0].bufadr = (char *)eqv; /* Cast OK for read only parameter */
1835 iss = sys$crelnm(&attr,&d_tab,&d_name,&acmode,lnmlst);
1836 if (!(iss&1)) lib$signal(iss);
1841 /*{{{ char *my_crypt(const char *textpasswd, const char *usrname)*/
1842 /* my_crypt - VMS password hashing
1843 * my_crypt() provides an interface compatible with the Unix crypt()
1844 * C library function, and uses sys$hash_password() to perform VMS
1845 * password hashing. The quadword hashed password value is returned
1846 * as a NUL-terminated 8 character string. my_crypt() does not change
1847 * the case of its string arguments; in order to match the behavior
1848 * of LOGINOUT et al., alphabetic characters in both arguments must
1849 * be upcased by the caller.
1851 * - fix me to call ACM services when available
1854 Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname)
1856 # ifndef UAI$C_PREFERRED_ALGORITHM
1857 # define UAI$C_PREFERRED_ALGORITHM 127
1859 unsigned char alg = UAI$C_PREFERRED_ALGORITHM;
1860 unsigned short int salt = 0;
1861 unsigned long int sts;
1863 unsigned short int dsc$w_length;
1864 unsigned char dsc$b_type;
1865 unsigned char dsc$b_class;
1866 const char * dsc$a_pointer;
1867 } usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
1868 txtdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1869 struct itmlst_3 uailst[3] = {
1870 { sizeof alg, UAI$_ENCRYPT, &alg, 0},
1871 { sizeof salt, UAI$_SALT, &salt, 0},
1872 { 0, 0, NULL, NULL}};
1873 static char hash[9];
1875 usrdsc.dsc$w_length = strlen(usrname);
1876 usrdsc.dsc$a_pointer = usrname;
1877 if (!((sts = sys$getuai(0, 0, &usrdsc, uailst, 0, 0, 0)) & 1)) {
1879 case SS$_NOGRPPRV: case SS$_NOSYSPRV:
1883 set_errno(ESRCH); /* There isn't a Unix no-such-user error */
1888 set_vaxc_errno(sts);
1889 if (sts != RMS$_RNF) return NULL;
1892 txtdsc.dsc$w_length = strlen(textpasswd);
1893 txtdsc.dsc$a_pointer = textpasswd;
1894 if (!((sts = sys$hash_password(&txtdsc, alg, salt, &usrdsc, &hash)) & 1)) {
1895 set_errno(EVMSERR); set_vaxc_errno(sts); return NULL;
1898 return (char *) hash;
1900 } /* end of my_crypt() */
1904 static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *);
1905 static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *);
1906 static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *);
1908 /* fixup barenames that are directories for internal use.
1909 * There have been problems with the consistent handling of UNIX
1910 * style directory names when routines are presented with a name that
1911 * has no directory delimitors at all. So this routine will eventually
1914 static char * fixup_bare_dirnames(const char * name)
1916 if (decc_disable_to_vms_logname_translation) {
1922 /* 8.3, remove() is now broken on symbolic links */
1923 static int rms_erase(const char * vmsname);
1927 * A little hack to get around a bug in some implemenation of remove()
1928 * that do not know how to delete a directory
1930 * Delete any file to which user has control access, regardless of whether
1931 * delete access is explicitly allowed.
1932 * Limitations: User must have write access to parent directory.
1933 * Does not block signals or ASTs; if interrupted in midstream
1934 * may leave file with an altered ACL.
1937 /*{{{int mp_do_kill_file(const char *name, int dirflag)*/
1939 mp_do_kill_file(pTHX_ const char *name, int dirflag)
1943 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
1944 unsigned long int cxt = 0, aclsts, fndsts, rmsts = -1;
1945 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1947 unsigned char myace$b_length;
1948 unsigned char myace$b_type;
1949 unsigned short int myace$w_flags;
1950 unsigned long int myace$l_access;
1951 unsigned long int myace$l_ident;
1952 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
1953 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL, 0},
1954 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
1956 findlst[3] = {{sizeof oldace, ACL$C_FNDACLENT, &oldace, 0},
1957 {sizeof oldace, ACL$C_READACE, &oldace, 0},{0,0,0,0}},
1958 addlst[2] = {{sizeof newace, ACL$C_ADDACLENT, &newace, 0},{0,0,0,0}},
1959 dellst[2] = {{sizeof newace, ACL$C_DELACLENT, &newace, 0},{0,0,0,0}},
1960 lcklst[2] = {{sizeof newace, ACL$C_WLOCK_ACL, &newace, 0},{0,0,0,0}},
1961 ulklst[2] = {{sizeof newace, ACL$C_UNLOCK_ACL, &newace, 0},{0,0,0,0}};
1963 /* Expand the input spec using RMS, since the CRTL remove() and
1964 * system services won't do this by themselves, so we may miss
1965 * a file "hiding" behind a logical name or search list. */
1966 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
1967 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
1969 rslt = int_rmsexpand_tovms(name, vmsname, PERL_RMSEXPAND_M_SYMLINK);
1971 PerlMem_free(vmsname);
1975 /* Erase the file */
1976 rmsts = rms_erase(vmsname);
1978 /* Did it succeed */
1979 if ($VMS_STATUS_SUCCESS(rmsts)) {
1980 PerlMem_free(vmsname);
1984 /* If not, can changing protections help? */
1985 if (rmsts != RMS$_PRV) {
1986 set_vaxc_errno(rmsts);
1987 PerlMem_free(vmsname);
1991 /* No, so we get our own UIC to use as a rights identifier,
1992 * and the insert an ACE at the head of the ACL which allows us
1993 * to delete the file.
1995 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
1996 fildsc.dsc$w_length = strlen(vmsname);
1997 fildsc.dsc$a_pointer = vmsname;
1999 newace.myace$l_ident = oldace.myace$l_ident;
2001 if (!((aclsts = sys$change_acl(0,&type,&fildsc,lcklst,0,0,0)) & 1)) {
2003 case RMS$_FNF: case RMS$_DNF: case SS$_NOSUCHOBJECT:
2004 set_errno(ENOENT); break;
2006 set_errno(ENOTDIR); break;
2008 set_errno(ENODEV); break;
2009 case RMS$_SYN: case SS$_INVFILFOROP:
2010 set_errno(EINVAL); break;
2012 set_errno(EACCES); break;
2014 _ckvmssts_noperl(aclsts);
2016 set_vaxc_errno(aclsts);
2017 PerlMem_free(vmsname);
2020 /* Grab any existing ACEs with this identifier in case we fail */
2021 aclsts = fndsts = sys$change_acl(0,&type,&fildsc,findlst,0,0,&cxt);
2022 if ( fndsts & 1 || fndsts == SS$_ACLEMPTY || fndsts == SS$_NOENTRY
2023 || fndsts == SS$_NOMOREACE ) {
2024 /* Add the new ACE . . . */
2025 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,0)) & 1))
2028 rmsts = rms_erase(vmsname);
2029 if ($VMS_STATUS_SUCCESS(rmsts)) {
2034 /* We blew it - dir with files in it, no write priv for
2035 * parent directory, etc. Put things back the way they were. */
2036 if (!((aclsts = sys$change_acl(0,&type,&fildsc,dellst,0,0,0)) & 1))
2039 addlst[0].bufadr = &oldace;
2040 if (!((aclsts = sys$change_acl(0,&type,&fildsc,addlst,0,0,&cxt)) & 1))
2047 fndsts = sys$change_acl(0,&type,&fildsc,ulklst,0,0,0);
2048 /* We just deleted it, so of course it's not there. Some versions of
2049 * VMS seem to return success on the unlock operation anyhow (after all
2050 * the unlock is successful), but others don't.
2052 if (fndsts == RMS$_FNF || fndsts == SS$_NOSUCHOBJECT) fndsts = SS$_NORMAL;
2053 if (aclsts & 1) aclsts = fndsts;
2054 if (!(aclsts & 1)) {
2056 set_vaxc_errno(aclsts);
2059 PerlMem_free(vmsname);
2062 } /* end of kill_file() */
2066 /*{{{int do_rmdir(char *name)*/
2068 Perl_do_rmdir(pTHX_ const char *name)
2074 dirfile = PerlMem_malloc(VMS_MAXRSS + 1);
2075 if (dirfile == NULL)
2076 _ckvmssts(SS$_INSFMEM);
2078 /* Force to a directory specification */
2079 if (do_fileify_dirspec(name, dirfile, 0, NULL) == NULL) {
2080 PerlMem_free(dirfile);
2083 if (Perl_flex_lstat(aTHX_ dirfile, &st) || !S_ISDIR(st.st_mode)) {
2088 retval = mp_do_kill_file(aTHX_ dirfile, 1);
2090 PerlMem_free(dirfile);
2093 } /* end of do_rmdir */
2097 * Delete any file to which user has control access, regardless of whether
2098 * delete access is explicitly allowed.
2099 * Limitations: User must have write access to parent directory.
2100 * Does not block signals or ASTs; if interrupted in midstream
2101 * may leave file with an altered ACL.
2104 /*{{{int kill_file(char *name)*/
2106 Perl_kill_file(pTHX_ const char *name)
2108 char rspec[NAM$C_MAXRSS+1];
2113 /* Remove() is allowed to delete directories, according to the X/Open
2115 * This may need special handling to work with the ACL hacks.
2117 if ((flex_lstat(name, &st) == 0) && S_ISDIR(st.st_mode)) {
2118 rmsts = Perl_do_rmdir(aTHX_ name);
2122 rmsts = mp_do_kill_file(aTHX_ name, 0);
2126 } /* end of kill_file() */
2130 /*{{{int my_mkdir(char *,Mode_t)*/
2132 Perl_my_mkdir(pTHX_ const char *dir, Mode_t mode)
2134 STRLEN dirlen = strlen(dir);
2136 /* zero length string sometimes gives ACCVIO */
2137 if (dirlen == 0) return -1;
2139 /* CRTL mkdir() doesn't tolerate trailing /, since that implies
2140 * null file name/type. However, it's commonplace under Unix,
2141 * so we'll allow it for a gain in portability.
2143 if (dir[dirlen-1] == '/') {
2144 char *newdir = savepvn(dir,dirlen-1);
2145 int ret = mkdir(newdir,mode);
2149 else return mkdir(dir,mode);
2150 } /* end of my_mkdir */
2153 /*{{{int my_chdir(char *)*/
2155 Perl_my_chdir(pTHX_ const char *dir)
2157 STRLEN dirlen = strlen(dir);
2159 /* zero length string sometimes gives ACCVIO */
2160 if (dirlen == 0) return -1;
2163 /* Perl is passing the output of the DCL SHOW DEFAULT with leading spaces.
2164 * This does not work if DECC$EFS_CHARSET is active. Hack it here
2165 * so that existing scripts do not need to be changed.
2168 while ((dirlen > 0) && (*dir1 == ' ')) {
2173 /* some versions of CRTL chdir() doesn't tolerate trailing /, since
2175 * null file name/type. However, it's commonplace under Unix,
2176 * so we'll allow it for a gain in portability.
2178 * - Preview- '/' will be valid soon on VMS
2180 if ((dirlen > 1) && (dir1[dirlen-1] == '/')) {
2181 char *newdir = savepvn(dir1,dirlen-1);
2182 int ret = chdir(newdir);
2186 else return chdir(dir1);
2187 } /* end of my_chdir */
2191 /*{{{int my_chmod(char *, mode_t)*/
2193 Perl_my_chmod(pTHX_ const char *file_spec, mode_t mode)
2195 STRLEN speclen = strlen(file_spec);
2197 /* zero length string sometimes gives ACCVIO */
2198 if (speclen == 0) return -1;
2200 /* some versions of CRTL chmod() doesn't tolerate trailing /, since
2201 * that implies null file name/type. However, it's commonplace under Unix,
2202 * so we'll allow it for a gain in portability.
2204 * Tests are showing that chmod() on VMS 8.3 is only accepting directories
2205 * in VMS file.dir notation.
2207 if ((speclen > 1) && (file_spec[speclen-1] == '/')) {
2208 char *vms_src, *vms_dir, *rslt;
2212 /* First convert this to a VMS format specification */
2213 vms_src = PerlMem_malloc(VMS_MAXRSS);
2214 if (vms_src == NULL)
2215 _ckvmssts_noperl(SS$_INSFMEM);
2217 rslt = do_tovmsspec(file_spec, vms_src, 0, NULL);
2219 /* If we fail, then not a file specification */
2220 PerlMem_free(vms_src);
2225 /* Now make it a directory spec so chmod is happy */
2226 vms_dir = PerlMem_malloc(VMS_MAXRSS + 1);
2227 if (vms_dir == NULL)
2228 _ckvmssts_noperl(SS$_INSFMEM);
2229 rslt = do_fileify_dirspec(vms_src, vms_dir, 0, NULL);
2230 PerlMem_free(vms_src);
2234 ret = chmod(vms_dir, mode);
2238 PerlMem_free(vms_dir);
2241 else return chmod(file_spec, mode);
2242 } /* end of my_chmod */
2246 /*{{{FILE *my_tmpfile()*/
2253 if ((fp = tmpfile())) return fp;
2255 cp = PerlMem_malloc(L_tmpnam+24);
2256 if (cp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
2258 if (decc_filename_unix_only == 0)
2259 strcpy(cp,"Sys$Scratch:");
2262 tmpnam(cp+strlen(cp));
2263 strcat(cp,".Perltmp");
2264 fp = fopen(cp,"w+","fop=dlt");
2271 #ifndef HOMEGROWN_POSIX_SIGNALS
2273 * The C RTL's sigaction fails to check for invalid signal numbers so we
2274 * help it out a bit. The docs are correct, but the actual routine doesn't
2275 * do what the docs say it will.
2277 /*{{{int Perl_my_sigaction (pTHX_ int, const struct sigaction*, struct sigaction*);*/
2279 Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act,
2280 struct sigaction* oact)
2282 if (sig == SIGKILL || sig == SIGSTOP || sig == SIGCONT) {
2283 SETERRNO(EINVAL, SS$_INVARG);
2286 return sigaction(sig, act, oact);
2291 #ifdef KILL_BY_SIGPRC
2292 #include <errnodef.h>
2294 /* We implement our own kill() using the undocumented system service
2295 sys$sigprc for one of two reasons:
2297 1.) If the kill() in an older CRTL uses sys$forcex, causing the
2298 target process to do a sys$exit, which usually can't be handled
2299 gracefully...certainly not by Perl and the %SIG{} mechanism.
2301 2.) If the kill() in the CRTL can't be called from a signal
2302 handler without disappearing into the ether, i.e., the signal
2303 it purportedly sends is never trapped. Still true as of VMS 7.3.
2305 sys$sigprc has the same parameters as sys$forcex, but throws an exception
2306 in the target process rather than calling sys$exit.
2308 Note that distinguishing SIGSEGV from SIGBUS requires an extra arg
2309 on the ACCVIO condition, which sys$sigprc (and sys$forcex) don't
2310 provide. On VMS 7.0+ this is taken care of by doing sys$sigprc
2311 with condition codes C$_SIG0+nsig*8, catching the exception on the
2312 target process and resignaling with appropriate arguments.
2314 But we don't have that VMS 7.0+ exception handler, so if you
2315 Perl_my_kill(.., SIGSEGV) it will show up as a SIGBUS. Oh well.
2317 Also note that SIGTERM is listed in the docs as being "unimplemented",
2318 yet always seems to be signaled with a VMS condition code of 4 (and
2319 correctly handled for that code). So we hardwire it in.
2321 Unlike the VMS 7.0+ CRTL kill() function, we actually check the signal
2322 number to see if it's valid. So Perl_my_kill(pid,0) returns -1 rather
2323 than signalling with an unrecognized (and unhandled by CRTL) code.
2326 #define _MY_SIG_MAX 28
2329 Perl_sig_to_vmscondition_int(int sig)
2331 static unsigned int sig_code[_MY_SIG_MAX+1] =
2334 SS$_HANGUP, /* 1 SIGHUP */
2335 SS$_CONTROLC, /* 2 SIGINT */
2336 SS$_CONTROLY, /* 3 SIGQUIT */
2337 SS$_RADRMOD, /* 4 SIGILL */
2338 SS$_BREAK, /* 5 SIGTRAP */
2339 SS$_OPCCUS, /* 6 SIGABRT */
2340 SS$_COMPAT, /* 7 SIGEMT */
2342 SS$_FLTOVF, /* 8 SIGFPE VAX */
2344 SS$_HPARITH, /* 8 SIGFPE AXP */
2346 SS$_ABORT, /* 9 SIGKILL */
2347 SS$_ACCVIO, /* 10 SIGBUS */
2348 SS$_ACCVIO, /* 11 SIGSEGV */
2349 SS$_BADPARAM, /* 12 SIGSYS */
2350 SS$_NOMBX, /* 13 SIGPIPE */
2351 SS$_ASTFLT, /* 14 SIGALRM */
2368 #if __VMS_VER >= 60200000
2369 static int initted = 0;
2372 sig_code[16] = C$_SIGUSR1;
2373 sig_code[17] = C$_SIGUSR2;
2374 #if __CRTL_VER >= 70000000
2375 sig_code[20] = C$_SIGCHLD;
2377 #if __CRTL_VER >= 70300000
2378 sig_code[28] = C$_SIGWINCH;
2383 if (sig < _SIG_MIN) return 0;
2384 if (sig > _MY_SIG_MAX) return 0;
2385 return sig_code[sig];
2389 Perl_sig_to_vmscondition(int sig)
2392 if (vms_debug_on_exception != 0)
2393 lib$signal(SS$_DEBUG);
2395 return Perl_sig_to_vmscondition_int(sig);
2400 Perl_my_kill(int pid, int sig)
2405 int sys$sigprc(unsigned int *pidadr,
2406 struct dsc$descriptor_s *prcname,
2409 /* sig 0 means validate the PID */
2410 /*------------------------------*/
2412 const unsigned long int jpicode = JPI$_PID;
2415 status = lib$getjpi(&jpicode, &pid, NULL, &ret_pid, NULL, NULL);
2416 if ($VMS_STATUS_SUCCESS(status))
2419 case SS$_NOSUCHNODE:
2420 case SS$_UNREACHABLE:
2434 code = Perl_sig_to_vmscondition_int(sig);
2437 SETERRNO(EINVAL, SS$_BADPARAM);
2441 /* Fixme: Per official UNIX specification: If pid = 0, or negative then
2442 * signals are to be sent to multiple processes.
2443 * pid = 0 - all processes in group except ones that the system exempts
2444 * pid = -1 - all processes except ones that the system exempts
2445 * pid = -n - all processes in group (abs(n)) except ...
2446 * For now, just report as not supported.
2450 SETERRNO(ENOTSUP, SS$_UNSUPPORTED);
2454 iss = sys$sigprc((unsigned int *)&pid,0,code);
2455 if (iss&1) return 0;
2459 set_errno(EPERM); break;
2461 case SS$_NOSUCHNODE:
2462 case SS$_UNREACHABLE:
2463 set_errno(ESRCH); break;
2465 set_errno(ENOMEM); break;
2467 _ckvmssts_noperl(iss);
2470 set_vaxc_errno(iss);
2476 /* Routine to convert a VMS status code to a UNIX status code.
2477 ** More tricky than it appears because of conflicting conventions with
2480 ** VMS status codes are a bit mask, with the least significant bit set for
2483 ** Special UNIX status of EVMSERR indicates that no translation is currently
2484 ** available, and programs should check the VMS status code.
2486 ** Programs compiled with _POSIX_EXIT have a special encoding that requires
2490 #ifndef C_FACILITY_NO
2491 #define C_FACILITY_NO 0x350000
2494 #define DCL_IVVERB 0x38090
2497 int Perl_vms_status_to_unix(int vms_status, int child_flag)
2505 /* Assume the best or the worst */
2506 if (vms_status & STS$M_SUCCESS)
2509 unix_status = EVMSERR;
2511 msg_status = vms_status & ~STS$M_CONTROL;
2513 facility = vms_status & STS$M_FAC_NO;
2514 fac_sp = vms_status & STS$M_FAC_SP;
2515 msg_no = vms_status & (STS$M_MSG_NO | STS$M_SEVERITY);
2517 if (((facility == 0) || (fac_sp == 0)) && (child_flag == 0)) {
2523 unix_status = EFAULT;
2525 case SS$_DEVOFFLINE:
2526 unix_status = EBUSY;
2529 unix_status = ENOTCONN;
2537 case SS$_INVFILFOROP:
2541 unix_status = EINVAL;
2543 case SS$_UNSUPPORTED:
2544 unix_status = ENOTSUP;
2549 unix_status = EACCES;
2551 case SS$_DEVICEFULL:
2552 unix_status = ENOSPC;
2555 unix_status = ENODEV;
2557 case SS$_NOSUCHFILE:
2558 case SS$_NOSUCHOBJECT:
2559 unix_status = ENOENT;
2561 case SS$_ABORT: /* Fatal case */
2562 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_ERROR): /* Error case */
2563 case ((SS$_ABORT & STS$M_COND_ID) | STS$K_WARNING): /* Warning case */
2564 unix_status = EINTR;
2567 unix_status = E2BIG;
2570 unix_status = ENOMEM;
2573 unix_status = EPERM;
2575 case SS$_NOSUCHNODE:
2576 case SS$_UNREACHABLE:
2577 unix_status = ESRCH;
2580 unix_status = ECHILD;
2583 if ((facility == 0) && (msg_no < 8)) {
2584 /* These are not real VMS status codes so assume that they are
2585 ** already UNIX status codes
2587 unix_status = msg_no;
2593 /* Translate a POSIX exit code to a UNIX exit code */
2594 if ((facility == C_FACILITY_NO) && ((msg_no & 0xA000) == 0xA000)) {
2595 unix_status = (msg_no & 0x07F8) >> 3;
2599 /* Documented traditional behavior for handling VMS child exits */
2600 /*--------------------------------------------------------------*/
2601 if (child_flag != 0) {
2603 /* Success / Informational return 0 */
2604 /*----------------------------------*/
2605 if (msg_no & STS$K_SUCCESS)
2608 /* Warning returns 1 */
2609 /*-------------------*/
2610 if ((msg_no & (STS$K_ERROR | STS$K_SEVERE)) == 0)
2613 /* Everything else pass through the severity bits */
2614 /*------------------------------------------------*/
2615 return (msg_no & STS$M_SEVERITY);
2618 /* Normal VMS status to ERRNO mapping attempt */
2619 /*--------------------------------------------*/
2620 switch(msg_status) {
2621 /* case RMS$_EOF: */ /* End of File */
2622 case RMS$_FNF: /* File Not Found */
2623 case RMS$_DNF: /* Dir Not Found */
2624 unix_status = ENOENT;
2626 case RMS$_RNF: /* Record Not Found */
2627 unix_status = ESRCH;
2630 unix_status = ENOTDIR;
2633 unix_status = ENODEV;
2638 unix_status = EBADF;
2641 unix_status = EEXIST;
2645 case LIB$_INVSTRDES:
2647 case LIB$_NOSUCHSYM:
2648 case LIB$_INVSYMNAM:
2650 unix_status = EINVAL;
2656 unix_status = E2BIG;
2658 case RMS$_PRV: /* No privilege */
2659 case RMS$_ACC: /* ACP file access failed */
2660 case RMS$_WLK: /* Device write locked */
2661 unix_status = EACCES;
2663 case RMS$_MKD: /* Failed to mark for delete */
2664 unix_status = EPERM;
2666 /* case RMS$_NMF: */ /* No more files */
2674 /* Try to guess at what VMS error status should go with a UNIX errno
2675 * value. This is hard to do as there could be many possible VMS
2676 * error statuses that caused the errno value to be set.
2679 int Perl_unix_status_to_vms(int unix_status)
2681 int test_unix_status;
2683 /* Trivial cases first */
2684 /*---------------------*/
2685 if (unix_status == EVMSERR)
2688 /* Is vaxc$errno sane? */
2689 /*---------------------*/
2690 test_unix_status = Perl_vms_status_to_unix(vaxc$errno, 0);
2691 if (test_unix_status == unix_status)
2694 /* If way out of range, must be VMS code already */
2695 /*-----------------------------------------------*/
2696 if (unix_status > EVMSERR)
2699 /* If out of range, punt */
2700 /*-----------------------*/
2701 if (unix_status > __ERRNO_MAX)
2705 /* Ok, now we have to do it the hard way. */
2706 /*----------------------------------------*/
2707 switch(unix_status) {
2708 case 0: return SS$_NORMAL;
2709 case EPERM: return SS$_NOPRIV;
2710 case ENOENT: return SS$_NOSUCHOBJECT;
2711 case ESRCH: return SS$_UNREACHABLE;
2712 case EINTR: return SS$_ABORT;
2715 case E2BIG: return SS$_BUFFEROVF;
2717 case EBADF: return RMS$_IFI;
2718 case ECHILD: return SS$_NONEXPR;
2720 case ENOMEM: return SS$_INSFMEM;
2721 case EACCES: return SS$_FILACCERR;
2722 case EFAULT: return SS$_ACCVIO;
2724 case EBUSY: return SS$_DEVOFFLINE;
2725 case EEXIST: return RMS$_FEX;
2727 case ENODEV: return SS$_NOSUCHDEV;
2728 case ENOTDIR: return RMS$_DIR;
2730 case EINVAL: return SS$_INVARG;
2736 case ENOSPC: return SS$_DEVICEFULL;
2737 case ESPIPE: return LIB$_INVARG;
2742 case ERANGE: return LIB$_INVARG;
2743 /* case EWOULDBLOCK */
2744 /* case EINPROGRESS */
2747 /* case EDESTADDRREQ */
2749 /* case EPROTOTYPE */
2750 /* case ENOPROTOOPT */
2751 /* case EPROTONOSUPPORT */
2752 /* case ESOCKTNOSUPPORT */
2753 /* case EOPNOTSUPP */
2754 /* case EPFNOSUPPORT */
2755 /* case EAFNOSUPPORT */
2756 /* case EADDRINUSE */
2757 /* case EADDRNOTAVAIL */
2759 /* case ENETUNREACH */
2760 /* case ENETRESET */
2761 /* case ECONNABORTED */
2762 /* case ECONNRESET */
2765 case ENOTCONN: return SS$_CLEARED;
2766 /* case ESHUTDOWN */
2767 /* case ETOOMANYREFS */
2768 /* case ETIMEDOUT */
2769 /* case ECONNREFUSED */
2771 /* case ENAMETOOLONG */
2772 /* case EHOSTDOWN */
2773 /* case EHOSTUNREACH */
2774 /* case ENOTEMPTY */
2786 /* case ECANCELED */
2790 return SS$_UNSUPPORTED;
2796 /* case EABANDONED */
2798 return SS$_ABORT; /* punt */
2801 return SS$_ABORT; /* Should not get here */
2805 /* default piping mailbox size */
2806 #define PERL_BUFSIZ 512
2810 create_mbx(unsigned short int *chan, struct dsc$descriptor_s *namdsc)
2812 unsigned long int mbxbufsiz;
2813 static unsigned long int syssize = 0;
2814 unsigned long int dviitm = DVI$_DEVNAM;
2815 char csize[LNM$C_NAMLENGTH+1];
2819 unsigned long syiitm = SYI$_MAXBUF;
2821 * Get the SYSGEN parameter MAXBUF
2823 * If the logical 'PERL_MBX_SIZE' is defined
2824 * use the value of the logical instead of PERL_BUFSIZ, but
2825 * keep the size between 128 and MAXBUF.
2828 _ckvmssts_noperl(lib$getsyi(&syiitm, &syssize, 0, 0, 0, 0));
2831 if (vmstrnenv("PERL_MBX_SIZE", csize, 0, fildev, 0)) {
2832 mbxbufsiz = atoi(csize);
2834 mbxbufsiz = PERL_BUFSIZ;
2836 if (mbxbufsiz < 128) mbxbufsiz = 128;
2837 if (mbxbufsiz > syssize) mbxbufsiz = syssize;
2839 _ckvmssts_noperl(sts = sys$crembx(0,chan,mbxbufsiz,mbxbufsiz,0,0,0));
2841 sts = lib$getdvi(&dviitm, chan, NULL, NULL, namdsc, &namdsc->dsc$w_length);
2842 _ckvmssts_noperl(sts);
2843 namdsc->dsc$a_pointer[namdsc->dsc$w_length] = '\0';
2845 } /* end of create_mbx() */
2848 /*{{{ my_popen and my_pclose*/
2850 typedef struct _iosb IOSB;
2851 typedef struct _iosb* pIOSB;
2852 typedef struct _pipe Pipe;
2853 typedef struct _pipe* pPipe;
2854 typedef struct pipe_details Info;
2855 typedef struct pipe_details* pInfo;
2856 typedef struct _srqp RQE;
2857 typedef struct _srqp* pRQE;
2858 typedef struct _tochildbuf CBuf;
2859 typedef struct _tochildbuf* pCBuf;
2862 unsigned short status;
2863 unsigned short count;
2864 unsigned long dvispec;
2867 #pragma member_alignment save
2868 #pragma nomember_alignment quadword
2869 struct _srqp { /* VMS self-relative queue entry */
2870 unsigned long qptr[2];
2872 #pragma member_alignment restore
2873 static RQE RQE_ZERO = {0,0};
2875 struct _tochildbuf {
2878 unsigned short size;
2886 unsigned short chan_in;
2887 unsigned short chan_out;
2889 unsigned int bufsize;
2901 #if defined(PERL_IMPLICIT_CONTEXT)
2902 void *thx; /* Either a thread or an interpreter */
2903 /* pointer, depending on how we're built */
2911 PerlIO *fp; /* file pointer to pipe mailbox */
2912 int useFILE; /* using stdio, not perlio */
2913 int pid; /* PID of subprocess */
2914 int mode; /* == 'r' if pipe open for reading */
2915 int done; /* subprocess has completed */
2916 int waiting; /* waiting for completion/closure */
2917 int closing; /* my_pclose is closing this pipe */
2918 unsigned long completion; /* termination status of subprocess */
2919 pPipe in; /* pipe in to sub */
2920 pPipe out; /* pipe out of sub */
2921 pPipe err; /* pipe of sub's sys$error */
2922 int in_done; /* true when in pipe finished */
2925 unsigned short xchan; /* channel to debug xterm */
2926 unsigned short xchan_valid; /* channel is assigned */
2929 struct exit_control_block
2931 struct exit_control_block *flink;
2932 unsigned long int (*exit_routine)();
2933 unsigned long int arg_count;
2934 unsigned long int *status_address;
2935 unsigned long int exit_status;
2938 typedef struct _closed_pipes Xpipe;
2939 typedef struct _closed_pipes* pXpipe;
2941 struct _closed_pipes {
2942 int pid; /* PID of subprocess */
2943 unsigned long completion; /* termination status of subprocess */
2945 #define NKEEPCLOSED 50
2946 static Xpipe closed_list[NKEEPCLOSED];
2947 static int closed_index = 0;
2948 static int closed_num = 0;
2950 #define RETRY_DELAY "0 ::0.20"
2951 #define MAX_RETRY 50
2953 static int pipe_ef = 0; /* first call to safe_popen inits these*/
2954 static unsigned long mypid;
2955 static unsigned long delaytime[2];
2957 static pInfo open_pipes = NULL;
2958 static $DESCRIPTOR(nl_desc, "NL:");
2960 #define PIPE_COMPLETION_WAIT 30 /* seconds, for EOF/FORCEX wait */
2964 static unsigned long int
2968 unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT;
2969 int sts, did_stuff, need_eof, j;
2972 * Flush any pending i/o, but since we are in process run-down, be
2973 * careful about referencing PerlIO structures that may already have
2974 * been deallocated. We may not even have an interpreter anymore.
2979 #if defined(PERL_IMPLICIT_CONTEXT)
2980 /* We need to use the Perl context of the thread that created */
2984 aTHX = info->err->thx;
2986 aTHX = info->out->thx;
2988 aTHX = info->in->thx;
2991 #if defined(USE_ITHREADS)
2994 && PL_perlio_fd_refcnt)
2995 PerlIO_flush(info->fp);
2997 fflush((FILE *)info->fp);
3003 next we try sending an EOF...ignore if doesn't work, make sure we
3011 _ckvmssts_noperl(sys$setast(0));
3012 if (info->in && !info->in->shut_on_empty) {
3013 _ckvmssts_noperl(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
3018 _ckvmssts_noperl(sys$setast(1));
3022 /* wait for EOF to have effect, up to ~ 30 sec [default] */
3024 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3029 _ckvmssts_noperl(sys$setast(0));
3030 if (info->waiting && info->done)
3032 nwait += info->waiting;
3033 _ckvmssts_noperl(sys$setast(1));
3043 _ckvmssts_noperl(sys$setast(0));
3044 if (!info->done) { /* Tap them gently on the shoulder . . .*/
3045 sts = sys$forcex(&info->pid,0,&abort);
3046 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3049 _ckvmssts_noperl(sys$setast(1));
3053 /* again, wait for effect */
3055 for (j = 0; did_stuff && j < PIPE_COMPLETION_WAIT; j++) {
3060 _ckvmssts_noperl(sys$setast(0));
3061 if (info->waiting && info->done)
3063 nwait += info->waiting;
3064 _ckvmssts_noperl(sys$setast(1));
3073 _ckvmssts_noperl(sys$setast(0));
3074 if (!info->done) { /* We tried to be nice . . . */
3075 sts = sys$delprc(&info->pid,0);
3076 if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts);
3077 info->done = 1; /* sys$delprc is as done as we're going to get. */
3079 _ckvmssts_noperl(sys$setast(1));
3085 #if defined(PERL_IMPLICIT_CONTEXT)
3086 /* We need to use the Perl context of the thread that created */
3089 if (open_pipes->err)
3090 aTHX = open_pipes->err->thx;
3091 else if (open_pipes->out)
3092 aTHX = open_pipes->out->thx;
3093 else if (open_pipes->in)
3094 aTHX = open_pipes->in->thx;
3096 if ((sts = my_pclose(open_pipes->fp)) == -1) retsts = vaxc$errno;
3097 else if (!(sts & 1)) retsts = sts;
3102 static struct exit_control_block pipe_exitblock =
3103 {(struct exit_control_block *) 0,
3104 pipe_exit_routine, 0, &pipe_exitblock.exit_status, 0};
3106 static void pipe_mbxtofd_ast(pPipe p);
3107 static void pipe_tochild1_ast(pPipe p);
3108 static void pipe_tochild2_ast(pPipe p);
3111 popen_completion_ast(pInfo info)
3113 pInfo i = open_pipes;
3118 info->completion &= 0x0FFFFFFF; /* strip off "control" field */
3119 closed_list[closed_index].pid = info->pid;
3120 closed_list[closed_index].completion = info->completion;
3122 if (closed_index == NKEEPCLOSED)
3127 if (i == info) break;
3130 if (!i) return; /* unlinked, probably freed too */
3135 Writing to subprocess ...
3136 if my_pclose'd: EOF already sent, should shutdown chan_in part of pipe
3138 chan_out may be waiting for "done" flag, or hung waiting
3139 for i/o completion to child...cancel the i/o. This will
3140 put it into "snarf mode" (done but no EOF yet) that discards
3143 Output from subprocess (stdout, stderr) needs to be flushed and
3144 shut down. We try sending an EOF, but if the mbx is full the pipe
3145 routine should still catch the "shut_on_empty" flag, telling it to
3146 use immediate-style reads so that "mbx empty" -> EOF.
3150 if (info->in && !info->in_done) { /* only for mode=w */
3151 if (info->in->shut_on_empty && info->in->need_wake) {
3152 info->in->need_wake = FALSE;
3153 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,info->in,0));
3155 _ckvmssts_noperl(sys$cancel(info->in->chan_out));
3159 if (info->out && !info->out_done) { /* were we also piping output? */
3160 info->out->shut_on_empty = TRUE;
3161 iss = sys$qio(0,info->out->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3162 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3163 _ckvmssts_noperl(iss);
3166 if (info->err && !info->err_done) { /* we were piping stderr */
3167 info->err->shut_on_empty = TRUE;
3168 iss = sys$qio(0,info->err->chan_in,IO$_WRITEOF|IO$M_NORSWAIT, 0, 0, 0, 0, 0, 0, 0, 0, 0);
3169 if (iss == SS$_MBFULL) iss = SS$_NORMAL;
3170 _ckvmssts_noperl(iss);
3172 _ckvmssts_noperl(sys$setef(pipe_ef));
3176 static unsigned long int setup_cmddsc(pTHX_ const char *cmd, int check_img, int *suggest_quote, struct dsc$descriptor_s **pvmscmd);
3177 static void vms_execfree(struct dsc$descriptor_s *vmscmd);
3180 we actually differ from vmstrnenv since we use this to
3181 get the RMS IFI to check if SYS$OUTPUT and SYS$ERROR *really*
3182 are pointing to the same thing
3185 static unsigned short
3186 popen_translate(pTHX_ char *logical, char *result)
3189 $DESCRIPTOR(d_table,"LNM$PROCESS_TABLE");
3190 $DESCRIPTOR(d_log,"");
3192 unsigned short length;
3193 unsigned short code;
3195 unsigned short *retlenaddr;
3197 unsigned short l, ifi;
3199 d_log.dsc$a_pointer = logical;
3200 d_log.dsc$w_length = strlen(logical);
3202 itmlst[0].code = LNM$_STRING;
3203 itmlst[0].length = 255;
3204 itmlst[0].buffer_addr = result;
3205 itmlst[0].retlenaddr = &l;
3208 itmlst[1].length = 0;
3209 itmlst[1].buffer_addr = 0;
3210 itmlst[1].retlenaddr = 0;
3212 iss = sys$trnlnm(0, &d_table, &d_log, 0, itmlst);
3213 if (iss == SS$_NOLOGNAM) {
3217 if (!(iss&1)) lib$signal(iss);
3220 logicals for PPFs have a 4 byte prefix ESC+NUL+(RMS IFI)
3221 strip it off and return the ifi, if any
3224 if (result[0] == 0x1b && result[1] == 0x00) {
3225 memmove(&ifi,result+2,2);
3226 strcpy(result,result+4);
3228 return ifi; /* this is the RMS internal file id */
3231 static void pipe_infromchild_ast(pPipe p);
3234 I'm using LIB$(GET|FREE)_VM here so that we can allocate and deallocate
3235 inside an AST routine without worrying about reentrancy and which Perl
3236 memory allocator is being used.
3238 We read data and queue up the buffers, then spit them out one at a
3239 time to the output mailbox when the output mailbox is ready for one.
3242 #define INITIAL_TOCHILDQUEUE 2
3245 pipe_tochild_setup(pTHX_ char *rmbx, char *wmbx)
3249 char mbx1[64], mbx2[64];
3250 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3251 DSC$K_CLASS_S, mbx1},
3252 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3253 DSC$K_CLASS_S, mbx2};
3254 unsigned int dviitm = DVI$_DEVBUFSIZ;
3258 _ckvmssts_noperl(lib$get_vm(&n, &p));
3260 create_mbx(&p->chan_in , &d_mbx1);
3261 create_mbx(&p->chan_out, &d_mbx2);
3262 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3265 p->shut_on_empty = FALSE;
3266 p->need_wake = FALSE;
3269 p->iosb.status = SS$_NORMAL;
3270 p->iosb2.status = SS$_NORMAL;
3276 #ifdef PERL_IMPLICIT_CONTEXT
3280 n = sizeof(CBuf) + p->bufsize;
3282 for (j = 0; j < INITIAL_TOCHILDQUEUE; j++) {
3283 _ckvmssts_noperl(lib$get_vm(&n, &b));
3284 b->buf = (char *) b + sizeof(CBuf);
3285 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3288 pipe_tochild2_ast(p);
3289 pipe_tochild1_ast(p);
3295 /* reads the MBX Perl is writing, and queues */
3298 pipe_tochild1_ast(pPipe p)
3301 int iss = p->iosb.status;
3302 int eof = (iss == SS$_ENDOFFILE);
3304 #ifdef PERL_IMPLICIT_CONTEXT
3310 p->shut_on_empty = TRUE;
3312 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3314 _ckvmssts_noperl(iss);
3318 b->size = p->iosb.count;
3319 _ckvmssts_noperl(sts = lib$insqhi(b, &p->wait));
3321 p->need_wake = FALSE;
3322 _ckvmssts_noperl(sys$dclast(pipe_tochild2_ast,p,0));
3325 p->retry = 1; /* initial call */
3328 if (eof) { /* flush the free queue, return when done */
3329 int n = sizeof(CBuf) + p->bufsize;
3331 iss = lib$remqti(&p->free, &b);
3332 if (iss == LIB$_QUEWASEMP) return;
3333 _ckvmssts_noperl(iss);
3334 _ckvmssts_noperl(lib$free_vm(&n, &b));
3338 iss = lib$remqti(&p->free, &b);
3339 if (iss == LIB$_QUEWASEMP) {
3340 int n = sizeof(CBuf) + p->bufsize;
3341 _ckvmssts_noperl(lib$get_vm(&n, &b));
3342 b->buf = (char *) b + sizeof(CBuf);
3344 _ckvmssts_noperl(iss);
3348 iss = sys$qio(0,p->chan_in,
3349 IO$_READVBLK|(p->shut_on_empty ? IO$M_NOWAIT : 0),
3351 pipe_tochild1_ast, p, b->buf, p->bufsize, 0, 0, 0, 0);
3352 if (iss == SS$_ENDOFFILE && p->shut_on_empty) iss = SS$_NORMAL;
3353 _ckvmssts_noperl(iss);
3357 /* writes queued buffers to output, waits for each to complete before
3361 pipe_tochild2_ast(pPipe p)
3364 int iss = p->iosb2.status;
3365 int n = sizeof(CBuf) + p->bufsize;
3366 int done = (p->info && p->info->done) ||
3367 iss == SS$_CANCEL || iss == SS$_ABORT;
3368 #if defined(PERL_IMPLICIT_CONTEXT)
3373 if (p->type) { /* type=1 has old buffer, dispose */
3374 if (p->shut_on_empty) {
3375 _ckvmssts_noperl(lib$free_vm(&n, &b));
3377 _ckvmssts_noperl(lib$insqhi(b, &p->free));
3382 iss = lib$remqti(&p->wait, &b);
3383 if (iss == LIB$_QUEWASEMP) {
3384 if (p->shut_on_empty) {
3386 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3387 *p->pipe_done = TRUE;
3388 _ckvmssts_noperl(sys$setef(pipe_ef));
3390 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3391 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3395 p->need_wake = TRUE;
3398 _ckvmssts_noperl(iss);
3405 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF,
3406 &p->iosb2, pipe_tochild2_ast, p, 0, 0, 0, 0, 0, 0));
3408 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,
3409 &p->iosb2, pipe_tochild2_ast, p, b->buf, b->size, 0, 0, 0, 0));
3418 pipe_infromchild_setup(pTHX_ char *rmbx, char *wmbx)
3421 char mbx1[64], mbx2[64];
3422 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
3423 DSC$K_CLASS_S, mbx1},
3424 d_mbx2 = {sizeof mbx2, DSC$K_DTYPE_T,
3425 DSC$K_CLASS_S, mbx2};
3426 unsigned int dviitm = DVI$_DEVBUFSIZ;
3428 int n = sizeof(Pipe);
3429 _ckvmssts_noperl(lib$get_vm(&n, &p));
3430 create_mbx(&p->chan_in , &d_mbx1);
3431 create_mbx(&p->chan_out, &d_mbx2);
3433 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3434 n = p->bufsize * sizeof(char);
3435 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3436 p->shut_on_empty = FALSE;
3439 p->iosb.status = SS$_NORMAL;
3440 #if defined(PERL_IMPLICIT_CONTEXT)
3443 pipe_infromchild_ast(p);
3451 pipe_infromchild_ast(pPipe p)
3453 int iss = p->iosb.status;
3454 int eof = (iss == SS$_ENDOFFILE);
3455 int myeof = (eof && (p->iosb.dvispec == mypid || p->iosb.dvispec == 0));
3456 int kideof = (eof && (p->iosb.dvispec == p->info->pid));
3457 #if defined(PERL_IMPLICIT_CONTEXT)
3461 if (p->info && p->info->closing && p->chan_out) { /* output shutdown */
3462 _ckvmssts_noperl(sys$dassgn(p->chan_out));
3467 input shutdown if EOF from self (done or shut_on_empty)
3468 output shutdown if closing flag set (my_pclose)
3469 send data/eof from child or eof from self
3470 otherwise, re-read (snarf of data from child)
3475 if (myeof && p->chan_in) { /* input shutdown */
3476 _ckvmssts_noperl(sys$dassgn(p->chan_in));
3481 if (myeof || kideof) { /* pass EOF to parent */
3482 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEOF, &p->iosb,
3483 pipe_infromchild_ast, p,
3486 } else if (eof) { /* eat EOF --- fall through to read*/
3488 } else { /* transmit data */
3489 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_WRITEVBLK,&p->iosb,
3490 pipe_infromchild_ast,p,
3491 p->buf, p->iosb.count, 0, 0, 0, 0));
3497 /* everything shut? flag as done */
3499 if (!p->chan_in && !p->chan_out) {
3500 *p->pipe_done = TRUE;
3501 _ckvmssts_noperl(sys$setef(pipe_ef));
3505 /* write completed (or read, if snarfing from child)
3506 if still have input active,
3507 queue read...immediate mode if shut_on_empty so we get EOF if empty
3509 check if Perl reading, generate EOFs as needed
3515 iss = sys$qio(0,p->chan_in,IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0),&p->iosb,
3516 pipe_infromchild_ast,p,
3517 p->buf, p->bufsize, 0, 0, 0, 0);
3518 if (p->shut_on_empty && iss == SS$_ENDOFFILE) iss = SS$_NORMAL;
3519 _ckvmssts_noperl(iss);
3520 } else { /* send EOFs for extra reads */
3521 p->iosb.status = SS$_ENDOFFILE;
3522 p->iosb.dvispec = 0;
3523 _ckvmssts_noperl(sys$qio(0,p->chan_out,IO$_SETMODE|IO$M_READATTN,
3525 pipe_infromchild_ast, p, 0, 0, 0, 0));
3531 pipe_mbxtofd_setup(pTHX_ int fd, char *out)
3535 unsigned long dviitm = DVI$_DEVBUFSIZ;
3537 struct dsc$descriptor_s d_mbx = {sizeof mbx, DSC$K_DTYPE_T,
3538 DSC$K_CLASS_S, mbx};
3539 int n = sizeof(Pipe);
3541 /* things like terminals and mbx's don't need this filter */
3542 if (fd && fstat(fd,&s) == 0) {
3543 unsigned long dviitm = DVI$_DEVCHAR, devchar;
3545 unsigned short dev_len;
3546 struct dsc$descriptor_s d_dev;
3548 struct item_list_3 items[3];
3550 unsigned short dvi_iosb[4];
3552 cptr = getname(fd, out, 1);
3553 if (cptr == NULL) _ckvmssts_noperl(SS$_NOSUCHDEV);
3554 d_dev.dsc$a_pointer = out;
3555 d_dev.dsc$w_length = strlen(out);
3556 d_dev.dsc$b_dtype = DSC$K_DTYPE_T;
3557 d_dev.dsc$b_class = DSC$K_CLASS_S;
3560 items[0].code = DVI$_DEVCHAR;
3561 items[0].bufadr = &devchar;
3562 items[0].retadr = NULL;
3564 items[1].code = DVI$_FULLDEVNAM;
3565 items[1].bufadr = device;
3566 items[1].retadr = &dev_len;
3570 status = sys$getdviw
3571 (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL);
3572 _ckvmssts_noperl(status);
3573 if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) {
3574 device[dev_len] = 0;
3576 if (!(devchar & DEV$M_DIR)) {
3577 strcpy(out, device);
3583 _ckvmssts_noperl(lib$get_vm(&n, &p));
3584 p->fd_out = dup(fd);
3585 create_mbx(&p->chan_in, &d_mbx);
3586 _ckvmssts_noperl(lib$getdvi(&dviitm, &p->chan_in, 0, &p->bufsize));
3587 n = (p->bufsize+1) * sizeof(char);
3588 _ckvmssts_noperl(lib$get_vm(&n, &p->buf));
3589 p->shut_on_empty = FALSE;
3594 _ckvmssts_noperl(sys$qio(0, p->chan_in, IO$_READVBLK, &p->iosb,
3595 pipe_mbxtofd_ast, p,
3596 p->buf, p->bufsize, 0, 0, 0, 0));
3602 pipe_mbxtofd_ast(pPipe p)
3604 int iss = p->iosb.status;
3605 int done = p->info->done;
3607 int eof = (iss == SS$_ENDOFFILE);
3608 int myeof = eof && ((p->iosb.dvispec == mypid)||(p->iosb.dvispec == 0));
3609 int err = !(iss&1) && !eof;
3610 #if defined(PERL_IMPLICIT_CONTEXT)
3614 if (done && myeof) { /* end piping */
3616 sys$dassgn(p->chan_in);
3617 *p->pipe_done = TRUE;
3618 _ckvmssts_noperl(sys$setef(pipe_ef));
3622 if (!err && !eof) { /* good data to send to file */
3623 p->buf[p->iosb.count] = '\n';
3624 iss2 = write(p->fd_out, p->buf, p->iosb.count+1);
3627 if (p->retry < MAX_RETRY) {
3628 _ckvmssts_noperl(sys$setimr(0,delaytime,pipe_mbxtofd_ast,p));
3634 _ckvmssts_noperl(iss);
3638 iss = sys$qio(0, p->chan_in, IO$_READVBLK|(p->shut_on_empty ? IO$M_NOW : 0), &p->iosb,
3639 pipe_mbxtofd_ast, p,
3640 p->buf, p->bufsize, 0, 0, 0, 0);
3641 if (p->shut_on_empty && (iss == SS$_ENDOFFILE)) iss = SS$_NORMAL;
3642 _ckvmssts_noperl(iss);
3646 typedef struct _pipeloc PLOC;
3647 typedef struct _pipeloc* pPLOC;
3651 char dir[NAM$C_MAXRSS+1];
3653 static pPLOC head_PLOC = 0;
3656 free_pipelocs(pTHX_ void *head)
3659 pPLOC *pHead = (pPLOC *)head;
3671 store_pipelocs(pTHX)
3680 char temp[NAM$C_MAXRSS+1];
3684 free_pipelocs(aTHX_ &head_PLOC);
3686 /* the . directory from @INC comes last */
3688 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3689 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3690 p->next = head_PLOC;
3692 strcpy(p->dir,"./");
3694 /* get the directory from $^X */
3696 unixdir = PerlMem_malloc(VMS_MAXRSS);
3697 if (unixdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3699 #ifdef PERL_IMPLICIT_CONTEXT
3700 if (aTHX && PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3702 if (PL_origargv && PL_origargv[0]) { /* maybe nul if embedded Perl */
3704 strcpy(temp, PL_origargv[0]);
3705 x = strrchr(temp,']');
3707 x = strrchr(temp,'>');
3709 /* It could be a UNIX path */
3710 x = strrchr(temp,'/');
3716 /* Got a bare name, so use default directory */
3721 if ((tounixpath_utf8(temp, unixdir, NULL)) != NULL) {
3722 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3723 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3724 p->next = head_PLOC;
3726 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3727 p->dir[NAM$C_MAXRSS] = '\0';
3731 /* reverse order of @INC entries, skip "." since entered above */
3733 #ifdef PERL_IMPLICIT_CONTEXT
3736 if (PL_incgv) av = GvAVn(PL_incgv);
3738 for (i = 0; av && i <= AvFILL(av); i++) {
3739 dirsv = *av_fetch(av,i,TRUE);
3741 if (SvROK(dirsv)) continue;
3742 dir = SvPVx(dirsv,n_a);
3743 if (strcmp(dir,".") == 0) continue;
3744 if ((tounixpath_utf8(dir, unixdir, NULL)) == NULL)
3747 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3748 p->next = head_PLOC;
3750 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3751 p->dir[NAM$C_MAXRSS] = '\0';
3754 /* most likely spot (ARCHLIB) put first in the list */
3757 if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != NULL) {
3758 p = (pPLOC) PerlMem_malloc(sizeof(PLOC));
3759 if (p == NULL) _ckvmssts_noperl(SS$_INSFMEM);
3760 p->next = head_PLOC;
3762 strncpy(p->dir,unixdir,sizeof(p->dir)-1);
3763 p->dir[NAM$C_MAXRSS] = '\0';
3766 PerlMem_free(unixdir);
3770 Perl_cando_by_name_int
3771 (pTHX_ I32 bit, bool effective, const char *fname, int opts);
3772 #if !defined(PERL_IMPLICIT_CONTEXT)
3773 #define cando_by_name_int Perl_cando_by_name_int
3775 #define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d)
3781 static int vmspipe_file_status = 0;
3782 static char vmspipe_file[NAM$C_MAXRSS+1];
3784 /* already found? Check and use ... need read+execute permission */
3786 if (vmspipe_file_status == 1) {
3787 if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3788 && cando_by_name_int
3789 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3790 return vmspipe_file;
3792 vmspipe_file_status = 0;
3795 /* scan through stored @INC, $^X */
3797 if (vmspipe_file_status == 0) {
3798 char file[NAM$C_MAXRSS+1];
3799 pPLOC p = head_PLOC;
3804 strcpy(file, p->dir);
3805 dirlen = strlen(file);
3806 strncat(file, "vmspipe.com",NAM$C_MAXRSS - dirlen);
3807 file[NAM$C_MAXRSS] = '\0';
3810 exp_res = int_rmsexpand_tovms(file, vmspipe_file, 0);
3811 if (!exp_res) continue;
3813 if (cando_by_name_int
3814 (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)
3815 && cando_by_name_int
3816 (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) {
3817 vmspipe_file_status = 1;
3818 return vmspipe_file;
3821 vmspipe_file_status = -1; /* failed, use tempfiles */
3828 vmspipe_tempfile(pTHX)
3830 char file[NAM$C_MAXRSS+1];
3832 static int index = 0;
3836 /* create a tempfile */
3838 /* we can't go from W, shr=get to R, shr=get without
3839 an intermediate vulnerable state, so don't bother trying...
3841 and lib$spawn doesn't shr=put, so have to close the write
3843 So... match up the creation date/time and the FID to
3844 make sure we're dealing with the same file
3849 if (!decc_filename_unix_only) {
3850 sprintf(file,"sys$scratch:perlpipe_%08.8x_%d.com",mypid,index);
3851 fp = fopen(file,"w");
3853 sprintf(file,"sys$login:perlpipe_%08.8x_%d.com",mypid,index);
3854 fp = fopen(file,"w");
3856 sprintf(file,"sys$disk:[]perlpipe_%08.8x_%d.com",mypid,index);
3857 fp = fopen(file,"w");
3862 sprintf(file,"/tmp/perlpipe_%08.8x_%d.com",mypid,index);
3863 fp = fopen(file,"w");
3865 sprintf(file,"/sys$login/perlpipe_%08.8x_%d.com",mypid,index);
3866 fp = fopen(file,"w");
3868 sprintf(file,"./perlpipe_%08.8x_%d.com",mypid,index);
3869 fp = fopen(file,"w");
3873 if (!fp) return 0; /* we're hosed */
3875 fprintf(fp,"$! 'f$verify(0)'\n");
3876 fprintf(fp,"$! --- protect against nonstandard definitions ---\n");
3877 fprintf(fp,"$ perl_cfile = f$environment(\"procedure\")\n");
3878 fprintf(fp,"$ perl_define = \"define/nolog\"\n");
3879 fprintf(fp,"$ perl_on = \"set noon\"\n");
3880 fprintf(fp,"$ perl_exit = \"exit\"\n");
3881 fprintf(fp,"$ perl_del = \"delete\"\n");
3882 fprintf(fp,"$ pif = \"if\"\n");
3883 fprintf(fp,"$! --- define i/o redirection (sys$output set by lib$spawn)\n");
3884 fprintf(fp,"$ pif perl_popen_in .nes. \"\" then perl_define/user/name_attributes=confine sys$input 'perl_popen_in'\n");
3885 fprintf(fp,"$ pif perl_popen_err .nes. \"\" then perl_define/user/name_attributes=confine sys$error 'perl_popen_err'\n");
3886 fprintf(fp,"$ pif perl_popen_out .nes. \"\" then perl_define sys$output 'perl_popen_out'\n");
3887 fprintf(fp,"$! --- build command line to get max possible length\n");
3888 fprintf(fp,"$c=perl_popen_cmd0\n");
3889 fprintf(fp,"$c=c+perl_popen_cmd1\n");
3890 fprintf(fp,"$c=c+perl_popen_cmd2\n");
3891 fprintf(fp,"$x=perl_popen_cmd3\n");
3892 fprintf(fp,"$c=c+x\n");
3893 fprintf(fp,"$ perl_on\n");
3894 fprintf(fp,"$ 'c'\n");
3895 fprintf(fp,"$ perl_status = $STATUS\n");
3896 fprintf(fp,"$ perl_del 'perl_cfile'\n");
3897 fprintf(fp,"$ perl_exit 'perl_status'\n");
3900 fgetname(fp, file, 1);
3901 fstat(fileno(fp), (struct stat *)&s0);
3904 if (decc_filename_unix_only)
3905 int_tounixspec(file, file, NULL);
3906 fp = fopen(file,"r","shr=get");
3908 fstat(fileno(fp), (struct stat *)&s1);
3910 cmp_result = VMS_INO_T_COMPARE(s0.crtl_stat.st_ino, s1.crtl_stat.st_ino);
3911 if ((cmp_result != 0) && (s0.st_ctime != s1.st_ctime)) {
3920 static int vms_is_syscommand_xterm(void)
3922 const static struct dsc$descriptor_s syscommand_dsc =
3923 { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" };
3925 const static struct dsc$descriptor_s decwdisplay_dsc =
3926 { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" };
3928 struct item_list_3 items[2];
3929 unsigned short dvi_iosb[4];
3930 unsigned long devchar;
3931 unsigned long devclass;
3934 /* Very simple check to guess if sys$command is a decterm? */
3935 /* First see if the DECW$DISPLAY: device exists */
3937 items[0].code = DVI$_DEVCHAR;
3938 items[0].bufadr = &devchar;
3939 items[0].retadr = NULL;
3943 status = sys$getdviw
3944 (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL);
3946 if ($VMS_STATUS_SUCCESS(status)) {
3947 status = dvi_iosb[0];
3950 if (!$VMS_STATUS_SUCCESS(status)) {
3951 SETERRNO(EVMSERR, status);
3955 /* If it does, then for now assume that we are on a workstation */
3956 /* Now verify that SYS$COMMAND is a terminal */
3957 /* for creating the debugger DECTerm */
3960 items[0].code = DVI$_DEVCLASS;
3961 items[0].bufadr = &devclass;
3962 items[0].retadr = NULL;
3966 status = sys$getdviw
3967 (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL);
3969 if ($VMS_STATUS_SUCCESS(status)) {
3970 status = dvi_iosb[0];
3973 if (!$VMS_STATUS_SUCCESS(status)) {
3974 SETERRNO(EVMSERR, status);
3978 if (devclass == DC$_TERM) {
3985 /* If we are on a DECTerm, we can pretend to fork xterms when requested */
3986 static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode)
3991 char device_name[65];
3992 unsigned short device_name_len;
3993 struct dsc$descriptor_s customization_dsc;
3994 struct dsc$descriptor_s device_name_dsc;
3997 char customization[200];
4001 unsigned short p_chan;
4003 unsigned short iosb[4];
4004 struct item_list_3 items[2];
4005 const char * cust_str =
4006 "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n";
4007 struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T,
4008 DSC$K_CLASS_S, mbx1};
4010 /* LIB$FIND_IMAGE_SIGNAL needs a handler */
4011 /*---------------------------------------*/
4012 VAXC$ESTABLISH((__vms_handler)lib$sig_to_ret);
4015 /* Make sure that this is from the Perl debugger */
4016 ret_char = strstr(cmd," xterm ");
4017 if (ret_char == NULL)
4019 cptr = ret_char + 7;
4020 ret_char = strstr(cmd,"tty");
4021 if (ret_char == NULL)
4023 ret_char = strstr(cmd,"sleep");
4024 if (ret_char == NULL)
4027 if (decw_term_port == 0) {
4028 $DESCRIPTOR(filename1_dsc, "DECW$TERMINALSHR12");
4029 $DESCRIPTOR(filename2_dsc, "DECW$TERMINALSHR");
4030 $DESCRIPTOR(decw_term_port_dsc, "DECW$TERM_PORT");
4032 status = lib$find_image_symbol
4034 &decw_term_port_dsc,
4035 (void *)&decw_term_port,
4039 /* Try again with the other image name */
4040 if (!$VMS_STATUS_SUCCESS(status)) {
4042 status = lib$find_image_symbol
4044 &decw_term_port_dsc,
4045 (void *)&decw_term_port,
4054 /* No decw$term_port, give it up */
4055 if (!$VMS_STATUS_SUCCESS(status))
4058 /* Are we on a workstation? */
4059 /* to do: capture the rows / columns and pass their properties */
4060 ret_stat = vms_is_syscommand_xterm();
4064 /* Make the title: */
4065 ret_char = strstr(cptr,"-title");
4066 if (ret_char != NULL) {
4067 while ((*cptr != 0) && (*cptr != '\"')) {
4073 while ((*cptr != 0) && (*cptr != '\"')) {
4086 strcpy(title,"Perl Debug DECTerm");
4088 sprintf(customization, cust_str, title);
4090 customization_dsc.dsc$a_pointer = customization;
4091 customization_dsc.dsc$w_length = strlen(customization);
4092 customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4093 customization_dsc.dsc$b_class = DSC$K_CLASS_S;
4095 device_name_dsc.dsc$a_pointer = device_name;
4096 device_name_dsc.dsc$w_length = sizeof device_name -1;
4097 device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
4098 device_name_dsc.dsc$b_class = DSC$K_CLASS_S;
4100 device_name_len = 0;
4102 /* Try to create the window */
4103 status = (*decw_term_port)
4112 if (!$VMS_STATUS_SUCCESS(status)) {
4113 SETERRNO(EVMSERR, status);
4117 device_name[device_name_len] = '\0';
4119 /* Need to set this up to look like a pipe for cleanup */
4121 status = lib$get_vm(&n, &info);
4122 if (!$VMS_STATUS_SUCCESS(status)) {
4123 SETERRNO(ENOMEM, status);
4129 info->completion = 0;
4130 info->closing = FALSE;
4137 info->in_done = TRUE;
4138 info->out_done = TRUE;
4139 info->err_done = TRUE;
4141 /* Assign a channel on this so that it will persist, and not login */
4142 /* We stash this channel in the info structure for reference. */
4143 /* The created xterm self destructs when the last channel is removed */
4144 /* and it appears that perl5db.pl (perl debugger) does this routinely */
4145 /* So leave this assigned. */
4146 device_name_dsc.dsc$w_length = device_name_len;
4147 status = sys$assign(&device_name_dsc,&info->xchan,0,0);
4148 if (!$VMS_STATUS_SUCCESS(status)) {
4149 SETERRNO(EVMSERR, status);
4152 info->xchan_valid = 1;
4154 /* Now create a mailbox to be read by the application */
4156 create_mbx(&p_chan, &d_mbx1);
4158 /* write the name of the created terminal to the mailbox */
4159 status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW,
4160 iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0);
4162 if (!$VMS_STATUS_SUCCESS(status)) {
4163 SETERRNO(EVMSERR, status);
4167 info->fp = PerlIO_open(mbx1, mode);
4169 /* Done with this channel */
4172 /* If any errors, then clean up */
4175 _ckvmssts_noperl(lib$free_vm(&n, &info));
4183 static I32 my_pclose_pinfo(pTHX_ pInfo info);
4186 safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts)
4188 static int handler_set_up = FALSE;
4190 unsigned long int sts, flags = CLI$M_NOWAIT;
4191 /* The use of a GLOBAL table (as was done previously) rendered
4192 * Perl's qx() or `` unusable from a C<$ SET SYMBOL/SCOPE=NOGLOBAL> DCL
4193 * environment. Hence we've switched to LOCAL symbol table.
4195 unsigned int table = LIB$K_CLI_LOCAL_SYM;
4197 char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe;
4198 char *in, *out, *err, mbx[512];
4200 char tfilebuf[NAM$C_MAXRSS+1];
4202 char cmd_sym_name[20];
4203 struct dsc$descriptor_s d_symbol= {0, DSC$K_DTYPE_T,
4204 DSC$K_CLASS_S, symbol};
4205 struct dsc$descriptor_s vmspipedsc = {0, DSC$K_DTYPE_T,
4207 struct dsc$descriptor_s d_sym_cmd = {0, DSC$K_DTYPE_T,
4208 DSC$K_CLASS_S, cmd_sym_name};
4209 struct dsc$descriptor_s *vmscmd;
4210 $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN");
4211 $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT");
4212 $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR");
4214 /* Check here for Xterm create request. This means looking for
4215 * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it
4216 * is possible to create an xterm.
4218 if (*in_mode == 'r') {
4221 xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode);
4222 if (xterm_fd != NULL)
4226 if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */
4228 /* once-per-program initialization...
4229 note that the SETAST calls and the dual test of pipe_ef
4230 makes sure that only the FIRST thread through here does
4231 the initialization...all other threads wait until it's
4234 Yeah, uglier than a pthread call, it's got all the stuff inline
4235 rather than in a separate routine.
4239 _ckvmssts_noperl(sys$setast(0));
4241 unsigned long int pidcode = JPI$_PID;
4242 $DESCRIPTOR(d_delay, RETRY_DELAY);
4243 _ckvmssts_noperl(lib$get_ef(&pipe_ef));
4244 _ckvmssts_noperl(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4245 _ckvmssts_noperl(sys$bintim(&d_delay, delaytime));
4247 if (!handler_set_up) {
4248 _ckvmssts_noperl(sys$dclexh(&pipe_exitblock));
4249 handler_set_up = TRUE;
4251 _ckvmssts_noperl(sys$setast(1));
4254 /* see if we can find a VMSPIPE.COM */
4257 vmspipe = find_vmspipe(aTHX);
4259 strcpy(tfilebuf+1,vmspipe);
4260 } else { /* uh, oh...we're in tempfile hell */
4261 tpipe = vmspipe_tempfile(aTHX);
4262 if (!tpipe) { /* a fish popular in Boston */
4263 if (ckWARN(WARN_PIPE)) {
4264 Perl_warner(aTHX_ packWARN(WARN_PIPE),"unable to find VMSPIPE.COM for i/o piping");
4268 fgetname(tpipe,tfilebuf+1,1);
4270 vmspipedsc.dsc$a_pointer = tfilebuf;
4271 vmspipedsc.dsc$w_length = strlen(tfilebuf);
4273 sts = setup_cmddsc(aTHX_ cmd,0,0,&vmscmd);
4276 case RMS$_FNF: case RMS$_DNF:
4277 set_errno(ENOENT); break;
4279 set_errno(ENOTDIR); break;
4281 set_errno(ENODEV); break;
4283 set_errno(EACCES); break;
4285 set_errno(EINVAL); break;
4286 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
4287 set_errno(E2BIG); break;
4288 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
4289 _ckvmssts_noperl(sts); /* fall through */
4290 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
4293 set_vaxc_errno(sts);
4294 if (*in_mode != 'n' && ckWARN(WARN_PIPE)) {
4295 Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno));
4301 _ckvmssts_noperl(lib$get_vm(&n, &info));
4303 strcpy(mode,in_mode);
4306 info->completion = 0;
4307 info->closing = FALSE;
4314 info->in_done = TRUE;
4315 info->out_done = TRUE;
4316 info->err_done = TRUE;
4318 info->xchan_valid = 0;
4320 in = PerlMem_malloc(VMS_MAXRSS);
4321 if (in == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4322 out = PerlMem_malloc(VMS_MAXRSS);
4323 if (out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4324 err = PerlMem_malloc(VMS_MAXRSS);
4325 if (err == NULL) _ckvmssts_noperl(SS$_INSFMEM);
4327 in[0] = out[0] = err[0] = '\0';
4329 if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */
4333 if ((p = strchr(mode,'W')) != NULL) { /* W -> wait for completion */
4338 if (*mode == 'r') { /* piping from subroutine */
4340 info->out = pipe_infromchild_setup(aTHX_ mbx,out);
4342 info->out->pipe_done = &info->out_done;
4343 info->out_done = FALSE;
4344 info->out->info = info;
4346 if (!info->useFILE) {
4347 info->fp = PerlIO_open(mbx, mode);
4349 info->fp = (PerlIO *) freopen(mbx, mode, stdin);
4350 Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx);
4353 if (!info->fp && info->out) {
4354 sys$cancel(info->out->chan_out);
4356 while (!info->out_done) {
4358 _ckvmssts_noperl(sys$setast(0));
4359 done = info->out_done;
4360 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4361 _ckvmssts_noperl(sys$setast(1));
4362 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4365 if (info->out->buf) {
4366 n = info->out->bufsize * sizeof(char);
4367 _ckvmssts_noperl(lib$free_vm(&n, &info->out->buf));
4370 _ckvmssts_noperl(lib$free_vm(&n, &info->out));
4372 _ckvmssts_noperl(lib$free_vm(&n, &info));
4377 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4379 info->err->pipe_done = &info->err_done;
4380 info->err_done = FALSE;
4381 info->err->info = info;
4384 } else if (*mode == 'w') { /* piping to subroutine */
4386 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4388 info->out->pipe_done = &info->out_done;
4389 info->out_done = FALSE;
4390 info->out->info = info;
4393 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4395 info->err->pipe_done = &info->err_done;
4396 info->err_done = FALSE;
4397 info->err->info = info;
4400 info->in = pipe_tochild_setup(aTHX_ in,mbx);
4401 if (!info->useFILE) {
4402 info->fp = PerlIO_open(mbx, mode);
4404 info->fp = (PerlIO *) freopen(mbx, mode, stdout);
4405 Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",mbx);
4409 info->in->pipe_done = &info->in_done;
4410 info->in_done = FALSE;
4411 info->in->info = info;
4415 if (!info->fp && info->in) {
4417 _ckvmssts_noperl(sys$qiow(0,info->in->chan_in, IO$_WRITEOF, 0,
4418 0, 0, 0, 0, 0, 0, 0, 0));
4420 while (!info->in_done) {
4422 _ckvmssts_noperl(sys$setast(0));
4423 done = info->in_done;
4424 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4425 _ckvmssts_noperl(sys$setast(1));
4426 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4429 if (info->in->buf) {
4430 n = info->in->bufsize * sizeof(char);
4431 _ckvmssts_noperl(lib$free_vm(&n, &info->in->buf));
4434 _ckvmssts_noperl(lib$free_vm(&n, &info->in));
4436 _ckvmssts_noperl(lib$free_vm(&n, &info));
4442 } else if (*mode == 'n') { /* separate subprocess, no Perl i/o */
4443 info->out = pipe_mbxtofd_setup(aTHX_ fileno(stdout), out);
4445 info->out->pipe_done = &info->out_done;
4446 info->out_done = FALSE;
4447 info->out->info = info;
4450 info->err = pipe_mbxtofd_setup(aTHX_ fileno(stderr), err);
4452 info->err->pipe_done = &info->err_done;
4453 info->err_done = FALSE;
4454 info->err->info = info;
4458 symbol[MAX_DCL_SYMBOL] = '\0';
4460 strncpy(symbol, in, MAX_DCL_SYMBOL);
4461 d_symbol.dsc$w_length = strlen(symbol);
4462 _ckvmssts_noperl(lib$set_symbol(&d_sym_in, &d_symbol, &table));
4464 strncpy(symbol, err, MAX_DCL_SYMBOL);
4465 d_symbol.dsc$w_length = strlen(symbol);
4466 _ckvmssts_noperl(lib$set_symbol(&d_sym_err, &d_symbol, &table));
4468 strncpy(symbol, out, MAX_DCL_SYMBOL);
4469 d_symbol.dsc$w_length = strlen(symbol);
4470 _ckvmssts_noperl(lib$set_symbol(&d_sym_out, &d_symbol, &table));
4472 /* Done with the names for the pipes */
4477 p = vmscmd->dsc$a_pointer;
4478 while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */
4479 if (*p == '$') p++; /* remove leading $ */
4480 while (*p == ' ' || *p == '\t') p++;
4482 for (j = 0; j < 4; j++) {
4483 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4484 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4486 strncpy(symbol, p, MAX_DCL_SYMBOL);
4487 d_symbol.dsc$w_length = strlen(symbol);
4488 _ckvmssts_noperl(lib$set_symbol(&d_sym_cmd, &d_symbol, &table));
4490 if (strlen(p) > MAX_DCL_SYMBOL) {
4491 p += MAX_DCL_SYMBOL;
4496 _ckvmssts_noperl(sys$setast(0));
4497 info->next=open_pipes; /* prepend to list */
4499 _ckvmssts_noperl(sys$setast(1));
4500 /* Omit arg 2 (input file) so the child will get the parent's SYS$INPUT
4501 * and SYS$COMMAND. vmspipe.com will redefine SYS$INPUT, but we'll still
4502 * have SYS$COMMAND if we need it.
4504 _ckvmssts_noperl(lib$spawn(&vmspipedsc, 0, &nl_desc, &flags,
4505 0, &info->pid, &info->completion,
4506 0, popen_completion_ast,info,0,0,0));
4508 /* if we were using a tempfile, close it now */
4510 if (tpipe) fclose(tpipe);
4512 /* once the subprocess is spawned, it has copied the symbols and
4513 we can get rid of ours */
4515 for (j = 0; j < 4; j++) {
4516 sprintf(cmd_sym_name,"PERL_POPEN_CMD%d",j);
4517 d_sym_cmd.dsc$w_length = strlen(cmd_sym_name);
4518 _ckvmssts_noperl(lib$delete_symbol(&d_sym_cmd, &table));
4520 _ckvmssts_noperl(lib$delete_symbol(&d_sym_in, &table));
4521 _ckvmssts_noperl(lib$delete_symbol(&d_sym_err, &table));
4522 _ckvmssts_noperl(lib$delete_symbol(&d_sym_out, &table));
4523 vms_execfree(vmscmd);
4525 #ifdef PERL_IMPLICIT_CONTEXT
4528 PL_forkprocess = info->pid;
4535 _ckvmssts_noperl(sys$setast(0));
4537 if (!done) _ckvmssts_noperl(sys$clref(pipe_ef));
4538 _ckvmssts_noperl(sys$setast(1));
4539 if (!done) _ckvmssts_noperl(sys$waitfr(pipe_ef));
4541 *psts = info->completion;
4542 /* Caller thinks it is open and tries to close it. */
4543 /* This causes some problems, as it changes the error status */
4544 /* my_pclose(info->fp); */
4546 /* If we did not have a file pointer open, then we have to */
4547 /* clean up here or eventually we will run out of something */
4549 if (info->fp == NULL) {
4550 my_pclose_pinfo(aTHX_ info);
4558 } /* end of safe_popen */
4561 /*{{{ PerlIO *my_popen(char *cmd, char *mode)*/
4563 Perl_my_popen(pTHX_ const char *cmd, const char *mode)
4567 TAINT_PROPER("popen");
4568 PERL_FLUSHALL_FOR_CHILD;
4569 return safe_popen(aTHX_ cmd,mode,&sts);
4575 /* Routine to close and cleanup a pipe info structure */
4577 static I32 my_pclose_pinfo(pTHX_ pInfo info) {
4579 unsigned long int retsts;
4584 /* If we were writing to a subprocess, insure that someone reading from
4585 * the mailbox gets an EOF. It looks like a simple fclose() doesn't
4586 * produce an EOF record in the mailbox.
4588 * well, at least sometimes it *does*, so we have to watch out for
4589 * the first EOF closing the pipe (and DASSGN'ing the channel)...
4593 #if defined(USE_ITHREADS)
4596 && PL_perlio_fd_refcnt)
4597 PerlIO_flush(info->fp);
4599 fflush((FILE *)info->fp);
4602 _ckvmssts(sys$setast(0));
4603 info->closing = TRUE;
4604 done = info->done && info->in_done && info->out_done && info->err_done;
4605 /* hanging on write to Perl's input? cancel it */
4606 if (info->mode == 'r' && info->out && !info->out_done) {
4607 if (info->out->chan_out) {
4608 _ckvmssts(sys$cancel(info->out->chan_out));
4609 if (!info->out->chan_in) { /* EOF generation, need AST */
4610 _ckvmssts(sys$dclast(pipe_infromchild_ast,info->out,0));
4614 if (info->in && !info->in_done && !info->in->shut_on_empty) /* EOF if hasn't had one yet */
4615 _ckvmssts(sys$qio(0,info->in->chan_in,IO$_WRITEOF,0,0,0,
4617 _ckvmssts(sys$setast(1));
4620 #if defined(USE_ITHREADS)
4623 && PL_perlio_fd_refcnt)
4624 PerlIO_close(info->fp);
4626 fclose((FILE *)info->fp);
4629 we have to wait until subprocess completes, but ALSO wait until all
4630 the i/o completes...otherwise we'll be freeing the "info" structure
4631 that the i/o ASTs could still be using...
4635 _ckvmssts(sys$setast(0));
4636 done = info->done && info->in_done && info->out_done && info->err_done;
4637 if (!done) _ckvmssts(sys$clref(pipe_ef));
4638 _ckvmssts(sys$setast(1));
4639 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4641 retsts = info->completion;
4643 /* remove from list of open pipes */
4644 _ckvmssts(sys$setast(0));
4646 for (next = open_pipes; next != NULL; last = next, next = next->next) {
4652 last->next = info->next;
4654 open_pipes = info->next;
4655 _ckvmssts(sys$setast(1));
4657 /* free buffers and structures */
4660 if (info->in->buf) {
4661 n = info->in->bufsize * sizeof(char);
4662 _ckvmssts(lib$free_vm(&n, &info->in->buf));
4665 _ckvmssts(lib$free_vm(&n, &info->in));
4668 if (info->out->buf) {
4669 n = info->out->bufsize * sizeof(char);
4670 _ckvmssts(lib$free_vm(&n, &info->out->buf));
4673 _ckvmssts(lib$free_vm(&n, &info->out));
4676 if (info->err->buf) {
4677 n = info->err->bufsize * sizeof(char);
4678 _ckvmssts(lib$free_vm(&n, &info->err->buf));
4681 _ckvmssts(lib$free_vm(&n, &info->err));
4684 _ckvmssts(lib$free_vm(&n, &info));
4690 /*{{{ I32 my_pclose(PerlIO *fp)*/
4691 I32 Perl_my_pclose(pTHX_ PerlIO *fp)
4693 pInfo info, last = NULL;
4696 /* Fixme - need ast and mutex protection here */
4697 for (info = open_pipes; info != NULL; last = info, info = info->next)
4698 if (info->fp == fp) break;
4700 if (info == NULL) { /* no such pipe open */
4701 set_errno(ECHILD); /* quoth POSIX */
4702 set_vaxc_errno(SS$_NONEXPR);
4706 ret_status = my_pclose_pinfo(aTHX_ info);
4710 } /* end of my_pclose() */
4712 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4713 /* Roll our own prototype because we want this regardless of whether
4714 * _VMS_WAIT is defined.
4716 __pid_t __vms_waitpid( __pid_t __pid, int *__stat_loc, int __options );
4718 /* sort-of waitpid; special handling of pipe clean-up for subprocesses
4719 created with popen(); otherwise partially emulate waitpid() unless
4720 we have a suitable one from the CRTL that came with VMS 7.2 and later.
4721 Also check processes not considered by the CRTL waitpid().
4723 /*{{{Pid_t my_waitpid(Pid_t pid, int *statusp, int flags)*/
4725 Perl_my_waitpid(pTHX_ Pid_t pid, int *statusp, int flags)
4732 if (statusp) *statusp = 0;
4734 for (info = open_pipes; info != NULL; info = info->next)
4735 if (info->pid == pid) break;
4737 if (info != NULL) { /* we know about this child */
4738 while (!info->done) {
4739 _ckvmssts(sys$setast(0));
4741 if (!done) _ckvmssts(sys$clref(pipe_ef));
4742 _ckvmssts(sys$setast(1));
4743 if (!done) _ckvmssts(sys$waitfr(pipe_ef));
4746 if (statusp) *statusp = info->completion;
4750 /* child that already terminated? */
4752 for (j = 0; j < NKEEPCLOSED && j < closed_num; j++) {
4753 if (closed_list[j].pid == pid) {
4754 if (statusp) *statusp = closed_list[j].completion;
4759 /* fall through if this child is not one of our own pipe children */
4761 #if defined(__CRTL_VER) && __CRTL_VER >= 70200000
4763 /* waitpid() became available in the CRTL as of VMS 7.0, but only
4764 * in 7.2 did we get a version that fills in the VMS completion
4765 * status as Perl has always tried to do.
4768 sts = __vms_waitpid( pid, statusp, flags );
4770 if ( sts == 0 || !(sts == -1 && errno == ECHILD) )
4773 /* If the real waitpid tells us the child does not exist, we
4774 * fall through here to implement waiting for a child that
4775 * was created by some means other than exec() (say, spawned
4776 * from DCL) or to wait for a process that is not a subprocess
4777 * of the current process.
4780 #endif /* defined(__CRTL_VER) && __CRTL_VER >= 70200000 */
4783 $DESCRIPTOR(intdsc,"0 00:00:01");
4784 unsigned long int ownercode = JPI$_OWNER, ownerpid;
4785 unsigned long int pidcode = JPI$_PID, mypid;
4786 unsigned long int interval[2];
4787 unsigned int jpi_iosb[2];
4788 struct itmlst_3 jpilist[2] = {
4789 {sizeof(ownerpid), JPI$_OWNER, &ownerpid, 0},
4794 /* Sorry folks, we don't presently implement rooting around for
4795 the first child we can find, and we definitely don't want to
4796 pass a pid of -1 to $getjpi, where it is a wildcard operation.
4802 /* Get the owner of the child so I can warn if it's not mine. If the
4803 * process doesn't exist or I don't have the privs to look at it,
4804 * I can go home early.
4806 sts = sys$getjpiw(0,&pid,NULL,&jpilist,&jpi_iosb,NULL,NULL);
4807 if (sts & 1) sts = jpi_iosb[0];
4819 set_vaxc_errno(sts);
4823 if (ckWARN(WARN_EXEC)) {
4824 /* remind folks they are asking for non-standard waitpid behavior */
4825 _ckvmssts(lib$getjpi(&pidcode,0,0,&mypid,0,0));
4826 if (ownerpid != mypid)
4827 Perl_warner(aTHX_ packWARN(WARN_EXEC),
4828 "waitpid: process %x is not a child of process %x",
4832 /* simply check on it once a second until it's not there anymore. */
4834 _ckvmssts(sys$bintim(&intdsc,interval));
4835 while ((sts=lib$getjpi(&ownercode,&pid,0,&ownerpid,0,0)) & 1) {
4836 _ckvmssts(sys$schdwk(0,0,interval,0));
4837 _ckvmssts(sys$hiber());
4839 if (sts == SS$_NONEXPR) sts = SS$_NORMAL;
4844 } /* end of waitpid() */
4849 /*{{{ char *my_gconvert(double val, int ndig, int trail, char *buf) */
4851 my_gconvert(double val, int ndig, int trail, char *buf)
4853 static char __gcvtbuf[DBL_DIG+1];
4856 loc = buf ? buf : __gcvtbuf;
4858 #ifndef __DECC /* VAXCRTL gcvt uses E format for numbers < 1 */
4860 sprintf(loc,"%.*g",ndig,val);
4866 if (!buf && ndig > DBL_DIG) ndig = DBL_DIG;
4867 return gcvt(val,ndig,loc);
4870 loc[0] = '0'; loc[1] = '\0';
4877 #if defined(__VAX) || !defined(NAML$C_MAXRSS)
4878 static int rms_free_search_context(struct FAB * fab)
4882 nam = fab->fab$l_nam;
4883 nam->nam$b_nop |= NAM$M_SYNCHK;
4884 nam->nam$l_rlf = NULL;
4886 return sys$parse(fab, NULL, NULL);
4889 #define rms_setup_nam(nam) struct NAM nam = cc$rms_nam
4890 #define rms_clear_nam_nop(nam) nam.nam$b_nop = 0;
4891 #define rms_set_nam_nop(nam, opt) nam.nam$b_nop |= (opt)
4892 #define rms_set_nam_fnb(nam, opt) nam.nam$l_fnb |= (opt)
4893 #define rms_is_nam_fnb(nam, opt) (nam.nam$l_fnb & (opt))
4894 #define rms_nam_esll(nam) nam.nam$b_esl
4895 #define rms_nam_esl(nam) nam.nam$b_esl
4896 #define rms_nam_name(nam) nam.nam$l_name
4897 #define rms_nam_namel(nam) nam.nam$l_name
4898 #define rms_nam_type(nam) nam.nam$l_type
4899 #define rms_nam_typel(nam) nam.nam$l_type
4900 #define rms_nam_ver(nam) nam.nam$l_ver
4901 #define rms_nam_verl(nam) nam.nam$l_ver
4902 #define rms_nam_rsll(nam) nam.nam$b_rsl
4903 #define rms_nam_rsl(nam) nam.nam$b_rsl
4904 #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam
4905 #define rms_set_fna(fab, nam, name, size) \
4906 { fab.fab$b_fns = size; fab.fab$l_fna = name; }
4907 #define rms_get_fna(fab, nam) fab.fab$l_fna
4908 #define rms_set_dna(fab, nam, name, size) \
4909 { fab.fab$b_dns = size; fab.fab$l_dna = name; }
4910 #define rms_nam_dns(fab, nam) fab.fab$b_dns
4911 #define rms_set_esa(nam, name, size) \
4912 { nam.nam$b_ess = size; nam.nam$l_esa = name; }
4913 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4914 { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;}
4915 #define rms_set_rsa(nam, name, size) \
4916 { nam.nam$l_rsa = name; nam.nam$b_rss = size; }
4917 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4918 { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; }
4919 #define rms_nam_name_type_l_size(nam) \
4920 (nam.nam$b_name + nam.nam$b_type)
4922 static int rms_free_search_context(struct FAB * fab)
4926 nam = fab->fab$l_naml;
4927 nam->naml$b_nop |= NAM$M_SYNCHK;
4928 nam->naml$l_rlf = NULL;
4929 nam->naml$l_long_defname_size = 0;
4932 return sys$parse(fab, NULL, NULL);
4935 #define rms_setup_nam(nam) struct NAML nam = cc$rms_naml
4936 #define rms_clear_nam_nop(nam) nam.naml$b_nop = 0;
4937 #define rms_set_nam_nop(nam, opt) nam.naml$b_nop |= (opt)
4938 #define rms_set_nam_fnb(nam, opt) nam.naml$l_fnb |= (opt)
4939 #define rms_is_nam_fnb(nam, opt) (nam.naml$l_fnb & (opt))
4940 #define rms_nam_esll(nam) nam.naml$l_long_expand_size
4941 #define rms_nam_esl(nam) nam.naml$b_esl
4942 #define rms_nam_name(nam) nam.naml$l_name
4943 #define rms_nam_namel(nam) nam.naml$l_long_name
4944 #define rms_nam_type(nam) nam.naml$l_type
4945 #define rms_nam_typel(nam) nam.naml$l_long_type
4946 #define rms_nam_ver(nam) nam.naml$l_ver
4947 #define rms_nam_verl(nam) nam.naml$l_long_ver
4948 #define rms_nam_rsll(nam) nam.naml$l_long_result_size
4949 #define rms_nam_rsl(nam) nam.naml$b_rsl
4950 #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam
4951 #define rms_set_fna(fab, nam, name, size) \
4952 { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \
4953 nam.naml$l_long_filename_size = size; \
4954 nam.naml$l_long_filename = name;}
4955 #define rms_get_fna(fab, nam) nam.naml$l_long_filename
4956 #define rms_set_dna(fab, nam, name, size) \
4957 { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \
4958 nam.naml$l_long_defname_size = size; \
4959 nam.naml$l_long_defname = name; }
4960 #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size
4961 #define rms_set_esa(nam, name, size) \
4962 { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \
4963 nam.naml$l_long_expand_alloc = size; \
4964 nam.naml$l_long_expand = name; }
4965 #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \
4966 { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \
4967 nam.naml$l_long_expand = l_name; \
4968 nam.naml$l_long_expand_alloc = l_size; }
4969 #define rms_set_rsa(nam, name, size) \
4970 { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \
4971 nam.naml$l_long_result = name; \
4972 nam.naml$l_long_result_alloc = size; }
4973 #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \
4974 { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \
4975 nam.naml$l_long_result = l_name; \
4976 nam.naml$l_long_result_alloc = l_size; }
4977 #define rms_nam_name_type_l_size(nam) \
4978 (nam.naml$l_long_name_size + nam.naml$l_long_type_size)
4983 * The CRTL for 8.3 and later can create symbolic links in any mode,
4984 * however in 8.3 the unlink/remove/delete routines will only properly handle
4985 * them if one of the PCP modes is active.
4987 static int rms_erase(const char * vmsname)
4990 struct FAB myfab = cc$rms_fab;
4991 rms_setup_nam(mynam);
4993 rms_set_fna(myfab, mynam, (char *)vmsname, strlen(vmsname)); /* cast ok */
4994 rms_bind_fab_nam(myfab, mynam);
4996 /* Are we removing all versions? */
4997 if (vms_unlink_all_versions == 1) {
4998 const char * defspec = ";*";
4999 rms_set_dna(myfab, mynam, (char *)defspec, strlen(defspec)); /* cast ok */
5002 #ifdef NAML$M_OPEN_SPECIAL
5003 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5006 status = sys$erase(&myfab, 0, 0);
5013 vms_rename_with_acl(pTHX_ const struct dsc$descriptor_s * vms_src_dsc,
5014 const struct dsc$descriptor_s * vms_dst_dsc,
5015 unsigned long flags)
5017 /* VMS and UNIX handle file permissions differently and the
5018 * the same ACL trick may be needed for renaming files,
5019 * especially if they are directories.
5022 /* todo: get kill_file and rename to share common code */
5023 /* I can not find online documentation for $change_acl
5024 * it appears to be replaced by $set_security some time ago */
5026 const unsigned int access_mode = 0;
5027 $DESCRIPTOR(obj_file_dsc,"FILE");
5030 unsigned long int jpicode = JPI$_UIC, type = ACL$C_FILE;
5031 int aclsts, fndsts, rnsts = -1;
5032 unsigned int ctx = 0;
5033 struct dsc$descriptor_s fildsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
5034 struct dsc$descriptor_s * clean_dsc;
5037 unsigned char myace$b_length;
5038 unsigned char myace$b_type;
5039 unsigned short int myace$w_flags;
5040 unsigned long int myace$l_access;
5041 unsigned long int myace$l_ident;
5042 } newace = { sizeof(struct myacedef), ACE$C_KEYID, 0,
5043 ACE$M_READ | ACE$M_WRITE | ACE$M_DELETE | ACE$M_CONTROL,
5045 oldace = { sizeof(struct myacedef), ACE$C_KEYID, 0, 0, 0};
5048 findlst[3] = {{sizeof oldace, OSS$_ACL_FIND_ENTRY, &oldace, 0},
5049 {sizeof oldace, OSS$_ACL_READ_ENTRY, &oldace, 0},
5051 addlst[2] = {{sizeof newace, OSS$_ACL_ADD_ENTRY, &newace, 0},{0,0,0,0}},
5052 dellst[2] = {{sizeof newace, OSS$_ACL_DELETE_ENTRY, &newace, 0},
5056 /* Expand the input spec using RMS, since we do not want to put
5057 * ACLs on the target of a symbolic link */
5058 vmsname = PerlMem_malloc(NAM$C_MAXRSS+1);
5059 if (vmsname == NULL)
5062 rslt = int_rmsexpand_tovms(vms_src_dsc->dsc$a_pointer,
5064 PERL_RMSEXPAND_M_SYMLINK);
5066 PerlMem_free(vmsname);
5070 /* So we get our own UIC to use as a rights identifier,
5071 * and the insert an ACE at the head of the ACL which allows us
5072 * to delete the file.
5074 _ckvmssts_noperl(lib$getjpi(&jpicode,0,0,&(oldace.myace$l_ident),0,0));
5076 fildsc.dsc$w_length = strlen(vmsname);
5077 fildsc.dsc$a_pointer = vmsname;
5079 newace.myace$l_ident = oldace.myace$l_ident;
5082 /* Grab any existing ACEs with this identifier in case we fail */
5083 clean_dsc = &fildsc;
5084 aclsts = fndsts = sys$get_security(&obj_file_dsc,
5092 if ($VMS_STATUS_SUCCESS(fndsts) || (fndsts == SS$_ACLEMPTY)) {
5093 /* Add the new ACE . . . */
5095 /* if the sys$get_security succeeded, then ctx is valid, and the
5096 * object/file descriptors will be ignored. But otherwise they
5099 aclsts = sys$set_security(&obj_file_dsc, &fildsc, NULL,
5100 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5101 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5103 set_vaxc_errno(aclsts);
5104 PerlMem_free(vmsname);
5108 rnsts = lib$rename_file(vms_src_dsc, vms_dst_dsc,
5111 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5113 if ($VMS_STATUS_SUCCESS(rnsts)) {
5114 clean_dsc = (struct dsc$descriptor_s *)vms_dst_dsc;
5117 /* Put things back the way they were. */
5119 aclsts = sys$get_security(&obj_file_dsc,
5127 if ($VMS_STATUS_SUCCESS(aclsts)) {
5131 if (!$VMS_STATUS_SUCCESS(fndsts))
5132 sec_flags = OSS$M_RELCTX;
5134 /* Get rid of the new ACE */
5135 aclsts = sys$set_security(NULL, NULL, NULL,
5136 sec_flags, dellst, &ctx, &access_mode);
5138 /* If there was an old ACE, put it back */
5139 if ($VMS_STATUS_SUCCESS(aclsts) && $VMS_STATUS_SUCCESS(fndsts)) {
5140 addlst[0].bufadr = &oldace;
5141 aclsts = sys$set_security(NULL, NULL, NULL,
5142 OSS$M_RELCTX, addlst, &ctx, &access_mode);
5143 if (!$VMS_STATUS_SUCCESS(aclsts) && (aclsts != SS$_NOCLASS)) {
5145 set_vaxc_errno(aclsts);
5151 /* Try to clear the lock on the ACL list */
5152 aclsts2 = sys$set_security(NULL, NULL, NULL,
5153 OSS$M_RELCTX, NULL, &ctx, &access_mode);
5155 /* Rename errors are most important */
5156 if (!$VMS_STATUS_SUCCESS(rnsts))
5159 set_vaxc_errno(aclsts);
5164 if (aclsts != SS$_ACLEMPTY)
5171 PerlMem_free(vmsname);
5176 /*{{{int rename(const char *, const char * */
5177 /* Not exactly what X/Open says to do, but doing it absolutely right
5178 * and efficiently would require a lot more work. This should be close
5179 * enough to pass all but the most strict X/Open compliance test.
5182 Perl_rename(pTHX_ const char *src, const char * dst)
5191 /* Validate the source file */
5192 src_sts = flex_lstat(src, &src_st);
5195 /* No source file or other problem */
5199 dst_sts = flex_lstat(dst, &dst_st);
5202 if (dst_st.st_dev != src_st.st_dev) {
5203 /* Must be on the same device */
5208 /* VMS_INO_T_COMPARE is true if the inodes are different
5209 * to match the output of memcmp
5212 if (!VMS_INO_T_COMPARE(src_st.st_ino, dst_st.st_ino)) {
5213 /* That was easy, the files are the same! */
5217 if (S_ISDIR(src_st.st_mode) && !S_ISDIR(dst_st.st_mode)) {
5218 /* If source is a directory, so must be dest */
5226 if ((dst_sts == 0) &&
5227 (vms_unlink_all_versions || S_ISDIR(dst_st.st_mode))) {
5229 /* We have issues here if vms_unlink_all_versions is set
5230 * If the destination exists, and is not a directory, then
5231 * we must delete in advance.
5233 * If the src is a directory, then we must always pre-delete
5236 * If we successfully delete the dst in advance, and the rename fails
5237 * X/Open requires that errno be EIO.
5241 if (!S_ISDIR(dst_st.st_mode) || S_ISDIR(src_st.st_mode)) {
5243 d_sts = mp_do_kill_file(aTHX_ dst, S_ISDIR(dst_st.st_mode));
5247 /* We killed the destination, so only errno now is EIO */
5252 /* Originally the idea was to call the CRTL rename() and only
5253 * try the lib$rename_file if it failed.
5254 * It turns out that there are too many variants in what the
5255 * the CRTL rename might do, so only use lib$rename_file
5260 /* Is the source and dest both in VMS format */
5261 /* if the source is a directory, then need to fileify */
5262 /* and dest must be a directory or non-existant. */
5268 unsigned long flags;
5269 struct dsc$descriptor_s old_file_dsc;
5270 struct dsc$descriptor_s new_file_dsc;
5272 /* We need to modify the src and dst depending
5273 * on if one or more of them are directories.
5276 vms_src = PerlMem_malloc(VMS_MAXRSS);
5277 if (vms_src == NULL)
5278 _ckvmssts_noperl(SS$_INSFMEM);
5280 /* Source is always a VMS format file */
5281 ret_str = do_tovmsspec(src, vms_src, 0, NULL);
5282 if (ret_str == NULL) {
5283 PerlMem_free(vms_src);
5288 vms_dst = PerlMem_malloc(VMS_MAXRSS);
5289 if (vms_dst == NULL)
5290 _ckvmssts_noperl(SS$_INSFMEM);
5292 if (S_ISDIR(src_st.st_mode)) {
5294 char * vms_dir_file;
5296 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5297 if (vms_dir_file == NULL)
5298 _ckvmssts_noperl(SS$_INSFMEM);
5300 /* The source must be a file specification */
5301 ret_str = do_fileify_dirspec(vms_src, vms_dir_file, 0, NULL);
5302 if (ret_str == NULL) {
5303 PerlMem_free(vms_src);
5304 PerlMem_free(vms_dst);
5305 PerlMem_free(vms_dir_file);
5309 PerlMem_free(vms_src);
5310 vms_src = vms_dir_file;
5312 /* If the dest is a directory, we must remove it
5315 d_sts = mp_do_kill_file(aTHX_ dst, 1);
5317 PerlMem_free(vms_src);
5318 PerlMem_free(vms_dst);
5326 /* The dest must be a VMS file specification */
5327 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5328 if (ret_str == NULL) {
5329 PerlMem_free(vms_src);
5330 PerlMem_free(vms_dst);
5335 /* The source must be a file specification */
5336 vms_dir_file = PerlMem_malloc(VMS_MAXRSS);
5337 if (vms_dir_file == NULL)
5338 _ckvmssts_noperl(SS$_INSFMEM);
5340 ret_str = do_fileify_dirspec(vms_dst, vms_dir_file, 0, NULL);
5341 if (ret_str == NULL) {
5342 PerlMem_free(vms_src);
5343 PerlMem_free(vms_dst);
5344 PerlMem_free(vms_dir_file);
5348 PerlMem_free(vms_dst);
5349 vms_dst = vms_dir_file;
5352 /* File to file or file to new dir */
5354 if ((dst_sts == 0) && S_ISDIR(dst_st.st_mode)) {
5355 /* VMS pathify a dir target */
5356 ret_str = do_tovmspath(dst, vms_dst, 0, NULL);
5357 if (ret_str == NULL) {
5358 PerlMem_free(vms_src);
5359 PerlMem_free(vms_dst);
5365 /* fileify a target VMS file specification */
5366 ret_str = int_tovmsspec(dst, vms_dst, 0, NULL);
5367 if (ret_str == NULL) {
5368 PerlMem_free(vms_src);
5369 PerlMem_free(vms_dst);
5376 old_file_dsc.dsc$a_pointer = vms_src;
5377 old_file_dsc.dsc$w_length = strlen(vms_src);
5378 old_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5379 old_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5381 new_file_dsc.dsc$a_pointer = vms_dst;
5382 new_file_dsc.dsc$w_length = strlen(vms_dst);
5383 new_file_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
5384 new_file_dsc.dsc$b_class = DSC$K_CLASS_S;
5387 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5388 flags |= 4; /* LIB$M_FIL_LONG_NAMES (bit 2) */
5391 sts = lib$rename_file(&old_file_dsc,
5395 NULL, NULL, NULL, NULL, NULL, NULL, NULL);
5396 if (!$VMS_STATUS_SUCCESS(sts)) {
5398 /* We could have failed because VMS style permissions do not
5399 * permit renames that UNIX will allow. Just like the hack
5402 sts = vms_rename_with_acl(aTHX_ &old_file_dsc, &new_file_dsc, flags);
5405 PerlMem_free(vms_src);
5406 PerlMem_free(vms_dst);
5407 if (!$VMS_STATUS_SUCCESS(sts)) {
5414 if (vms_unlink_all_versions) {
5415 /* Now get rid of any previous versions of the source file that
5420 src_sts = mp_do_kill_file(aTHX_ src, S_ISDIR(src_st.st_mode));
5424 /* We deleted the destination, so must force the error to be EIO */
5425 if ((retval != 0) && (pre_delete != 0))
5433 /*{{{char *do_rmsexpand(char *fspec, char *out, int ts, char *def, unsigned opts)*/
5434 /* Shortcut for common case of simple calls to $PARSE and $SEARCH
5435 * to expand file specification. Allows for a single default file
5436 * specification and a simple mask of options. If outbuf is non-NULL,
5437 * it must point to a buffer at least NAM$C_MAXRSS bytes long, into which
5438 * the resultant file specification is placed. If outbuf is NULL, the
5439 * resultant file specification is placed into a static buffer.
5440 * The third argument, if non-NULL, is taken to be a default file
5441 * specification string. The fourth argument is unused at present.
5442 * rmesexpand() returns the address of the resultant string if
5443 * successful, and NULL on error.
5445 * New functionality for previously unused opts value:
5446 * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format.
5447 * PERL_RMSEXPAND_M_LONG - Want output in long formst
5448 * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify
5449 * PERL_RMSEXPAND_M_SYMLINK - Use symbolic link, not target
5451 static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *);
5455 (const char *filespec,
5457 const char *defspec,
5463 const char * in_spec;
5465 const char * def_spec;
5466 char * vmsfspec, *vmsdefspec;
5470 struct FAB myfab = cc$rms_fab;
5471 rms_setup_nam(mynam);
5473 unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0;
5476 /* temp hack until UTF8 is actually implemented */
5477 if (fs_utf8 != NULL)
5480 if (!filespec || !*filespec) {
5481 set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL);
5491 if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) {
5492 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
5493 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
5495 /* If this is a UNIX file spec, convert it to VMS */
5496 sts = vms_split_path(filespec, &v_spec, &v_len, &r_spec, &r_len,
5497 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
5498 &e_len, &vs_spec, &vs_len);
5503 vmsfspec = PerlMem_malloc(VMS_MAXRSS);
5504 if (vmsfspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5505 ret_spec = int_tovmsspec(filespec, vmsfspec, 0, fs_utf8);
5506 if (ret_spec == NULL) {
5507 PerlMem_free(vmsfspec);
5510 in_spec = (const char *)vmsfspec;
5512 /* Unless we are forcing to VMS format, a UNIX input means
5513 * UNIX output, and that requires long names to be used
5515 if ((opts & PERL_RMSEXPAND_M_VMS) == 0)
5516 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5517 opts |= PERL_RMSEXPAND_M_LONG;
5525 rms_set_fna(myfab, mynam, (char *)in_spec, strlen(in_spec)); /* cast ok */
5526 rms_bind_fab_nam(myfab, mynam);
5528 /* Process the default file specification if present */
5530 if (defspec && *defspec) {
5532 t_isunix = is_unix_filespec(defspec);
5534 vmsdefspec = PerlMem_malloc(VMS_MAXRSS);
5535 if (vmsdefspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5536 ret_spec = int_tovmsspec(defspec, vmsdefspec, 0, dfs_utf8);
5538 if (ret_spec == NULL) {
5539 /* Clean up and bail */
5540 PerlMem_free(vmsdefspec);
5541 if (vmsfspec != NULL)
5542 PerlMem_free(vmsfspec);
5545 def_spec = (const char *)vmsdefspec;
5547 rms_set_dna(myfab, mynam,
5548 (char *)def_spec, strlen(def_spec)); /* cast ok */
5551 /* Now we need the expansion buffers */
5552 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
5553 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5554 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5555 esal = PerlMem_malloc(VMS_MAXRSS);
5556 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5558 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1);
5560 /* If a NAML block is used RMS always writes to the long and short
5561 * addresses unless you suppress the short name.
5563 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5564 outbufl = PerlMem_malloc(VMS_MAXRSS);
5565 if (outbufl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5567 rms_set_rsal(mynam, outbuf, NAM$C_MAXRSS, outbufl, (VMS_MAXRSS - 1));
5569 #ifdef NAM$M_NO_SHORT_UPCASE
5570 if (decc_efs_case_preserve)
5571 rms_set_nam_nop(mynam, NAM$M_NO_SHORT_UPCASE);
5574 /* We may not want to follow symbolic links */
5575 #ifdef NAML$M_OPEN_SPECIAL
5576 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5577 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5580 /* First attempt to parse as an existing file */
5581 retsts = sys$parse(&myfab,0,0);
5582 if (!(retsts & STS$K_SUCCESS)) {
5584 /* Could not find the file, try as syntax only if error is not fatal */
5585 rms_set_nam_nop(mynam, NAM$M_SYNCHK);
5586 if (retsts == RMS$_DNF ||
5587 retsts == RMS$_DIR ||
5588 retsts == RMS$_DEV ||
5589 retsts == RMS$_PRV) {
5590 retsts = sys$parse(&myfab,0,0);
5591 if (retsts & STS$K_SUCCESS) goto int_expanded;
5594 /* Still could not parse the file specification */
5595 /*----------------------------------------------*/
5596 sts = rms_free_search_context(&myfab); /* Free search context */
5597 if (vmsdefspec != NULL)
5598 PerlMem_free(vmsdefspec);
5599 if (vmsfspec != NULL)
5600 PerlMem_free(vmsfspec);
5601 if (outbufl != NULL)
5602 PerlMem_free(outbufl);
5606 set_vaxc_errno(retsts);
5607 if (retsts == RMS$_PRV) set_errno(EACCES);
5608 else if (retsts == RMS$_DEV) set_errno(ENODEV);
5609 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
5610 else set_errno(EVMSERR);
5613 retsts = sys$search(&myfab,0,0);
5614 if (!(retsts & STS$K_SUCCESS) && retsts != RMS$_FNF) {
5615 sts = rms_free_search_context(&myfab); /* Free search context */
5616 if (vmsdefspec != NULL)
5617 PerlMem_free(vmsdefspec);
5618 if (vmsfspec != NULL)
5619 PerlMem_free(vmsfspec);
5620 if (outbufl != NULL)
5621 PerlMem_free(outbufl);
5625 set_vaxc_errno(retsts);
5626 if (retsts == RMS$_PRV) set_errno(EACCES);
5627 else set_errno(EVMSERR);
5631 /* If the input filespec contained any lowercase characters,
5632 * downcase the result for compatibility with Unix-minded code. */
5634 if (!decc_efs_case_preserve) {
5636 for (tbuf = rms_get_fna(myfab, mynam); *tbuf; tbuf++)
5637 if (islower(*tbuf)) { haslower = 1; break; }
5640 /* Is a long or a short name expected */
5641 /*------------------------------------*/
5643 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5644 if (rms_nam_rsll(mynam)) {
5646 speclen = rms_nam_rsll(mynam);
5649 spec_buf = esal; /* Not esa */
5650 speclen = rms_nam_esll(mynam);
5654 if (rms_nam_rsl(mynam)) {
5656 speclen = rms_nam_rsl(mynam);
5659 spec_buf = esa; /* Not esal */
5660 speclen = rms_nam_esl(mynam);
5663 spec_buf[speclen] = '\0';
5665 /* Trim off null fields added by $PARSE
5666 * If type > 1 char, must have been specified in original or default spec
5667 * (not true for version; $SEARCH may have added version of existing file).
5669 trimver = !rms_is_nam_fnb(mynam, NAM$M_EXP_VER);
5670 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5671 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5672 ((rms_nam_verl(mynam) - rms_nam_typel(mynam)) == 1);
5675 trimtype = !rms_is_nam_fnb(mynam, NAM$M_EXP_TYPE) &&
5676 ((rms_nam_ver(mynam) - rms_nam_type(mynam)) == 1);
5678 if (trimver || trimtype) {
5679 if (defspec && *defspec) {
5680 char *defesal = NULL;
5681 char *defesa = NULL;
5682 defesa = PerlMem_malloc(VMS_MAXRSS + 1);
5683 if (defesa != NULL) {
5684 struct FAB deffab = cc$rms_fab;
5685 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5686 defesal = PerlMem_malloc(VMS_MAXRSS + 1);
5687 if (defesal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
5689 rms_setup_nam(defnam);
5691 rms_bind_fab_nam(deffab, defnam);
5695 (deffab, defnam, (char *)defspec, rms_nam_dns(myfab, mynam));
5697 /* RMS needs the esa/esal as a work area if wildcards are involved */
5698 rms_set_esal(defnam, defesa, NAM$C_MAXRSS, defesal, VMS_MAXRSS - 1);
5700 rms_clear_nam_nop(defnam);
5701 rms_set_nam_nop(defnam, NAM$M_SYNCHK);
5702 #ifdef NAM$M_NO_SHORT_UPCASE
5703 if (decc_efs_case_preserve)
5704 rms_set_nam_nop(defnam, NAM$M_NO_SHORT_UPCASE);
5706 #ifdef NAML$M_OPEN_SPECIAL
5707 if ((opts & PERL_RMSEXPAND_M_SYMLINK) != 0)
5708 rms_set_nam_nop(mynam, NAML$M_OPEN_SPECIAL);
5710 if (sys$parse(&deffab,0,0) & STS$K_SUCCESS) {
5712 trimver = !rms_is_nam_fnb(defnam, NAM$M_EXP_VER);
5715 trimtype = !rms_is_nam_fnb(defnam, NAM$M_EXP_TYPE);
5718 if (defesal != NULL)
5719 PerlMem_free(defesal);
5720 PerlMem_free(defesa);
5722 _ckvmssts_noperl(SS$_INSFMEM);
5726 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5727 if (*(rms_nam_verl(mynam)) != '\"')
5728 speclen = rms_nam_verl(mynam) - spec_buf;
5731 if (*(rms_nam_ver(mynam)) != '\"')
5732 speclen = rms_nam_ver(mynam) - spec_buf;
5736 /* If we didn't already trim version, copy down */
5737 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5738 if (speclen > rms_nam_verl(mynam) - spec_buf)
5740 (rms_nam_typel(mynam),
5741 rms_nam_verl(mynam),
5742 speclen - (rms_nam_verl(mynam) - spec_buf));
5743 speclen -= rms_nam_verl(mynam) - rms_nam_typel(mynam);
5746 if (speclen > rms_nam_ver(mynam) - spec_buf)
5748 (rms_nam_type(mynam),
5750 speclen - (rms_nam_ver(mynam) - spec_buf));
5751 speclen -= rms_nam_ver(mynam) - rms_nam_type(mynam);
5756 /* Done with these copies of the input files */
5757 /*-------------------------------------------*/
5758 if (vmsfspec != NULL)
5759 PerlMem_free(vmsfspec);
5760 if (vmsdefspec != NULL)
5761 PerlMem_free(vmsdefspec);
5763 /* If we just had a directory spec on input, $PARSE "helpfully"
5764 * adds an empty name and type for us */
5765 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5766 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5767 if (rms_nam_namel(mynam) == rms_nam_typel(mynam) &&
5768 rms_nam_verl(mynam) == rms_nam_typel(mynam) + 1 &&
5769 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5770 speclen = rms_nam_namel(mynam) - spec_buf;
5775 if (rms_nam_name(mynam) == rms_nam_type(mynam) &&
5776 rms_nam_ver(mynam) == rms_nam_ver(mynam) + 1 &&
5777 !(rms_is_nam_fnb(mynam, NAM$M_EXP_NAME)))
5778 speclen = rms_nam_name(mynam) - spec_buf;
5781 /* Posix format specifications must have matching quotes */
5782 if (speclen < (VMS_MAXRSS - 1)) {
5783 if (decc_posix_compliant_pathnames && (spec_buf[0] == '\"')) {
5784 if ((speclen > 1) && (spec_buf[speclen-1] != '\"')) {
5785 spec_buf[speclen] = '\"';
5790 spec_buf[speclen] = '\0';
5791 if (haslower && !decc_efs_case_preserve) __mystrtolower(spec_buf);
5793 /* Have we been working with an expanded, but not resultant, spec? */
5794 /* Also, convert back to Unix syntax if necessary. */
5798 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
5799 if ((opts & PERL_RMSEXPAND_M_LONG) != 0) {
5800 rsl = rms_nam_rsll(mynam);
5804 rsl = rms_nam_rsl(mynam);
5807 /* rsl is not present, it means that spec_buf is either */
5808 /* esa or esal, and needs to be copied to outbuf */
5809 /* convert to Unix if desired */
5811 ret_spec = int_tounixspec(spec_buf, outbuf, fs_utf8);
5813 /* VMS file specs are not in UTF-8 */
5814 if (fs_utf8 != NULL)
5816 strcpy(outbuf, spec_buf);
5821 /* Now spec_buf is either outbuf or outbufl */
5822 /* We need the result into outbuf */
5824 /* If we need this in UNIX, then we need another buffer */
5825 /* to keep things in order */
5827 char * new_src = NULL;
5828 if (spec_buf == outbuf) {
5829 new_src = PerlMem_malloc(VMS_MAXRSS);
5830 strcpy(new_src, spec_buf);
5834 ret_spec = int_tounixspec(src, outbuf, fs_utf8);
5836 PerlMem_free(new_src);
5839 /* VMS file specs are not in UTF-8 */
5840 if (fs_utf8 != NULL)
5843 /* Copy the buffer if needed */
5844 if (outbuf != spec_buf)
5845 strcpy(outbuf, spec_buf);
5851 /* Need to clean up the search context */
5852 rms_set_rsal(mynam, NULL, 0, NULL, 0);
5853 sts = rms_free_search_context(&myfab); /* Free search context */
5855 /* Clean up the extra buffers */
5859 if (outbufl != NULL)
5860 PerlMem_free(outbufl);
5862 /* Return the result */
5866 /* Common simple case - Expand an already VMS spec */
5868 int_rmsexpand_vms(const char * filespec, char * outbuf, unsigned opts) {
5869 opts |= PERL_RMSEXPAND_M_VMS_IN;
5870 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5873 /* Common simple case - Expand to a VMS spec */
5875 int_rmsexpand_tovms(const char * filespec, char * outbuf, unsigned opts) {
5876 opts |= PERL_RMSEXPAND_M_VMS;
5877 return int_rmsexpand(filespec, outbuf, NULL, opts, NULL, NULL);
5881 /* Entry point used by perl routines */
5884 (pTHX_ const char *filespec,
5887 const char *defspec,
5892 static char __rmsexpand_retbuf[VMS_MAXRSS];
5893 char * expanded, *ret_spec, *ret_buf;
5897 if (ret_buf == NULL) {
5899 Newx(expanded, VMS_MAXRSS, char);
5900 if (expanded == NULL)
5901 _ckvmssts(SS$_INSFMEM);
5904 ret_buf = __rmsexpand_retbuf;
5909 ret_spec = int_rmsexpand(filespec, ret_buf, defspec,
5910 opts, fs_utf8, dfs_utf8);
5912 if (ret_spec == NULL) {
5913 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
5921 /* External entry points */
5922 char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5923 { return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); }
5924 char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt)
5925 { return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); }
5926 char *Perl_rmsexpand_utf8
5927 (pTHX_ const char *spec, char *buf, const char *def,
5928 unsigned opt, int * fs_utf8, int * dfs_utf8)
5929 { return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); }
5930 char *Perl_rmsexpand_utf8_ts
5931 (pTHX_ const char *spec, char *buf, const char *def,
5932 unsigned opt, int * fs_utf8, int * dfs_utf8)
5933 { return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); }
5937 ** The following routines are provided to make life easier when
5938 ** converting among VMS-style and Unix-style directory specifications.
5939 ** All will take input specifications in either VMS or Unix syntax. On
5940 ** failure, all return NULL. If successful, the routines listed below
5941 ** return a pointer to a buffer containing the appropriately
5942 ** reformatted spec (and, therefore, subsequent calls to that routine
5943 ** will clobber the result), while the routines of the same names with
5944 ** a _ts suffix appended will return a pointer to a mallocd string
5945 ** containing the appropriately reformatted spec.
5946 ** In all cases, only explicit syntax is altered; no check is made that
5947 ** the resulting string is valid or that the directory in question
5950 ** fileify_dirspec() - convert a directory spec into the name of the
5951 ** directory file (i.e. what you can stat() to see if it's a dir).
5952 ** The style (VMS or Unix) of the result is the same as the style
5953 ** of the parameter passed in.
5954 ** pathify_dirspec() - convert a directory spec into a path (i.e.
5955 ** what you prepend to a filename to indicate what directory it's in).
5956 ** The style (VMS or Unix) of the result is the same as the style
5957 ** of the parameter passed in.
5958 ** tounixpath() - convert a directory spec into a Unix-style path.
5959 ** tovmspath() - convert a directory spec into a VMS-style path.
5960 ** tounixspec() - convert any file spec into a Unix-style file spec.
5961 ** tovmsspec() - convert any file spec into a VMS-style spec.
5962 ** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec.
5964 ** Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>
5965 ** Permission is given to distribute this code as part of the Perl
5966 ** standard distribution under the terms of the GNU General Public
5967 ** License or the Perl Artistic License. Copies of each may be
5968 ** found in the Perl standard distribution.
5971 /*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/
5972 static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl)
5974 static char __fileify_retbuf[VMS_MAXRSS];
5975 unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0;
5976 char *retspec, *cp1, *cp2, *lastdir;
5977 char *trndir, *vmsdir;
5978 unsigned short int trnlnm_iter_count;
5982 if (utf8_fl != NULL)
5985 if (!dir || !*dir) {
5986 set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL;
5988 dirlen = strlen(dir);
5989 while (dirlen && dir[dirlen-1] == '/') --dirlen;
5990 if (!dirlen) { /* We had Unixish '/' -- substitute top of current tree */
5991 if (!decc_posix_compliant_pathnames && decc_disable_posix_root) {
5998 if (dirlen > (VMS_MAXRSS - 1)) {
5999 set_errno(ENAMETOOLONG); set_vaxc_errno(RMS$_SYN);
6002 trndir = PerlMem_malloc(VMS_MAXRSS + 1);
6003 if (trndir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6004 if (!strpbrk(dir+1,"/]>:") &&
6005 (!decc_posix_compliant_pathnames && decc_disable_posix_root)) {
6006 strcpy(trndir,*dir == '/' ? dir + 1: dir);
6007 trnlnm_iter_count = 0;
6008 while (!strpbrk(trndir,"/]>:") && simple_trnlnm(trndir,trndir,VMS_MAXRSS-1)) {
6009 trnlnm_iter_count++;
6010 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
6012 dirlen = strlen(trndir);
6015 strncpy(trndir,dir,dirlen);
6016 trndir[dirlen] = '\0';
6019 /* At this point we are done with *dir and use *trndir which is a
6020 * copy that can be modified. *dir must not be modified.
6023 /* If we were handed a rooted logical name or spec, treat it like a
6024 * simple directory, so that
6025 * $ Define myroot dev:[dir.]
6026 * ... do_fileify_dirspec("myroot",buf,1) ...
6027 * does something useful.
6029 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".]")) {
6030 trndir[--dirlen] = '\0';
6031 trndir[dirlen-1] = ']';
6033 if (dirlen >= 2 && !strcmp(trndir+dirlen-2,".>")) {
6034 trndir[--dirlen] = '\0';
6035 trndir[dirlen-1] = '>';
6038 if ((cp1 = strrchr(trndir,']')) != NULL || (cp1 = strrchr(trndir,'>')) != NULL) {
6039 /* If we've got an explicit filename, we can just shuffle the string. */
6040 if (*(cp1+1)) hasfilename = 1;
6041 /* Similarly, we can just back up a level if we've got multiple levels
6042 of explicit directories in a VMS spec which ends with directories. */
6044 for (cp2 = cp1; cp2 > trndir; cp2--) {
6046 if ((cp2 - 1 > trndir) && (*(cp2 - 1) != '^')) {
6047 /* fix-me, can not scan EFS file specs backward like this */
6048 *cp2 = *cp1; *cp1 = '\0';
6053 if (*cp2 == '[' || *cp2 == '<') break;
6058 vmsdir = PerlMem_malloc(VMS_MAXRSS + 1);
6059 if (vmsdir == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6060 cp1 = strpbrk(trndir,"]:>");
6061 if (hasfilename || !cp1) { /* Unix-style path or filename */
6062 if (trndir[0] == '.') {
6063 if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) {
6064 PerlMem_free(trndir);
6065 PerlMem_free(vmsdir);
6066 return do_fileify_dirspec("[]",buf,ts,NULL);
6068 else if (trndir[1] == '.' &&
6069 (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) {
6070 PerlMem_free(trndir);
6071 PerlMem_free(vmsdir);
6072 return do_fileify_dirspec("[-]",buf,ts,NULL);
6075 if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */
6076 dirlen -= 1; /* to last element */
6077 lastdir = strrchr(trndir,'/');
6079 else if ((cp1 = strstr(trndir,"/.")) != NULL) {
6080 /* If we have "/." or "/..", VMSify it and let the VMS code
6081 * below expand it, rather than repeating the code to handle
6082 * relative components of a filespec here */
6084 if (*(cp1+2) == '.') cp1++;
6085 if (*(cp1+2) == '/' || *(cp1+2) == '\0') {
6087 if (int_tovmsspec(trndir, vmsdir, 0, utf8_fl) == NULL) {
6088 PerlMem_free(trndir);
6089 PerlMem_free(vmsdir);
6092 if (strchr(vmsdir,'/') != NULL) {
6093 /* If int_tovmsspec() returned it, it must have VMS syntax
6094 * delimiters in it, so it's a mixed VMS/Unix spec. We take
6095 * the time to check this here only so we avoid a recursion
6096 * loop; otherwise, gigo.
6098 PerlMem_free(trndir);
6099 PerlMem_free(vmsdir);
6100 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN);
6103 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
6104 PerlMem_free(trndir);
6105 PerlMem_free(vmsdir);
6108 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6109 PerlMem_free(trndir);
6110 PerlMem_free(vmsdir);
6114 } while ((cp1 = strstr(cp1,"/.")) != NULL);
6115 lastdir = strrchr(trndir,'/');
6117 else if (dirlen >= 7 && !strcmp(&trndir[dirlen-7],"/000000")) {
6119 /* Ditto for specs that end in an MFD -- let the VMS code
6120 * figure out whether it's a real device or a rooted logical. */
6122 /* This should not happen any more. Allowing the fake /000000
6123 * in a UNIX pathname causes all sorts of problems when trying
6124 * to run in UNIX emulation. So the VMS to UNIX conversions
6125 * now remove the fake /000000 directories.
6128 trndir[dirlen] = '/'; trndir[dirlen+1] = '\0';
6129 if (int_tovmsspec(trndir, vmsdir, 0, NULL) == NULL) {
6130 PerlMem_free(trndir);
6131 PerlMem_free(vmsdir);
6134 if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) {
6135 PerlMem_free(trndir);
6136 PerlMem_free(vmsdir);
6139 ret_chr = int_tounixspec(trndir, buf, utf8_fl);
6140 PerlMem_free(trndir);
6141 PerlMem_free(vmsdir);
6146 if ( !(lastdir = cp1 = strrchr(trndir,'/')) &&
6147 !(lastdir = cp1 = strrchr(trndir,']')) &&
6148 !(lastdir = cp1 = strrchr(trndir,'>'))) cp1 = trndir;
6149 if ((cp2 = strchr(cp1,'.'))) { /* look for explicit type */
6152 /* For EFS or ODS-5 look for the last dot */
6153 if (decc_efs_charset) {
6154 cp2 = strrchr(cp1,'.');
6156 if (vms_process_case_tolerant) {
6157 if (!*(cp2+1) || toupper(*(cp2+1)) != 'D' || /* Wrong type. */
6158 !*(cp2+2) || toupper(*(cp2+2)) != 'I' || /* Bzzt. */
6159 !*(cp2+3) || toupper(*(cp2+3)) != 'R' ||
6160 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6161 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6162 (ver || *cp3)))))) {
6163 PerlMem_free(trndir);
6164 PerlMem_free(vmsdir);
6166 set_vaxc_errno(RMS$_DIR);
6171 if (!*(cp2+1) || *(cp2+1) != 'D' || /* Wrong type. */
6172 !*(cp2+2) || *(cp2+2) != 'I' || /* Bzzt. */
6173 !*(cp2+3) || *(cp2+3) != 'R' ||
6174 (*(cp2+4) && ((*(cp2+4) != ';' && *(cp2+4) != '.') ||
6175 (*(cp2+5) && ((ver = strtol(cp2+5,&cp3,10)) != 1 &&
6176 (ver || *cp3)))))) {
6177 PerlMem_free(trndir);
6178 PerlMem_free(vmsdir);
6180 set_vaxc_errno(RMS$_DIR);
6184 dirlen = cp2 - trndir;
6188 retlen = dirlen + 6;
6189 if (buf) retspec = buf;
6190 else if (ts) Newx(retspec,retlen+1,char);
6191 else retspec = __fileify_retbuf;
6192 memcpy(retspec,trndir,dirlen);
6193 retspec[dirlen] = '\0';
6195 /* We've picked up everything up to the directory file name.
6196 Now just add the type and version, and we're set. */
6198 /* We should only add type for VMS syntax, but historically Perl
6199 has added it for UNIX style also */
6201 /* Fix me - we should not be using the same routine for VMS and
6202 UNIX format files. Things are too tangled so we need to lookup
6203 what syntax the output is */
6207 lastdir = strrchr(trndir,'/');
6211 lastdir = strpbrk(trndir,"]:>");
6217 if ((is_vms == 0) && (is_unix == 0)) {
6218 /* We still do not know? */
6219 is_unix = decc_filename_unix_report;
6224 if ((is_unix && !decc_efs_charset) || is_vms) {
6226 /* It is a bug to add a .dir to a UNIX format directory spec */
6227 /* However Perl on VMS may have programs that expect this so */
6228 /* If not using EFS character specifications allow it. */
6230 if ((!decc_efs_case_preserve) && vms_process_case_tolerant) {
6231 /* Traditionally Perl expects filenames in lower case */
6232 strcat(retspec, ".dir");
6234 /* VMS expects the .DIR to be in upper case */
6235 strcat(retspec, ".DIR");
6238 /* It is also a bug to put a VMS format version on a UNIX file */
6239 /* specification. Perl self tests are looking for this */
6240 if (is_vms || !(decc_efs_charset || decc_filename_unix_report))
6241 strcat(retspec, ";1");
6243 PerlMem_free(trndir);
6244 PerlMem_free(vmsdir);
6247 else { /* VMS-style directory spec */
6249 char *esa, *esal, term, *cp;
6252 unsigned long int sts, cmplen, haslower = 0;
6253 unsigned int nam_fnb;
6255 struct FAB dirfab = cc$rms_fab;
6256 rms_setup_nam(savnam);
6257 rms_setup_nam(dirnam);
6259 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
6260 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6262 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
6263 esal = PerlMem_malloc(VMS_MAXRSS);
6264 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6266 rms_set_fna(dirfab, dirnam, trndir, strlen(trndir));
6267 rms_bind_fab_nam(dirfab, dirnam);
6268 rms_set_dna(dirfab, dirnam, ".DIR;1", 6);
6269 rms_set_esal(dirnam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
6270 #ifdef NAM$M_NO_SHORT_UPCASE
6271 if (decc_efs_case_preserve)
6272 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6275 for (cp = trndir; *cp; cp++)
6276 if (islower(*cp)) { haslower = 1; break; }
6277 if (!((sts = sys$parse(&dirfab)) & STS$K_SUCCESS)) {
6278 if ((dirfab.fab$l_sts == RMS$_DIR) || (dirfab.fab$l_sts == RMS$_DNF)) {
6279 rms_set_nam_nop(dirnam, NAM$M_SYNCHK);
6280 sts = sys$parse(&dirfab) & STS$K_SUCCESS;
6286 PerlMem_free(trndir);
6287 PerlMem_free(vmsdir);
6289 set_vaxc_errno(dirfab.fab$l_sts);
6295 /* Does the file really exist? */
6296 if (sys$search(&dirfab)& STS$K_SUCCESS) {
6297 /* Yes; fake the fnb bits so we'll check type below */
6298 rms_set_nam_fnb(dirnam, (NAM$M_EXP_TYPE | NAM$M_EXP_VER));
6300 else { /* No; just work with potential name */
6301 if (dirfab.fab$l_sts == RMS$_FNF) dirnam = savnam;
6304 fab_sts = dirfab.fab$l_sts;
6305 sts = rms_free_search_context(&dirfab);
6309 PerlMem_free(trndir);
6310 PerlMem_free(vmsdir);
6311 set_errno(EVMSERR); set_vaxc_errno(fab_sts);
6317 /* Make sure we are using the right buffer */
6320 my_esa_len = rms_nam_esll(dirnam);
6323 my_esa_len = rms_nam_esl(dirnam);
6325 my_esa[my_esa_len] = '\0';
6326 if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) {
6327 cp1 = strchr(my_esa,']');
6328 if (!cp1) cp1 = strchr(my_esa,'>');
6329 if (cp1) { /* Should always be true */
6330 my_esa_len -= cp1 - my_esa - 1;
6331 memmove(my_esa, cp1 + 1, my_esa_len);
6334 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_TYPE)) { /* Was type specified? */
6335 /* Yep; check version while we're at it, if it's there. */
6336 cmplen = rms_is_nam_fnb(dirnam, NAM$M_EXP_VER) ? 6 : 4;
6337 if (strncmp(rms_nam_typel(dirnam), ".DIR;1", cmplen)) {
6338 /* Something other than .DIR[;1]. Bzzt. */
6339 sts = rms_free_search_context(&dirfab);
6343 PerlMem_free(trndir);
6344 PerlMem_free(vmsdir);
6346 set_vaxc_errno(RMS$_DIR);
6351 if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) {
6352 /* They provided at least the name; we added the type, if necessary, */
6353 if (buf) retspec = buf; /* in sys$parse() */
6354 else if (ts) Newx(retspec, my_esa_len + 1, char);
6355 else retspec = __fileify_retbuf;
6356 strcpy(retspec,my_esa);
6357 sts = rms_free_search_context(&dirfab);
6358 PerlMem_free(trndir);
6362 PerlMem_free(vmsdir);
6365 if ((cp1 = strstr(esa,".][000000]")) != NULL) {
6366 for (cp2 = cp1 + 9; *cp2; cp1++,cp2++) *cp1 = *cp2;
6370 if ((cp1 = strrchr(my_esa,']')) == NULL) cp1 = strrchr(my_esa,'>');
6371 if (cp1 == NULL) { /* should never happen */
6372 sts = rms_free_search_context(&dirfab);
6373 PerlMem_free(trndir);
6377 PerlMem_free(vmsdir);
6382 retlen = strlen(my_esa);
6383 cp1 = strrchr(my_esa,'.');
6384 /* ODS-5 directory specifications can have extra "." in them. */
6385 /* Fix-me, can not scan EFS file specifications backwards */
6386 while (cp1 != NULL) {
6387 if ((cp1-1 == my_esa) || (*(cp1-1) != '^'))
6391 while ((cp1 > my_esa) && (*cp1 != '.'))
6398 if ((cp1) != NULL) {
6399 /* There's more than one directory in the path. Just roll back. */
6401 if (buf) retspec = buf;
6402 else if (ts) Newx(retspec,retlen+7,char);
6403 else retspec = __fileify_retbuf;
6404 strcpy(retspec,my_esa);
6407 if (rms_is_nam_fnb(dirnam, NAM$M_ROOT_DIR)) {
6408 /* Go back and expand rooted logical name */
6409 rms_set_nam_nop(dirnam, NAM$M_SYNCHK | NAM$M_NOCONCEAL);
6410 #ifdef NAM$M_NO_SHORT_UPCASE
6411 if (decc_efs_case_preserve)
6412 rms_set_nam_nop(dirnam, NAM$M_NO_SHORT_UPCASE);
6414 if (!(sys$parse(&dirfab) & STS$K_SUCCESS)) {
6415 sts = rms_free_search_context(&dirfab);
6419 PerlMem_free(trndir);
6420 PerlMem_free(vmsdir);
6422 set_vaxc_errno(dirfab.fab$l_sts);
6426 /* This changes the length of the string of course */
6428 my_esa_len = rms_nam_esll(dirnam);
6430 my_esa_len = rms_nam_esl(dirnam);
6433 retlen = my_esa_len - 9; /* esa - '][' - '].DIR;1' */
6434 if (buf) retspec = buf;
6435 else if (ts) Newx(retspec,retlen+16,char);
6436 else retspec = __fileify_retbuf;
6437 cp1 = strstr(my_esa,"][");
6438 if (!cp1) cp1 = strstr(my_esa,"]<");
6439 dirlen = cp1 - my_esa;
6440 memcpy(retspec,my_esa,dirlen);
6441 if (!strncmp(cp1+2,"000000]",7)) {
6442 retspec[dirlen-1] = '\0';
6443 /* fix-me Not full ODS-5, just extra dots in directories for now */
6444 cp1 = retspec + dirlen - 1;
6445 while (cp1 > retspec)
6450 if (*(cp1-1) != '^')
6455 if (*cp1 == '.') *cp1 = ']';
6457 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6458 memmove(cp1+1,"000000]",7);
6462 memmove(retspec+dirlen,cp1+2,retlen-dirlen);
6463 retspec[retlen] = '\0';
6464 /* Convert last '.' to ']' */
6465 cp1 = retspec+retlen-1;
6466 while (*cp != '[') {
6469 /* Do not trip on extra dots in ODS-5 directories */
6470 if ((cp1 == retspec) || (*(cp1-1) != '^'))
6474 if (*cp1 == '.') *cp1 = ']';
6476 memmove(cp1+8,cp1+1,retspec+dirlen-cp1);
6477 memmove(cp1+1,"000000]",7);
6481 else { /* This is a top-level dir. Add the MFD to the path. */
6482 if (buf) retspec = buf;
6483 else if (ts) Newx(retspec,retlen+16,char);
6484 else retspec = __fileify_retbuf;
6487 while ((*cp1 != ':') && (*cp1 != '\0')) *(cp2++) = *(cp1++);
6488 strcpy(cp2,":[000000]");
6493 sts = rms_free_search_context(&dirfab);
6494 /* We've set up the string up through the filename. Add the
6495 type and version, and we're done. */
6496 strcat(retspec,".DIR;1");
6498 /* $PARSE may have upcased filespec, so convert output to lower
6499 * case if input contained any lowercase characters. */
6500 if (haslower && !decc_efs_case_preserve) __mystrtolower(retspec);
6501 PerlMem_free(trndir);
6505 PerlMem_free(vmsdir);
6508 } /* end of do_fileify_dirspec() */
6510 /* External entry points */
6511 char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf)
6512 { return do_fileify_dirspec(dir,buf,0,NULL); }
6513 char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf)
6514 { return do_fileify_dirspec(dir,buf,1,NULL); }
6515 char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl)
6516 { return do_fileify_dirspec(dir,buf,0,utf8_fl); }
6517 char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl)
6518 { return do_fileify_dirspec(dir,buf,1,utf8_fl); }
6520 static char * int_pathify_dirspec_simple(const char * dir, char * buf,
6521 char * v_spec, int v_len, char * r_spec, int r_len,
6522 char * d_spec, int d_len, char * n_spec, int n_len,
6523 char * e_spec, int e_len, char * vs_spec, int vs_len) {
6525 /* VMS specification - Try to do this the simple way */
6526 if ((v_len + r_len > 0) || (d_len > 0)) {
6529 /* No name or extension component, already a directory */
6530 if ((n_len + e_len + vs_len) == 0) {
6535 /* Special case, we may get [.foo]bar instead of [.foo]bar.dir */
6536 /* This results from catfile() being used instead of catdir() */
6537 /* So even though it should not work, we need to allow it */
6539 /* If this is .DIR;1 then do a simple conversion */
6540 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6541 if (is_dir || (e_len == 0) && (d_len > 0)) {
6543 len = v_len + r_len + d_len - 1;
6544 char dclose = d_spec[d_len - 1];
6545 strncpy(buf, dir, len);
6548 strncpy(&buf[len], n_spec, n_len);
6551 buf[len + 1] = '\0';
6556 else if (d_len > 0) {
6557 /* In the olden days, a directory needed to have a .DIR */
6558 /* extension to be a valid directory, but now it could */
6559 /* be a symbolic link */
6561 len = v_len + r_len + d_len - 1;
6562 char dclose = d_spec[d_len - 1];
6563 strncpy(buf, dir, len);
6566 strncpy(&buf[len], n_spec, n_len);
6569 if (decc_efs_charset) {
6572 strncpy(&buf[len], e_spec, e_len);
6575 set_vaxc_errno(RMS$_DIR);
6581 buf[len + 1] = '\0';
6586 set_vaxc_errno(RMS$_DIR);
6592 set_vaxc_errno(RMS$_DIR);
6598 /* Internal routine to make sure or convert a directory to be in a */
6599 /* path specification. No utf8 flag because it is not changed or used */
6600 static char *int_pathify_dirspec(const char *dir, char *buf)
6602 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
6603 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
6604 char * exp_spec, *ret_spec;
6606 unsigned short int trnlnm_iter_count;
6610 if (vms_debug_fileify) {
6612 fprintf(stderr, "int_pathify_dirspec: dir = NULL\n");
6614 fprintf(stderr, "int_pathify_dirspec: dir = %s\n", dir);
6617 /* We may need to lower case the result if we translated */
6618 /* a logical name or got the current working directory */
6621 if (!dir || !*dir) {
6623 set_vaxc_errno(SS$_BADPARAM);
6627 trndir = PerlMem_malloc(VMS_MAXRSS);
6629 _ckvmssts_noperl(SS$_INSFMEM);
6631 /* If no directory specified use the current default */
6633 strcpy(trndir, dir);
6635 getcwd(trndir, VMS_MAXRSS - 1);
6639 /* now deal with bare names that could be logical names */
6640 trnlnm_iter_count = 0;
6641 while (!strpbrk(trndir,"/]:>") && !no_translate_barewords
6642 && simple_trnlnm(trndir, trndir, VMS_MAXRSS)) {
6643 trnlnm_iter_count++;
6645 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER)
6647 trnlen = strlen(trndir);
6649 /* Trap simple rooted lnms, and return lnm:[000000] */
6650 if (!strcmp(trndir+trnlen-2,".]")) {
6652 strcat(buf, ":[000000]");
6653 PerlMem_free(trndir);
6655 if (vms_debug_fileify) {
6656 fprintf(stderr, "int_pathify_dirspec: buf = %s\n", buf);
6662 /* At this point we do not work with *dir, but the copy in *trndir */
6664 if (need_to_lower && !decc_efs_case_preserve) {
6665 /* Legacy mode, lower case the returned value */
6666 __mystrtolower(trndir);
6670 /* Some special cases, '..', '.' */
6672 if ((trndir[0] == '.') && ((trndir[1] == '.') || (trndir[1] == '\0'))) {
6673 /* Force UNIX filespec */
6677 /* Is this Unix or VMS format? */
6678 sts = vms_split_path(trndir, &v_spec, &v_len, &r_spec, &r_len,
6679 &d_spec, &d_len, &n_spec, &n_len, &e_spec,
6680 &e_len, &vs_spec, &vs_len);
6683 /* Just a filename? */
6684 if ((v_len + r_len + d_len) == 0) {
6686 /* Now we have a problem, this could be Unix or VMS */
6687 /* We have to guess. .DIR usually means VMS */
6689 /* In UNIX report mode, the .DIR extension is removed */
6690 /* if one shows up, it is for a non-directory or a directory */
6691 /* in EFS charset mode */
6693 /* So if we are in Unix report mode, assume that this */
6694 /* is a relative Unix directory specification */
6697 if (!decc_filename_unix_report && decc_efs_charset) {
6699 is_dir = is_dir_ext(e_spec, e_len, vs_spec, vs_len);
6702 /* Traditional mode, assume .DIR is directory */
6705 strncpy(&buf[2], n_spec, n_len);
6706 buf[n_len + 2] = ']';
6707 buf[n_len + 3] = '\0';
6708 PerlMem_free(trndir);
6709 if (vms_debug_fileify) {
6711 "int_pathify_dirspec: buf = %s\n",
6721 ret_spec = int_pathify_dirspec_simple(trndir, buf,
6722 v_spec, v_len, r_spec, r_len,
6723 d_spec, d_len, n_spec, n_len,
6724 e_spec, e_len, vs_spec, vs_len);
6726 if (ret_spec != NULL) {
6727 PerlMem_free(trndir);
6728 if (vms_debug_fileify) {
6730 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6735 /* Simple way did not work, which means that a logical name */
6736 /* was present for the directory specification. */
6737 /* Need to use an rmsexpand variant to decode it completely */
6738 exp_spec = PerlMem_malloc(VMS_MAXRSS);
6739 if (exp_spec == NULL)
6740 _ckvmssts_noperl(SS$_INSFMEM);
6742 ret_spec = int_rmsexpand_vms(trndir, exp_spec, PERL_RMSEXPAND_M_LONG);
6743 if (ret_spec != NULL) {
6744 sts = vms_split_path(exp_spec, &v_spec, &v_len,
6745 &r_spec, &r_len, &d_spec, &d_len,
6746 &n_spec, &n_len, &e_spec,
6747 &e_len, &vs_spec, &vs_len);
6749 ret_spec = int_pathify_dirspec_simple(
6750 exp_spec, buf, v_spec, v_len, r_spec, r_len,
6751 d_spec, d_len, n_spec, n_len,
6752 e_spec, e_len, vs_spec, vs_len);
6754 if ((ret_spec != NULL) && (!decc_efs_case_preserve)) {
6755 /* Legacy mode, lower case the returned value */
6756 __mystrtolower(ret_spec);
6759 set_vaxc_errno(RMS$_DIR);
6764 PerlMem_free(exp_spec);
6765 PerlMem_free(trndir);
6766 if (vms_debug_fileify) {
6767 if (ret_spec == NULL)
6768 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6771 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6776 /* Unix specification, Could be trivial conversion */
6778 dir_len = strlen(trndir);
6780 /* If the extended file character set is in effect */
6781 /* then pathify is simple */
6783 if (!decc_efs_charset) {
6784 /* Have to deal with traiing '.dir' or extra '.' */
6785 /* that should not be there in legacy mode, but is */
6791 lastslash = strrchr(trndir, '/');
6792 if (lastslash == NULL)
6799 /* '..' or '.' are valid directory components */
6801 if (lastslash[0] == '.') {
6802 if (lastslash[1] == '\0') {
6804 } else if (lastslash[1] == '.') {
6805 if (lastslash[2] == '\0') {
6808 /* And finally allow '...' */
6809 if ((lastslash[2] == '.') && (lastslash[3] == '\0')) {
6817 lastdot = strrchr(lastslash, '.');
6819 if (lastdot != NULL) {
6822 /* '.dir' is discarded, and any other '.' is invalid */
6823 e_len = strlen(lastdot);
6825 is_dir = is_dir_ext(lastdot, e_len, NULL, 0);
6828 dir_len = dir_len - 4;
6834 strcpy(buf, trndir);
6835 if (buf[dir_len - 1] != '/') {
6837 buf[dir_len + 1] = '\0';
6840 /* Under ODS-2 rules, '.' becomes '_', so fix it up */
6841 if (!decc_efs_charset) {
6844 if (str[0] == '.') {
6847 while ((dots[cnt] == '.') && (cnt < 3))
6850 if ((dots[cnt] == '\0') || (dots[cnt] == '/')) {
6856 for (; *str; ++str) {
6857 while (*str == '/') {
6863 /* Have to skip up to three dots which could be */
6864 /* directories, 3 dots being a VMS extension for Perl */
6867 while ((dots[cnt] == '.') && (cnt < 3)) {
6870 if (dots[cnt] == '\0')
6872 if ((cnt > 1) && (dots[cnt] != '/')) {
6878 /* too many dots? */
6879 if ((cnt == 0) || (cnt > 3)) {
6883 if (!dir_start && (*str == '.')) {
6888 PerlMem_free(trndir);
6890 if (vms_debug_fileify) {
6891 if (ret_spec == NULL)
6892 fprintf(stderr, "int_pathify_dirspec: ret_spec = NULL\n");
6895 "int_pathify_dirspec: ret_spec = %s\n", ret_spec);
6901 /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/
6902 static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl)
6904 static char __pathify_retbuf[VMS_MAXRSS];
6905 char * pathified, *ret_spec, *ret_buf;
6909 if (ret_buf == NULL) {
6911 Newx(pathified, VMS_MAXRSS, char);
6912 if (pathified == NULL)
6913 _ckvmssts(SS$_INSFMEM);
6914 ret_buf = pathified;
6916 ret_buf = __pathify_retbuf;
6920 ret_spec = int_pathify_dirspec(dir, ret_buf);
6922 if (ret_spec == NULL) {
6923 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
6925 Safefree(pathified);
6930 } /* end of do_pathify_dirspec() */
6933 /* External entry points */
6934 char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf)
6935 { return do_pathify_dirspec(dir,buf,0,NULL); }
6936 char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf)
6937 { return do_pathify_dirspec(dir,buf,1,NULL); }
6938 char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl)
6939 { return do_pathify_dirspec(dir,buf,0,utf8_fl); }
6940 char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl)
6941 { return do_pathify_dirspec(dir,buf,1,utf8_fl); }
6943 /* Internal tounixspec routine that does not use a thread context */
6944 /*{{{ char *int_tounixspec[_ts](char *spec, char *buf, int *)*/
6945 static char *int_tounixspec(const char *spec, char *rslt, int * utf8_fl)
6947 char *dirend, *cp1, *cp3, *tmp;
6949 int devlen, dirlen, retlen = VMS_MAXRSS;
6950 int expand = 1; /* guarantee room for leading and trailing slashes */
6951 unsigned short int trnlnm_iter_count;
6953 if (utf8_fl != NULL)
6956 if (vms_debug_fileify) {
6958 fprintf(stderr, "int_tounixspec: spec = NULL\n");
6960 fprintf(stderr, "int_tounixspec: spec = %s\n", spec);
6966 set_vaxc_errno(SS$_BADPARAM);
6969 if (strlen(spec) > (VMS_MAXRSS-1)) {
6971 set_vaxc_errno(SS$_BUFFEROVF);
6975 /* New VMS specific format needs translation
6976 * glob passes filenames with trailing '\n' and expects this preserved.
6978 if (decc_posix_compliant_pathnames) {
6979 if (strncmp(spec, "\"^UP^", 5) == 0) {
6985 tunix = PerlMem_malloc(VMS_MAXRSS);
6986 if (tunix == NULL) _ckvmssts_noperl(SS$_INSFMEM);
6987 strcpy(tunix, spec);
6988 tunix_len = strlen(tunix);
6990 if (tunix[tunix_len - 1] == '\n') {
6991 tunix[tunix_len - 1] = '\"';
6992 tunix[tunix_len] = '\0';
6996 uspec = decc$translate_vms(tunix);
6997 PerlMem_free(tunix);
6998 if ((int)uspec > 0) {
7004 /* If we can not translate it, makemaker wants as-is */
7012 cmp_rslt = 0; /* Presume VMS */
7013 cp1 = strchr(spec, '/');
7017 /* Look for EFS ^/ */
7018 if (decc_efs_charset) {
7019 while (cp1 != NULL) {
7022 /* Found illegal VMS, assume UNIX */
7027 cp1 = strchr(cp1, '/');
7031 /* Look for "." and ".." */
7032 if (decc_filename_unix_report) {
7033 if (spec[0] == '.') {
7034 if ((spec[1] == '\0') || (spec[1] == '\n')) {
7038 if ((spec[1] == '.') && ((spec[2] == '\0') || (spec[2] == '\n'))) {
7044 /* This is already UNIX or at least nothing VMS understands */
7047 if (vms_debug_fileify) {
7048 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7055 dirend = strrchr(spec,']');
7056 if (dirend == NULL) dirend = strrchr(spec,'>');
7057 if (dirend == NULL) dirend = strchr(spec,':');
7058 if (dirend == NULL) {
7060 if (vms_debug_fileify) {
7061 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7066 /* Special case 1 - sys$posix_root = / */
7067 #if __CRTL_VER >= 70000000
7068 if (!decc_disable_posix_root) {
7069 if (strncasecmp(spec, "SYS$POSIX_ROOT:", 15) == 0) {
7077 /* Special case 2 - Convert NLA0: to /dev/null */
7078 #if __CRTL_VER < 70000000
7079 cmp_rslt = strncmp(spec,"NLA0:", 5);
7081 cmp_rslt = strncmp(spec,"nla0:", 5);
7083 cmp_rslt = strncasecmp(spec,"NLA0:", 5);
7085 if (cmp_rslt == 0) {
7086 strcpy(rslt, "/dev/null");
7089 if (spec[6] != '\0') {
7096 /* Also handle special case "SYS$SCRATCH:" */
7097 #if __CRTL_VER < 70000000
7098 cmp_rslt = strncmp(spec,"SYS$SCRATCH:", 12);
7100 cmp_rslt = strncmp(spec,"sys$scratch:", 12);
7102 cmp_rslt = strncasecmp(spec,"SYS$SCRATCH:", 12);
7104 tmp = PerlMem_malloc(VMS_MAXRSS);
7105 if (tmp == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7106 if (cmp_rslt == 0) {
7109 islnm = simple_trnlnm("TMP", tmp, VMS_MAXRSS-1);
7111 strcpy(rslt, "/tmp");
7114 if (spec[12] != '\0') {
7122 if (*cp2 != '[' && *cp2 != '<') {
7125 else { /* the VMS spec begins with directories */
7127 if (*cp2 == ']' || *cp2 == '>') {
7128 *(cp1++) = '.'; *(cp1++) = '/'; *(cp1++) = '\0';
7132 else if ( *cp2 != '^' && *cp2 != '.' && *cp2 != '-') { /* add the implied device */
7133 if (getcwd(tmp, VMS_MAXRSS-1 ,1) == NULL) {
7135 if (vms_debug_fileify) {
7136 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7140 trnlnm_iter_count = 0;
7143 while (*cp3 != ':' && *cp3) cp3++;
7145 if (strchr(cp3,']') != NULL) break;
7146 trnlnm_iter_count++;
7147 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER+1) break;
7148 } while (vmstrnenv(tmp,tmp,0,fildev,0));
7153 *(cp1++) = *(cp3++);
7154 if (cp1 - rslt > (VMS_MAXRSS - 1)) {
7156 set_errno(ENAMETOOLONG);
7157 set_vaxc_errno(SS$_BUFFEROVF);
7158 if (vms_debug_fileify) {
7159 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7161 return NULL; /* No room */
7166 if ((*cp2 == '^')) {
7167 /* EFS file escape, pass the next character as is */
7168 /* Fix me: HEX encoding for Unicode not implemented */
7171 else if ( *cp2 == '.') {
7172 if (*(cp2+1) == '.' && *(cp2+2) == '.') {
7173 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7180 for (; cp2 <= dirend; cp2++) {
7181 if ((*cp2 == '^')) {
7182 /* EFS file escape, pass the next character as is */
7183 /* Fix me: HEX encoding for Unicode not implemented */
7184 *(cp1++) = *(++cp2);
7185 /* An escaped dot stays as is -- don't convert to slash */
7186 if (*cp2 == '.') cp2++;
7190 if (*(cp2+1) == '[') cp2++;
7192 else if (*cp2 == ']' || *cp2 == '>') {
7193 if (*(cp1-1) != '/') *(cp1++) = '/'; /* Don't double after ellipsis */
7195 else if ((*cp2 == '.') && (*cp2-1 != '^')) {
7197 if (*(cp2+1) == ']' || *(cp2+1) == '>') {
7198 while (*(cp2+1) == ']' || *(cp2+1) == '>' ||
7199 *(cp2+1) == '[' || *(cp2+1) == '<') cp2++;
7200 if (!strncmp(cp2,"[000000",7) && (*(cp2+7) == ']' ||
7201 *(cp2+7) == '>' || *(cp2+7) == '.')) cp2 += 7;
7203 else if ( *(cp2+1) == '.' && *(cp2+2) == '.') {
7204 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) ='/';
7208 else if (*cp2 == '-') {
7209 if (*(cp2-1) == '[' || *(cp2-1) == '<' || *(cp2-1) == '.') {
7210 while (*cp2 == '-') {
7212 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '/';
7214 if (*cp2 != '.' && *cp2 != ']' && *cp2 != '>') { /* we don't allow */
7215 /* filespecs like */
7216 set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); /* [fred.--foo.bar] */
7217 if (vms_debug_fileify) {
7218 fprintf(stderr, "int_tounixspec: rslt = NULL\n");
7223 else *(cp1++) = *cp2;
7225 else *(cp1++) = *cp2;
7227 /* Translate the rest of the filename. */
7232 /* Fixme - for compatibility with the CRTL we should be removing */
7233 /* spaces from the file specifications, but this may show that */
7234 /* some tests that were appearing to pass are not really passing */
7240 /* Fix me hex expansions not implemented */
7241 cp2++; /* '^.' --> '.' and other. */
7247 *(cp1++) = *(cp2++);
7252 if (decc_filename_unix_no_version) {
7253 /* Easy, drop the version */
7258 /* Punt - passing the version as a dot will probably */
7259 /* break perl in weird ways, but so did passing */
7260 /* through the ; as a version. Follow the CRTL and */
7261 /* hope for the best. */
7268 /* We will need to fix this properly later */
7269 /* As Perl may be installed on an ODS-5 volume, but not */
7270 /* have the EFS_CHARSET enabled, it still may encounter */
7271 /* filenames with extra dots in them, and a precedent got */
7272 /* set which allowed them to work, that we will uphold here */
7273 /* If extra dots are present in a name and no ^ is on them */
7274 /* VMS assumes that the first one is the extension delimiter */
7275 /* the rest have an implied ^. */
7277 /* this is also a conflict as the . is also a version */
7278 /* delimiter in VMS, */
7280 *(cp1++) = *(cp2++);
7284 /* This is an extension */
7285 if (decc_readdir_dropdotnotype) {
7287 if ((!*cp2) || (*cp2 == ';') || (*cp2 == '.')) {
7288 /* Drop the dot for the extension */
7296 *(cp1++) = *(cp2++);
7301 /* This still leaves /000000/ when working with a
7302 * VMS device root or concealed root.
7308 ulen = strlen(rslt);
7310 /* Get rid of "000000/ in rooted filespecs */
7312 zeros = strstr(rslt, "/000000/");
7313 if (zeros != NULL) {
7315 mlen = ulen - (zeros - rslt) - 7;
7316 memmove(zeros, &zeros[7], mlen);
7323 if (vms_debug_fileify) {
7324 fprintf(stderr, "int_tounixspec: rslt = %s\n", rslt);
7328 } /* end of int_tounixspec() */
7331 /*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/
7332 static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl)
7334 static char __tounixspec_retbuf[VMS_MAXRSS];
7335 char * unixspec, *ret_spec, *ret_buf;
7339 if (ret_buf == NULL) {
7341 Newx(unixspec, VMS_MAXRSS, char);
7342 if (unixspec == NULL)
7343 _ckvmssts(SS$_INSFMEM);
7346 ret_buf = __tounixspec_retbuf;
7350 ret_spec = int_tounixspec(spec, ret_buf, utf8_fl);
7352 if (ret_spec == NULL) {
7353 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
7360 } /* end of do_tounixspec() */
7362 /* External entry points */
7363 char *Perl_tounixspec(pTHX_ const char *spec, char *buf)
7364 { return do_tounixspec(spec,buf,0, NULL); }
7365 char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf)
7366 { return do_tounixspec(spec,buf,1, NULL); }
7367 char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl)
7368 { return do_tounixspec(spec,buf,0, utf8_fl); }
7369 char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl)
7370 { return do_tounixspec(spec,buf,1, utf8_fl); }
7372 #if __CRTL_VER >= 70200000 && !defined(__VAX)
7375 This procedure is used to identify if a path is based in either
7376 the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and
7377 it returns the OpenVMS format directory for it.
7379 It is expecting specifications of only '/' or '/xxxx/'
7381 If a posix root does not exist, or 'xxxx' is not a directory
7382 in the posix root, it returns a failure.
7384 FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7.
7386 It is used only internally by posix_to_vmsspec_hardway().
7389 static int posix_root_to_vms
7390 (char *vmspath, int vmspath_len,
7391 const char *unixpath,
7392 const int * utf8_fl)
7395 struct FAB myfab = cc$rms_fab;
7396 rms_setup_nam(mynam);
7397 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7398 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
7399 char * esa, * esal, * rsa, * rsal;
7406 unixlen = strlen(unixpath);
7411 #if __CRTL_VER >= 80200000
7412 /* If not a posix spec already, convert it */
7413 if (decc_posix_compliant_pathnames) {
7414 if (strncmp(unixpath,"\"^UP^",5) != 0) {
7415 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7418 /* This is already a VMS specification, no conversion */
7420 strncpy(vmspath,unixpath, vmspath_len);
7429 /* Check to see if this is under the POSIX root */
7430 if (decc_disable_posix_root) {
7434 /* Skip leading / */
7435 if (unixpath[0] == '/') {
7441 strcpy(vmspath,"SYS$POSIX_ROOT:");
7443 /* If this is only the / , or blank, then... */
7444 if (unixpath[0] == '\0') {
7445 /* by definition, this is the answer */
7449 /* Need to look up a directory */
7453 /* Copy and add '^' escape characters as needed */
7456 while (unixpath[i] != 0) {
7459 j += copy_expand_unix_filename_escape
7460 (&vmspath[j], &unixpath[i], &k, utf8_fl);
7464 path_len = strlen(vmspath);
7465 if (vmspath[path_len - 1] == '/')
7467 vmspath[path_len] = ']';
7469 vmspath[path_len] = '\0';
7472 vmspath[vmspath_len] = 0;
7473 if (unixpath[unixlen - 1] == '/')
7475 esal = PerlMem_malloc(VMS_MAXRSS);
7476 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7477 esa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7478 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7479 rsal = PerlMem_malloc(VMS_MAXRSS);
7480 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7481 rsa = PerlMem_malloc(NAM$C_MAXRSS + 1);
7482 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7483 rms_set_fna(myfab, mynam, (char *) vmspath, strlen(vmspath)); /* cast ok */
7484 rms_bind_fab_nam(myfab, mynam);
7485 rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS - 1);
7486 rms_set_rsal(mynam, rsa, NAM$C_MAXRSS, rsal, VMS_MAXRSS - 1);
7487 if (decc_efs_case_preserve)
7488 mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE;
7489 #ifdef NAML$M_OPEN_SPECIAL
7490 mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL;
7493 /* Set up the remaining naml fields */
7494 sts = sys$parse(&myfab);
7496 /* It failed! Try again as a UNIX filespec */
7505 /* get the Device ID and the FID */
7506 sts = sys$search(&myfab);
7508 /* These are no longer needed */
7513 /* on any failure, returned the POSIX ^UP^ filespec */
7518 specdsc.dsc$a_pointer = vmspath;
7519 specdsc.dsc$w_length = vmspath_len;
7521 dvidsc.dsc$a_pointer = &mynam.naml$t_dvi[1];
7522 dvidsc.dsc$w_length = mynam.naml$t_dvi[0];
7523 sts = lib$fid_to_name
7524 (&dvidsc, mynam.naml$w_fid, &specdsc, &specdsc.dsc$w_length);
7526 /* on any failure, returned the POSIX ^UP^ filespec */
7528 /* This can happen if user does not have permission to read directories */
7529 if (strncmp(unixpath,"\"^UP^",5) != 0)
7530 sprintf(vmspath,"\"^UP^%s\"",unixpath);
7532 strcpy(vmspath, unixpath);
7535 vmspath[specdsc.dsc$w_length] = 0;
7537 /* Are we expecting a directory? */
7538 if (dir_flag != 0) {
7544 i = specdsc.dsc$w_length - 1;
7548 /* Version must be '1' */
7549 if (vmspath[i--] != '1')
7551 /* Version delimiter is one of ".;" */
7552 if ((vmspath[i] != '.') && (vmspath[i] != ';'))
7555 if (vmspath[i--] != 'R')
7557 if (vmspath[i--] != 'I')
7559 if (vmspath[i--] != 'D')
7561 if (vmspath[i--] != '.')
7563 eptr = &vmspath[i+1];
7565 if ((vmspath[i] == ']') || (vmspath[i] == '>')) {
7566 if (vmspath[i-1] != '^') {
7574 /* Get rid of 6 imaginary zero directory filename */
7575 vmspath[i+1] = '\0';
7579 if (vmspath[i] == '0')
7593 /* /dev/mumble needs to be handled special.
7594 /dev/null becomes NLA0:, And there is the potential for other stuff
7595 like /dev/tty which may need to be mapped to something.
7599 slash_dev_special_to_vms
7600 (const char * unixptr,
7610 nextslash = strchr(unixptr, '/');
7611 len = strlen(unixptr);
7612 if (nextslash != NULL)
7613 len = nextslash - unixptr;
7614 cmp = strncmp("null", unixptr, 5);
7616 if (vmspath_len >= 6) {
7617 strcpy(vmspath, "_NLA0:");
7624 /* The built in routines do not understand perl's special needs, so
7625 doing a manual conversion from UNIX to VMS
7627 If the utf8_fl is not null and points to a non-zero value, then
7628 treat 8 bit characters as UTF-8.
7630 The sequence starting with '$(' and ending with ')' will be passed
7631 through with out interpretation instead of being escaped.
7634 static int posix_to_vmsspec_hardway
7635 (char *vmspath, int vmspath_len,
7636 const char *unixpath,
7641 const char *unixptr;
7642 const char *unixend;
7644 const char *lastslash;
7645 const char *lastdot;
7651 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
7652 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
7654 if (utf8_fl != NULL)
7660 /* Ignore leading "/" characters */
7661 while((unixptr[0] == '/') && (unixptr[1] == '/')) {
7664 unixlen = strlen(unixptr);
7666 /* Do nothing with blank paths */
7673 /* This could have a "^UP^ on the front */
7674 if (strncmp(unixptr,"\"^UP^",5) == 0) {
7680 lastslash = strrchr(unixptr,'/');
7681 lastdot = strrchr(unixptr,'.');
7682 unixend = strrchr(unixptr,'\"');
7683 if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) {
7684 unixend = unixptr + unixlen;
7687 /* last dot is last dot or past end of string */
7688 if (lastdot == NULL)
7689 lastdot = unixptr + unixlen;
7691 /* if no directories, set last slash to beginning of string */
7692 if (lastslash == NULL) {
7693 lastslash = unixptr;
7696 /* Watch out for trailing "." after last slash, still a directory */
7697 if ((lastslash[1] == '.') && (lastslash[2] == '\0')) {
7698 lastslash = unixptr + unixlen;
7701 /* Watch out for traiing ".." after last slash, still a directory */
7702 if ((lastslash[1] == '.')&&(lastslash[2] == '.')&&(lastslash[3] == '\0')) {
7703 lastslash = unixptr + unixlen;
7706 /* dots in directories are aways escaped */
7707 if (lastdot < lastslash)
7708 lastdot = unixptr + unixlen;
7711 /* if (unixptr < lastslash) then we are in a directory */
7718 /* Start with the UNIX path */
7719 if (*unixptr != '/') {
7720 /* relative paths */
7722 /* If allowing logical names on relative pathnames, then handle here */
7723 if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation &&
7724 !decc_posix_compliant_pathnames) {
7730 /* Find the next slash */
7731 nextslash = strchr(unixptr,'/');
7733 esa = PerlMem_malloc(vmspath_len);
7734 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7736 trn = PerlMem_malloc(VMS_MAXRSS);
7737 if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7739 if (nextslash != NULL) {
7741 seg_len = nextslash - unixptr;
7742 strncpy(esa, unixptr, seg_len);
7746 strcpy(esa, unixptr);
7747 seg_len = strlen(unixptr);
7749 /* trnlnm(section) */
7750 islnm = vmstrnenv(esa, trn, 0, fildev, 0);
7753 /* Now fix up the directory */
7755 /* Split up the path to find the components */
7756 sts = vms_split_path
7775 /* A logical name must be a directory or the full
7776 specification. It is only a full specification if
7777 it is the only component */
7778 if ((unixptr[seg_len] == '\0') ||
7779 (unixptr[seg_len+1] == '\0')) {
7781 /* Is a directory being required? */
7782 if (((n_len + e_len) != 0) && (dir_flag !=0)) {
7783 /* Not a logical name */
7788 if ((unixptr[seg_len] == '/') || (dir_flag != 0)) {
7789 /* This must be a directory */
7790 if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) {
7791 strcpy(vmsptr, esa);
7792 vmslen=strlen(vmsptr);
7793 vmsptr[vmslen] = ':';
7795 vmsptr[vmslen] = '\0';
7803 /* must be dev/directory - ignore version */
7804 if ((n_len + e_len) != 0)
7807 /* transfer the volume */
7808 if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) {
7809 strncpy(vmsptr, v_spec, v_len);
7815 /* unroot the rooted directory */
7816 if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) {
7818 r_spec[r_len - 1] = ']';
7820 /* This should not be there, but nothing is perfect */
7822 cmp = strcmp(&r_spec[1], "000000.");
7832 strncpy(vmsptr, r_spec, r_len);
7838 /* Bring over the directory. */
7840 ((d_len + vmslen) < vmspath_len)) {
7842 d_spec[d_len - 1] = ']';
7844 cmp = strcmp(&d_spec[1], "000000.");
7855 /* Remove the redundant root */
7863 strncpy(vmsptr, d_spec, d_len);
7877 if (lastslash > unixptr) {
7880 /* skip leading ./ */
7882 while ((unixptr[0] == '.') && (unixptr[1] == '/')) {
7888 /* Are we still in a directory? */
7889 if (unixptr <= lastslash) {
7894 /* if not backing up, then it is relative forward. */
7895 if (!((*unixptr == '.') && (unixptr[1] == '.') &&
7896 ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) {
7904 /* Perl wants an empty directory here to tell the difference
7905 * between a DCL commmand and a filename
7914 /* Handle two special files . and .. */
7915 if (unixptr[0] == '.') {
7916 if (&unixptr[1] == unixend) {
7923 if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) {
7934 else { /* Absolute PATH handling */
7938 /* Need to find out where root is */
7940 /* In theory, this procedure should never get an absolute POSIX pathname
7941 * that can not be found on the POSIX root.
7942 * In practice, that can not be relied on, and things will show up
7943 * here that are a VMS device name or concealed logical name instead.
7944 * So to make things work, this procedure must be tolerant.
7946 esa = PerlMem_malloc(vmspath_len);
7947 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
7950 nextslash = strchr(&unixptr[1],'/');
7952 if (nextslash != NULL) {
7954 seg_len = nextslash - &unixptr[1];
7955 strncpy(vmspath, unixptr, seg_len + 1);
7956 vmspath[seg_len+1] = 0;
7959 cmp = strncmp(vmspath, "dev", 4);
7961 sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len);
7962 if (sts = SS$_NORMAL)
7966 sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl);
7969 if ($VMS_STATUS_SUCCESS(sts)) {
7970 /* This is verified to be a real path */
7972 sts = posix_root_to_vms(esa, vmspath_len, "/", NULL);
7973 if ($VMS_STATUS_SUCCESS(sts)) {
7974 strcpy(vmspath, esa);
7975 vmslen = strlen(vmspath);
7976 vmsptr = vmspath + vmslen;
7978 if (unixptr < lastslash) {
7987 cmp = strcmp(rptr,"000000.");
7992 } /* removing 6 zeros */
7993 } /* vmslen < 7, no 6 zeros possible */
7994 } /* Not in a directory */
7995 } /* Posix root found */
7997 /* No posix root, fall back to default directory */
7998 strcpy(vmspath, "SYS$DISK:[");
7999 vmsptr = &vmspath[10];
8001 if (unixptr > lastslash) {
8010 } /* end of verified real path handling */
8015 /* Ok, we have a device or a concealed root that is not in POSIX
8016 * or we have garbage. Make the best of it.
8019 /* Posix to VMS destroyed this, so copy it again */
8020 strncpy(vmspath, &unixptr[1], seg_len);
8021 vmspath[seg_len] = 0;
8023 vmsptr = &vmsptr[vmslen];
8026 /* Now do we need to add the fake 6 zero directory to it? */
8028 if ((*lastslash == '/') && (nextslash < lastslash)) {
8029 /* No there is another directory */
8036 /* now we have foo:bar or foo:[000000]bar to decide from */
8037 islnm = vmstrnenv(vmspath, esa, 0, fildev, 0);
8039 if (!islnm && !decc_posix_compliant_pathnames) {
8041 cmp = strncmp("bin", vmspath, 4);
8043 /* bin => SYS$SYSTEM: */
8044 islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0);
8047 /* tmp => SYS$SCRATCH: */
8048 cmp = strncmp("tmp", vmspath, 4);
8050 islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0);
8055 trnend = islnm ? islnm - 1 : 0;
8057 /* if this was a logical name, ']' or '>' must be present */
8058 /* if not a logical name, then assume a device and hope. */
8059 islnm = trnend ? (esa[trnend] == ']' || esa[trnend] == '>') : 0;
8061 /* if log name and trailing '.' then rooted - treat as device */
8062 add_6zero = islnm ? (esa[trnend-1] == '.') : 0;
8064 /* Fix me, if not a logical name, a device lookup should be
8065 * done to see if the device is file structured. If the device
8066 * is not file structured, the 6 zeros should not be put on.
8068 * As it is, perl is occasionally looking for dev:[000000]tty.
8069 * which looks a little strange.
8071 * Not that easy to detect as "/dev" may be file structured with
8072 * special device files.
8075 if ((add_6zero == 0) && (*nextslash == '/') &&
8076 (&nextslash[1] == unixend)) {
8077 /* No real directory present */
8082 /* Put the device delimiter on */
8085 unixptr = nextslash;
8088 /* Start directory if needed */
8089 if (!islnm || add_6zero) {
8095 /* add fake 000000] if needed */
8108 } /* non-POSIX translation */
8110 } /* End of relative/absolute path handling */
8112 while ((unixptr <= unixend) && (vmslen < vmspath_len)){
8119 if (dir_start != 0) {
8121 /* First characters in a directory are handled special */
8122 while ((*unixptr == '/') ||
8123 ((*unixptr == '.') &&
8124 ((unixptr[1]=='.') || (unixptr[1]=='/') ||
8125 (&unixptr[1]==unixend)))) {
8130 /* Skip redundant / in specification */
8131 while ((*unixptr == '/') && (dir_start != 0)) {
8134 if (unixptr == lastslash)
8137 if (unixptr == lastslash)
8140 /* Skip redundant ./ characters */
8141 while ((*unixptr == '.') &&
8142 ((unixptr[1] == '/')||(&unixptr[1] == unixend))) {
8145 if (unixptr == lastslash)
8147 if (*unixptr == '/')
8150 if (unixptr == lastslash)
8153 /* Skip redundant ../ characters */
8154 while ((*unixptr == '.') && (unixptr[1] == '.') &&
8155 ((unixptr[2] == '/') || (&unixptr[2] == unixend))) {
8156 /* Set the backing up flag */
8162 unixptr++; /* first . */
8163 unixptr++; /* second . */
8164 if (unixptr == lastslash)
8166 if (*unixptr == '/') /* The slash */
8169 if (unixptr == lastslash)
8172 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8173 /* Not needed when VMS is pretending to be UNIX. */
8175 /* Is this loop stuck because of too many dots? */
8176 if (loop_flag == 0) {
8177 /* Exit the loop and pass the rest through */
8182 /* Are we done with directories yet? */
8183 if (unixptr >= lastslash) {
8185 /* Watch out for trailing dots */
8194 if (*unixptr == '/')
8198 /* Have we stopped backing up? */
8203 /* dir_start continues to be = 1 */
8205 if (*unixptr == '-') {
8207 *vmsptr++ = *unixptr++;
8211 /* Now are we done with directories yet? */
8212 if (unixptr >= lastslash) {
8214 /* Watch out for trailing dots */
8230 if (unixptr >= unixend)
8233 /* Normal characters - More EFS work probably needed */
8239 /* remove multiple / */
8240 while (unixptr[1] == '/') {
8243 if (unixptr == lastslash) {
8244 /* Watch out for trailing dots */
8256 /* To do: Perl expects /.../ to be translated to [...] on VMS */
8257 /* Not needed when VMS is pretending to be UNIX. */
8261 if (unixptr != unixend)
8266 if ((unixptr < lastdot) || (unixptr < lastslash) ||
8267 (&unixptr[1] == unixend)) {
8273 /* trailing dot ==> '^..' on VMS */
8274 if (unixptr == unixend) {
8282 *vmsptr++ = *unixptr++;
8286 if (quoted && (&unixptr[1] == unixend)) {
8290 in_cnt = copy_expand_unix_filename_escape
8291 (vmsptr, unixptr, &out_cnt, utf8_fl);
8301 in_cnt = copy_expand_unix_filename_escape
8302 (vmsptr, unixptr, &out_cnt, utf8_fl);
8309 /* Make sure directory is closed */
8310 if (unixptr == lastslash) {
8312 vmsptr2 = vmsptr - 1;
8314 if (*vmsptr2 != ']') {
8317 /* directories do not end in a dot bracket */
8318 if (*vmsptr2 == '.') {
8322 if (*vmsptr2 != '^') {
8323 vmsptr--; /* back up over the dot */
8331 /* Add a trailing dot if a file with no extension */
8332 vmsptr2 = vmsptr - 1;
8334 (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') &&
8335 (*vmsptr2 != ')') && (*lastdot != '.')) {
8346 /* Eventual routine to convert a UTF-8 specification to VTF-7. */
8347 static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl)
8352 /* If a UTF8 flag is being passed, honor it */
8354 if (utf8_fl != NULL) {
8355 utf8_flag = *utf8_fl;
8360 /* If there is a possibility of UTF8, then if any UTF8 characters
8361 are present, then they must be converted to VTF-7
8363 result = strcpy(rslt, path); /* FIX-ME */
8366 result = strcpy(rslt, path);
8373 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8374 static char *int_tovmsspec
8375 (const char *path, char *rslt, int dir_flag, int * utf8_flag) {
8381 unsigned long int infront = 0, hasdir = 1;
8384 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
8385 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
8387 if (vms_debug_fileify) {
8389 fprintf(stderr, "int_tovmsspec: path = NULL\n");
8391 fprintf(stderr, "int_tovmsspec: path = %s\n", path);
8395 /* If we fail, we should be setting errno */
8397 set_vaxc_errno(SS$_BADPARAM);
8400 rslt_len = VMS_MAXRSS-1;
8402 /* '.' and '..' are "[]" and "[-]" for a quick check */
8403 if (path[0] == '.') {
8404 if (path[1] == '\0') {
8406 if (utf8_flag != NULL)
8411 if (path[1] == '.' && path[2] == '\0') {
8413 if (utf8_flag != NULL)
8420 /* Posix specifications are now a native VMS format */
8421 /*--------------------------------------------------*/
8422 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8423 if (decc_posix_compliant_pathnames) {
8424 if (strncmp(path,"\"^UP^",5) == 0) {
8425 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8431 /* This is really the only way to see if this is already in VMS format */
8432 sts = vms_split_path
8447 /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath()
8448 replacement, because the above parse just took care of most of
8449 what is needed to do vmspath when the specification is already
8452 And if it is not already, it is easier to do the conversion as
8453 part of this routine than to call this routine and then work on
8457 /* If VMS punctuation was found, it is already VMS format */
8458 if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) {
8459 if (utf8_flag != NULL)
8462 if (vms_debug_fileify) {
8463 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8467 /* Now, what to do with trailing "." cases where there is no
8468 extension? If this is a UNIX specification, and EFS characters
8469 are enabled, then the trailing "." should be converted to a "^.".
8470 But if this was already a VMS specification, then it should be
8473 So in the case of ambiguity, leave the specification alone.
8477 /* If there is a possibility of UTF8, then if any UTF8 characters
8478 are present, then they must be converted to VTF-7
8480 if (utf8_flag != NULL)
8483 if (vms_debug_fileify) {
8484 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8489 dirend = strrchr(path,'/');
8491 if (dirend == NULL) {
8495 /* If we get here with no UNIX directory delimiters, then this is
8496 not a complete file specification, either garbage a UNIX glob
8497 specification that can not be converted to a VMS wildcard, or
8498 it a UNIX shell macro. MakeMaker wants shell macros passed
8501 utf8 flag setting needs to be preserved.
8506 macro_start = strchr(path,'$');
8507 if (macro_start != NULL) {
8508 if (macro_start[1] == '(') {
8512 if ((decc_efs_charset == 0) || (has_macro)) {
8514 if (vms_debug_fileify) {
8515 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8521 /* If POSIX mode active, handle the conversion */
8522 #if __CRTL_VER >= 80200000 && !defined(__VAX)
8523 if (decc_efs_charset) {
8524 posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag);
8525 if (vms_debug_fileify) {
8526 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8532 if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */
8533 if (!*(dirend+2)) dirend +=2;
8534 if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3;
8535 if (decc_efs_charset == 0) {
8536 if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4;
8542 lastdot = strrchr(cp2,'.');
8548 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8550 if (decc_disable_posix_root) {
8551 strcpy(rslt,"sys$disk:[000000]");
8554 strcpy(rslt,"sys$posix_root:[000000]");
8556 if (utf8_flag != NULL)
8558 if (vms_debug_fileify) {
8559 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8563 while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2;
8565 trndev = PerlMem_malloc(VMS_MAXRSS);
8566 if (trndev == NULL) _ckvmssts_noperl(SS$_INSFMEM);
8567 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8569 /* DECC special handling */
8571 if (strcmp(rslt,"bin") == 0) {
8572 strcpy(rslt,"sys$system");
8575 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8577 else if (strcmp(rslt,"tmp") == 0) {
8578 strcpy(rslt,"sys$scratch");
8581 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8583 else if (!decc_disable_posix_root) {
8584 strcpy(rslt, "sys$posix_root");
8588 while (*(cp2+1) == '/') cp2++; /* Skip multiple /s */
8589 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8591 else if (strcmp(rslt,"dev") == 0) {
8592 if (strncmp(cp2,"/null", 5) == 0) {
8593 if ((cp2[5] == 0) || (cp2[5] == '/')) {
8594 strcpy(rslt,"NLA0");
8598 islnm = simple_trnlnm(rslt,trndev,VMS_MAXRSS-1);
8604 trnend = islnm ? strlen(trndev) - 1 : 0;
8605 islnm = trnend ? (trndev[trnend] == ']' || trndev[trnend] == '>') : 0;
8606 rooted = islnm ? (trndev[trnend-1] == '.') : 0;
8607 /* If the first element of the path is a logical name, determine
8608 * whether it has to be translated so we can add more directories. */
8609 if (!islnm || rooted) {
8612 if (cp2 == dirend) while (infront++ < 6) *(cp1++) = '0';
8616 if (cp2 != dirend) {
8617 strcpy(rslt,trndev);
8618 cp1 = rslt + trnend;
8625 if (decc_disable_posix_root) {
8631 PerlMem_free(trndev);
8636 if (*(cp2+1) == '/' || *(cp2+1) == '\0') {
8637 cp2 += 2; /* skip over "./" - it's redundant */
8638 *(cp1++) = '.'; /* but it does indicate a relative dirspec */
8640 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8641 *(cp1++) = '-'; /* "../" --> "-" */
8644 else if (*(cp2+1) == '.' && *(cp2+2) == '.' &&
8645 (*(cp2+3) == '/' || *(cp2+3) == '\0')) {
8646 *(cp1++) = '.'; *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8647 if (!*(cp2+4)) *(cp1++) = '.'; /* Simulate trailing '/' for later */
8650 else if ((cp2 != lastdot) || (lastdot < dirend)) {
8651 /* Escape the extra dots in EFS file specifications */
8654 if (cp2 > dirend) cp2 = dirend;
8656 else *(cp1++) = '.';
8658 for (; cp2 < dirend; cp2++) {
8660 if (*(cp2-1) == '/') continue;
8661 if (*(cp1-1) != '.') *(cp1++) = '.';
8664 else if (!infront && *cp2 == '.') {
8665 if (cp2+1 == dirend || *(cp2+1) == '\0') { cp2++; break; }
8666 else if (*(cp2+1) == '/') cp2++; /* skip over "./" - it's redundant */
8667 else if (*(cp2+1) == '.' && (*(cp2+2) == '/' || *(cp2+2) == '\0')) {
8668 if (*(cp1-1) == '-' || *(cp1-1) == '[') *(cp1++) = '-'; /* handle "../" */
8669 else if (*(cp1-2) == '[') *(cp1-1) = '-';
8670 else { /* back up over previous directory name */
8672 while (*(cp1-1) != '.' && *(cp1-1) != '[') cp1--;
8673 if (*(cp1-1) == '[') {
8674 memcpy(cp1,"000000.",7);
8679 if (cp2 == dirend) break;
8681 else if ( *(cp2+1) == '.' && *(cp2+2) == '.' &&
8682 (*(cp2+3) == '/' || *(cp2+3) == '\0') ) {
8683 if (*(cp1-1) != '.') *(cp1++) = '.'; /* May already have 1 from '/' */
8684 *(cp1++) = '.'; *(cp1++) = '.'; /* ".../" --> "..." */
8686 *(cp1++) = '.'; /* Simulate trailing '/' */
8687 cp2 += 2; /* for loop will incr this to == dirend */
8689 else cp2 += 3; /* Trailing '/' was there, so skip it, too */
8692 if (decc_efs_charset == 0)
8693 *(cp1++) = '_'; /* fix up syntax - '.' in name not allowed */
8695 *(cp1++) = '^'; /* fix up syntax - '.' in name is allowed */
8701 if (!infront && *(cp1-1) == '-') *(cp1++) = '.';
8703 if (decc_efs_charset == 0)
8710 else *(cp1++) = *cp2;
8714 if (*(cp1-1) == '.') cp1--; /* Unix spec ending in '/' ==> trailing '.' */
8715 if (hasdir) *(cp1++) = ']';
8716 if (*cp2) cp2++; /* check in case we ended with trailing '..' */
8717 /* fixme for ODS5 */
8724 if (decc_efs_charset == 0)
8735 if (((cp2 < lastdot) || (cp2[1] == '\0')) &&
8736 decc_readdir_dropdotnotype) {
8741 /* trailing dot ==> '^..' on VMS */
8748 *(cp1++) = *(cp2++);
8753 /* This could be a macro to be passed through */
8754 *(cp1++) = *(cp2++);
8756 const char * save_cp2;
8760 /* paranoid check */
8766 *(cp1++) = *(cp2++);
8767 if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8768 *(cp1++) = *(cp2++);
8769 while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) {
8770 *(cp1++) = *(cp2++);
8773 *(cp1++) = *(cp2++);
8777 if (is_macro == 0) {
8778 /* Not really a macro - never mind */
8791 /* Don't escape again if following character is
8792 * already something we escape.
8794 if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) {
8795 *(cp1++) = *(cp2++);
8798 /* But otherwise fall through and escape it. */
8816 *(cp1++) = *(cp2++);
8819 /* FIXME: This needs fixing as Perl is putting ".dir;" on UNIX filespecs
8820 * which is wrong. UNIX notation should be ".dir." unless
8821 * the DECC$FILENAME_UNIX_NO_VERSION is enabled.
8822 * changing this behavior could break more things at this time.
8823 * efs character set effectively does not allow "." to be a version
8824 * delimiter as a further complication about changing this.
8826 if (decc_filename_unix_report != 0) {
8829 *(cp1++) = *(cp2++);
8832 *(cp1++) = *(cp2++);
8835 if ((no_type_seen == 1) && decc_readdir_dropdotnotype) {
8839 /* Fix me for "^]", but that requires making sure that you do
8840 * not back up past the start of the filename
8842 if ((*lcp1 != ']') && (*lcp1 != '*') && (*lcp1 != '%'))
8847 if (utf8_flag != NULL)
8849 if (vms_debug_fileify) {
8850 fprintf(stderr, "int_tovmsspec: rslt = %s\n", rslt);
8854 } /* end of int_tovmsspec() */
8857 /*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/
8858 static char *mp_do_tovmsspec
8859 (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) {
8860 static char __tovmsspec_retbuf[VMS_MAXRSS];
8861 char * vmsspec, *ret_spec, *ret_buf;
8865 if (ret_buf == NULL) {
8867 Newx(vmsspec, VMS_MAXRSS, char);
8868 if (vmsspec == NULL)
8869 _ckvmssts(SS$_INSFMEM);
8872 ret_buf = __tovmsspec_retbuf;
8876 ret_spec = int_tovmsspec(path, ret_buf, 0, utf8_flag);
8878 if (ret_spec == NULL) {
8879 /* Cleanup on isle 5, if this is thread specific we need to deallocate */
8886 } /* end of mp_do_tovmsspec() */
8888 /* External entry points */
8889 char *Perl_tovmsspec(pTHX_ const char *path, char *buf)
8890 { return do_tovmsspec(path,buf,0,NULL); }
8891 char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf)
8892 { return do_tovmsspec(path,buf,1,NULL); }
8893 char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
8894 { return do_tovmsspec(path,buf,0,utf8_fl); }
8895 char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
8896 { return do_tovmsspec(path,buf,1,utf8_fl); }
8898 /*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/
8899 static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8900 static char __tovmspath_retbuf[VMS_MAXRSS];
8902 char *pathified, *vmsified, *cp;
8904 if (path == NULL) return NULL;
8905 pathified = PerlMem_malloc(VMS_MAXRSS);
8906 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8907 if (int_pathify_dirspec(path, pathified) == NULL) {
8908 PerlMem_free(pathified);
8914 Newx(vmsified, VMS_MAXRSS, char);
8915 if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) {
8916 PerlMem_free(pathified);
8917 if (vmsified) Safefree(vmsified);
8920 PerlMem_free(pathified);
8925 vmslen = strlen(vmsified);
8926 Newx(cp,vmslen+1,char);
8927 memcpy(cp,vmsified,vmslen);
8933 strcpy(__tovmspath_retbuf,vmsified);
8935 return __tovmspath_retbuf;
8938 } /* end of do_tovmspath() */
8940 /* External entry points */
8941 char *Perl_tovmspath(pTHX_ const char *path, char *buf)
8942 { return do_tovmspath(path,buf,0, NULL); }
8943 char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf)
8944 { return do_tovmspath(path,buf,1, NULL); }
8945 char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl)
8946 { return do_tovmspath(path,buf,0,utf8_fl); }
8947 char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl)
8948 { return do_tovmspath(path,buf,1,utf8_fl); }
8951 /*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/
8952 static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) {
8953 static char __tounixpath_retbuf[VMS_MAXRSS];
8955 char *pathified, *unixified, *cp;
8957 if (path == NULL) return NULL;
8958 pathified = PerlMem_malloc(VMS_MAXRSS);
8959 if (pathified == NULL) _ckvmssts(SS$_INSFMEM);
8960 if (int_pathify_dirspec(path, pathified) == NULL) {
8961 PerlMem_free(pathified);
8967 Newx(unixified, VMS_MAXRSS, char);
8969 if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) {
8970 PerlMem_free(pathified);
8971 if (unixified) Safefree(unixified);
8974 PerlMem_free(pathified);
8979 unixlen = strlen(unixified);
8980 Newx(cp,unixlen+1,char);
8981 memcpy(cp,unixified,unixlen);
8983 Safefree(unixified);
8987 strcpy(__tounixpath_retbuf,unixified);
8988 Safefree(unixified);
8989 return __tounixpath_retbuf;
8992 } /* end of do_tounixpath() */
8994 /* External entry points */
8995 char *Perl_tounixpath(pTHX_ const char *path, char *buf)
8996 { return do_tounixpath(path,buf,0,NULL); }
8997 char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf)
8998 { return do_tounixpath(path,buf,1,NULL); }
8999 char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl)
9000 { return do_tounixpath(path,buf,0,utf8_fl); }
9001 char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl)
9002 { return do_tounixpath(path,buf,1,utf8_fl); }
9005 * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com)
9007 *****************************************************************************
9009 * Copyright (C) 1989-1994, 2007 by *
9010 * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 *
9012 * Permission is hereby granted for the reproduction of this software *
9013 * on condition that this copyright notice is included in source *
9014 * distributions of the software. The code may be modified and *
9015 * distributed under the same terms as Perl itself. *
9017 * 27-Aug-1994 Modified for inclusion in perl5 *
9018 * by Charles Bailey (bailey AT newman DOT upenn DOT edu) *
9019 *****************************************************************************
9023 * getredirection() is intended to aid in porting C programs
9024 * to VMS (Vax-11 C). The native VMS environment does not support
9025 * '>' and '<' I/O redirection, or command line wild card expansion,
9026 * or a command line pipe mechanism using the '|' AND background
9027 * command execution '&'. All of these capabilities are provided to any
9028 * C program which calls this procedure as the first thing in the
9030 * The piping mechanism will probably work with almost any 'filter' type
9031 * of program. With suitable modification, it may useful for other
9032 * portability problems as well.
9034 * Author: Mark Pizzolato (mark AT infocomm DOT com)
9038 struct list_item *next;
9042 static void add_item(struct list_item **head,
9043 struct list_item **tail,
9047 static void mp_expand_wild_cards(pTHX_ char *item,
9048 struct list_item **head,
9049 struct list_item **tail,
9052 static int background_process(pTHX_ int argc, char **argv);
9054 static void pipe_and_fork(pTHX_ char **cmargv);
9056 /*{{{ void getredirection(int *ac, char ***av)*/
9058 mp_getredirection(pTHX_ int *ac, char ***av)
9060 * Process vms redirection arg's. Exit if any error is seen.
9061 * If getredirection() processes an argument, it is erased
9062 * from the vector. getredirection() returns a new argc and argv value.
9063 * In the event that a background command is requested (by a trailing "&"),
9064 * this routine creates a background subprocess, and simply exits the program.
9066 * Warning: do not try to simplify the code for vms. The code
9067 * presupposes that getredirection() is called before any data is
9068 * read from stdin or written to stdout.
9070 * Normal usage is as follows:
9076 * getredirection(&argc, &argv);
9080 int argc = *ac; /* Argument Count */
9081 char **argv = *av; /* Argument Vector */
9082 char *ap; /* Argument pointer */
9083 int j; /* argv[] index */
9084 int item_count = 0; /* Count of Items in List */
9085 struct list_item *list_head = 0; /* First Item in List */
9086 struct list_item *list_tail; /* Last Item in List */
9087 char *in = NULL; /* Input File Name */
9088 char *out = NULL; /* Output File Name */
9089 char *outmode = "w"; /* Mode to Open Output File */
9090 char *err = NULL; /* Error File Name */
9091 char *errmode = "w"; /* Mode to Open Error File */
9092 int cmargc = 0; /* Piped Command Arg Count */
9093 char **cmargv = NULL;/* Piped Command Arg Vector */
9096 * First handle the case where the last thing on the line ends with
9097 * a '&'. This indicates the desire for the command to be run in a
9098 * subprocess, so we satisfy that desire.
9101 if (0 == strcmp("&", ap))
9102 exit(background_process(aTHX_ --argc, argv));
9103 if (*ap && '&' == ap[strlen(ap)-1])
9105 ap[strlen(ap)-1] = '\0';
9106 exit(background_process(aTHX_ argc, argv));
9109 * Now we handle the general redirection cases that involve '>', '>>',
9110 * '<', and pipes '|'.
9112 for (j = 0; j < argc; ++j)
9114 if (0 == strcmp("<", argv[j]))
9118 fprintf(stderr,"No input file after < on command line");
9119 exit(LIB$_WRONUMARG);
9124 if ('<' == *(ap = argv[j]))
9129 if (0 == strcmp(">", ap))
9133 fprintf(stderr,"No output file after > on command line");
9134 exit(LIB$_WRONUMARG);
9153 fprintf(stderr,"No output file after > or >> on command line");
9154 exit(LIB$_WRONUMARG);
9158 if (('2' == *ap) && ('>' == ap[1]))
9175 fprintf(stderr,"No output file after 2> or 2>> on command line");
9176 exit(LIB$_WRONUMARG);
9180 if (0 == strcmp("|", argv[j]))
9184 fprintf(stderr,"No command into which to pipe on command line");
9185 exit(LIB$_WRONUMARG);
9187 cmargc = argc-(j+1);
9188 cmargv = &argv[j+1];
9192 if ('|' == *(ap = argv[j]))
9200 expand_wild_cards(ap, &list_head, &list_tail, &item_count);
9203 * Allocate and fill in the new argument vector, Some Unix's terminate
9204 * the list with an extra null pointer.
9206 argv = (char **) PerlMem_malloc((item_count+1) * sizeof(char *));
9207 if (argv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9209 for (j = 0; j < item_count; ++j, list_head = list_head->next)
9210 argv[j] = list_head->value;
9216 fprintf(stderr,"'|' and '>' may not both be specified on command line");
9217 exit(LIB$_INVARGORD);
9219 pipe_and_fork(aTHX_ cmargv);
9222 /* Check for input from a pipe (mailbox) */
9224 if (in == NULL && 1 == isapipe(0))
9226 char mbxname[L_tmpnam];
9228 long int dvi_item = DVI$_DEVBUFSIZ;
9229 $DESCRIPTOR(mbxnam, "");
9230 $DESCRIPTOR(mbxdevnam, "");
9232 /* Input from a pipe, reopen it in binary mode to disable */
9233 /* carriage control processing. */
9235 fgetname(stdin, mbxname);
9236 mbxnam.dsc$a_pointer = mbxname;
9237 mbxnam.dsc$w_length = strlen(mbxnam.dsc$a_pointer);
9238 lib$getdvi(&dvi_item, 0, &mbxnam, &bufsize, 0, 0);
9239 mbxdevnam.dsc$a_pointer = mbxname;
9240 mbxdevnam.dsc$w_length = sizeof(mbxname);
9241 dvi_item = DVI$_DEVNAM;
9242 lib$getdvi(&dvi_item, 0, &mbxnam, 0, &mbxdevnam, &mbxdevnam.dsc$w_length);
9243 mbxdevnam.dsc$a_pointer[mbxdevnam.dsc$w_length] = '\0';
9246 freopen(mbxname, "rb", stdin);
9249 fprintf(stderr,"Can't reopen input pipe (name: %s) in binary mode",mbxname);
9253 if ((in != NULL) && (NULL == freopen(in, "r", stdin, "mbc=32", "mbf=2")))
9255 fprintf(stderr,"Can't open input file %s as stdin",in);
9258 if ((out != NULL) && (NULL == freopen(out, outmode, stdout, "mbc=32", "mbf=2")))
9260 fprintf(stderr,"Can't open output file %s as stdout",out);
9263 if (out != NULL) Perl_vmssetuserlnm(aTHX_ "SYS$OUTPUT",out);
9266 if (strcmp(err,"&1") == 0) {
9267 dup2(fileno(stdout), fileno(stderr));
9268 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR","SYS$OUTPUT");
9271 if (NULL == (tmperr = fopen(err, errmode, "mbc=32", "mbf=2")))
9273 fprintf(stderr,"Can't open error file %s as stderr",err);
9277 if (NULL == freopen(err, "a", stderr, "mbc=32", "mbf=2"))
9281 Perl_vmssetuserlnm(aTHX_ "SYS$ERROR",err);
9284 #ifdef ARGPROC_DEBUG
9285 PerlIO_printf(Perl_debug_log, "Arglist:\n");
9286 for (j = 0; j < *ac; ++j)
9287 PerlIO_printf(Perl_debug_log, "argv[%d] = '%s'\n", j, argv[j]);
9289 /* Clear errors we may have hit expanding wildcards, so they don't
9290 show up in Perl's $! later */
9291 set_errno(0); set_vaxc_errno(1);
9292 } /* end of getredirection() */
9295 static void add_item(struct list_item **head,
9296 struct list_item **tail,
9302 *head = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9303 if (head == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9307 (*tail)->next = (struct list_item *) PerlMem_malloc(sizeof(struct list_item));
9308 if ((*tail)->next == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9309 *tail = (*tail)->next;
9311 (*tail)->value = value;
9315 static void mp_expand_wild_cards(pTHX_ char *item,
9316 struct list_item **head,
9317 struct list_item **tail,
9321 unsigned long int context = 0;
9329 $DESCRIPTOR(filespec, "");
9330 $DESCRIPTOR(defaultspec, "SYS$DISK:[]");
9331 $DESCRIPTOR(resultspec, "");
9332 unsigned long int lff_flags = 0;
9336 #ifdef VMS_LONGNAME_SUPPORT
9337 lff_flags = LIB$M_FIL_LONG_NAMES;
9340 for (cp = item; *cp; cp++) {
9341 if (*cp == '*' || *cp == '%' || isspace(*cp)) break;
9342 if (*cp == '.' && *(cp-1) == '.' && *(cp-2) =='.') break;
9344 if (!*cp || isspace(*cp))
9346 add_item(head, tail, item, count);
9351 /* "double quoted" wild card expressions pass as is */
9352 /* From DCL that means using e.g.: */
9353 /* perl program """perl.*""" */
9354 item_len = strlen(item);
9355 if ( '"' == *item && '"' == item[item_len-1] )
9358 item[item_len-2] = '\0';
9359 add_item(head, tail, item, count);
9363 resultspec.dsc$b_dtype = DSC$K_DTYPE_T;
9364 resultspec.dsc$b_class = DSC$K_CLASS_D;
9365 resultspec.dsc$a_pointer = NULL;
9366 vmsspec = PerlMem_malloc(VMS_MAXRSS);
9367 if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9368 if ((isunix = (int) strchr(item,'/')) != (int) NULL)
9369 filespec.dsc$a_pointer = int_tovmsspec(item, vmsspec, 0, NULL);
9370 if (!isunix || !filespec.dsc$a_pointer)
9371 filespec.dsc$a_pointer = item;
9372 filespec.dsc$w_length = strlen(filespec.dsc$a_pointer);
9374 * Only return version specs, if the caller specified a version
9376 had_version = strchr(item, ';');
9378 * Only return device and directory specs, if the caller specifed either.
9380 had_device = strchr(item, ':');
9381 had_directory = (isunix || NULL != strchr(item, '[')) || (NULL != strchr(item, '<'));
9383 while ($VMS_STATUS_SUCCESS(sts = lib$find_file
9384 (&filespec, &resultspec, &context,
9385 &defaultspec, 0, &rms_sts, &lff_flags)))
9390 string = PerlMem_malloc(resultspec.dsc$w_length+1);
9391 if (string == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9392 strncpy(string, resultspec.dsc$a_pointer, resultspec.dsc$w_length);
9393 string[resultspec.dsc$w_length] = '\0';
9394 if (NULL == had_version)
9395 *(strrchr(string, ';')) = '\0';
9396 if ((!had_directory) && (had_device == NULL))
9398 if (NULL == (devdir = strrchr(string, ']')))
9399 devdir = strrchr(string, '>');
9400 strcpy(string, devdir + 1);
9403 * Be consistent with what the C RTL has already done to the rest of
9404 * the argv items and lowercase all of these names.
9406 if (!decc_efs_case_preserve) {
9407 for (c = string; *c; ++c)
9411 if (isunix) trim_unixpath(string,item,1);
9412 add_item(head, tail, string, count);
9415 PerlMem_free(vmsspec);
9416 if (sts != RMS$_NMF)
9418 set_vaxc_errno(sts);
9421 case RMS$_FNF: case RMS$_DNF:
9422 set_errno(ENOENT); break;
9424 set_errno(ENOTDIR); break;
9426 set_errno(ENODEV); break;
9427 case RMS$_FNM: case RMS$_SYN:
9428 set_errno(EINVAL); break;
9430 set_errno(EACCES); break;
9432 _ckvmssts_noperl(sts);
9436 add_item(head, tail, item, count);
9437 _ckvmssts_noperl(lib$sfree1_dd(&resultspec));
9438 _ckvmssts_noperl(lib$find_file_end(&context));
9441 static int child_st[2];/* Event Flag set when child process completes */
9443 static unsigned short child_chan;/* I/O Channel for Pipe Mailbox */
9445 static unsigned long int exit_handler(int *status)
9449 if (0 == child_st[0])
9451 #ifdef ARGPROC_DEBUG
9452 PerlIO_printf(Perl_debug_log, "Waiting for Child Process to Finish . . .\n");
9454 fflush(stdout); /* Have to flush pipe for binary data to */
9455 /* terminate properly -- <tp@mccall.com> */
9456 sys$qiow(0, child_chan, IO$_WRITEOF, iosb, 0, 0, 0, 0, 0, 0, 0, 0);
9457 sys$dassgn(child_chan);
9459 sys$synch(0, child_st);
9464 static void sig_child(int chan)
9466 #ifdef ARGPROC_DEBUG
9467 PerlIO_printf(Perl_debug_log, "Child Completion AST\n");
9469 if (child_st[0] == 0)
9473 static struct exit_control_block exit_block =
9478 &exit_block.exit_status,
9483 pipe_and_fork(pTHX_ char **cmargv)
9486 struct dsc$descriptor_s *vmscmd;
9487 char subcmd[2*MAX_DCL_LINE_LENGTH], *p, *q;
9488 int sts, j, l, ismcr, quote, tquote = 0;
9490 sts = setup_cmddsc(aTHX_ cmargv[0],0,"e,&vmscmd);
9491 vms_execfree(vmscmd);
9496 ismcr = q && toupper(*q) == 'M' && toupper(*(q+1)) == 'C'
9497 && toupper(*(q+2)) == 'R' && !*(q+3);
9499 while (q && l < MAX_DCL_LINE_LENGTH) {
9501 if (j > 0 && quote) {
9507 if (ismcr && j > 1) quote = 1;
9508 tquote = (strchr(q,' ')) != NULL || *q == '\0';
9511 if (quote || tquote) {
9517 if ((quote||tquote) && *q == '"') {
9527 fp = safe_popen(aTHX_ subcmd,"wbF",&sts);
9529 PerlIO_printf(Perl_debug_log,"Can't open output pipe (status %d)",sts);
9533 static int background_process(pTHX_ int argc, char **argv)
9535 char command[MAX_DCL_SYMBOL + 1] = "$";
9536 $DESCRIPTOR(value, "");
9537 static $DESCRIPTOR(cmd, "BACKGROUND$COMMAND");
9538 static $DESCRIPTOR(null, "NLA0:");
9539 static $DESCRIPTOR(pidsymbol, "SHELL_BACKGROUND_PID");
9541 $DESCRIPTOR(pidstr, "");
9543 unsigned long int flags = 17, one = 1, retsts;
9546 strcat(command, argv[0]);
9547 len = strlen(command);
9548 while (--argc && (len < MAX_DCL_SYMBOL))
9550 strcat(command, " \"");
9551 strcat(command, *(++argv));
9552 strcat(command, "\"");
9553 len = strlen(command);
9555 value.dsc$a_pointer = command;
9556 value.dsc$w_length = strlen(value.dsc$a_pointer);
9557 _ckvmssts_noperl(lib$set_symbol(&cmd, &value));
9558 retsts = lib$spawn(&cmd, &null, 0, &flags, 0, &pid);
9559 if (retsts == 0x38250) { /* DCL-W-NOTIFY - We must be BATCH, so retry */
9560 _ckvmssts_noperl(lib$spawn(&cmd, &null, 0, &one, 0, &pid));
9563 _ckvmssts_noperl(retsts);
9565 #ifdef ARGPROC_DEBUG
9566 PerlIO_printf(Perl_debug_log, "%s\n", command);
9568 sprintf(pidstring, "%08X", pid);
9569 PerlIO_printf(Perl_debug_log, "%s\n", pidstring);
9570 pidstr.dsc$a_pointer = pidstring;
9571 pidstr.dsc$w_length = strlen(pidstr.dsc$a_pointer);
9572 lib$set_symbol(&pidsymbol, &pidstr);
9576 /***** End of code taken from Mark Pizzolato's argproc.c package *****/
9579 /* OS-specific initialization at image activation (not thread startup) */
9580 /* Older VAXC header files lack these constants */
9581 #ifndef JPI$_RIGHTS_SIZE
9582 # define JPI$_RIGHTS_SIZE 817
9584 #ifndef KGB$M_SUBSYSTEM
9585 # define KGB$M_SUBSYSTEM 0x8
9588 /* Avoid Newx() in vms_image_init as thread context has not been initialized. */
9590 /*{{{void vms_image_init(int *, char ***)*/
9592 vms_image_init(int *argcp, char ***argvp)
9595 char eqv[LNM$C_NAMLENGTH+1] = "";
9596 unsigned int len, tabct = 8, tabidx = 0;
9597 unsigned long int *mask, iosb[2], i, rlst[128], rsz;
9598 unsigned long int iprv[(sizeof(union prvdef) + sizeof(unsigned long int) - 1) / sizeof(unsigned long int)];
9599 unsigned short int dummy, rlen;
9600 struct dsc$descriptor_s **tabvec;
9601 #if defined(PERL_IMPLICIT_CONTEXT)
9604 struct itmlst_3 jpilist[4] = { {sizeof iprv, JPI$_IMAGPRIV, iprv, &dummy},
9605 {sizeof rlst, JPI$_RIGHTSLIST, rlst, &rlen},
9606 { sizeof rsz, JPI$_RIGHTS_SIZE, &rsz, &dummy},
9609 #ifdef KILL_BY_SIGPRC
9610 Perl_csighandler_init();
9613 /* This was moved from the pre-image init handler because on threaded */
9614 /* Perl it was always returning 0 for the default value. */
9615 status = simple_trnlnm("SYS$POSIX_ROOT", eqv, LNM$C_NAMLENGTH);
9618 s = decc$feature_get_index("DECC$DISABLE_POSIX_ROOT");
9621 initial = decc$feature_get_value(s, 4);
9623 /* initial is: 0 if nothing has set the feature */
9624 /* -1 if initialized to default */
9625 /* 1 if set by logical name */
9626 /* 2 if set by decc$feature_set_value */
9627 decc_disable_posix_root = decc$feature_get_value(s, 1);
9629 /* If the value is not valid, force the feature off */
9630 if (decc_disable_posix_root < 0) {
9631 decc$feature_set_value(s, 1, 1);
9632 decc_disable_posix_root = 1;
9636 /* Nothing has asked for it explicitly, so use our own default. */
9637 decc_disable_posix_root = 1;
9638 decc$feature_set_value(s, 1, 1);
9644 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,jpilist,iosb,NULL,NULL));
9645 _ckvmssts_noperl(iosb[0]);
9646 for (i = 0; i < sizeof iprv / sizeof(unsigned long int); i++) {
9647 if (iprv[i]) { /* Running image installed with privs? */
9648 _ckvmssts_noperl(sys$setprv(0,iprv,0,NULL)); /* Turn 'em off. */
9653 /* Rights identifiers might trigger tainting as well. */
9654 if (!will_taint && (rlen || rsz)) {
9655 while (rlen < rsz) {
9656 /* We didn't get all the identifiers on the first pass. Allocate a
9657 * buffer much larger than $GETJPI wants (rsz is size in bytes that
9658 * were needed to hold all identifiers at time of last call; we'll
9659 * allocate that many unsigned long ints), and go back and get 'em.
9660 * If it gave us less than it wanted to despite ample buffer space,
9661 * something's broken. Is your system missing a system identifier?
9663 if (rsz <= jpilist[1].buflen) {
9664 /* Perl_croak accvios when used this early in startup. */
9665 fprintf(stderr, "vms_image_init: $getjpiw refuses to store RIGHTSLIST of %u bytes in buffer of %u bytes.\n%s",
9666 rsz, (unsigned long) jpilist[1].buflen,
9667 "Check your rights database for corruption.\n");
9670 if (jpilist[1].bufadr != rlst) PerlMem_free(jpilist[1].bufadr);
9671 jpilist[1].bufadr = mask = (unsigned long int *) PerlMem_malloc(rsz * sizeof(unsigned long int));
9672 if (mask == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9673 jpilist[1].buflen = rsz * sizeof(unsigned long int);
9674 _ckvmssts_noperl(sys$getjpiw(0,NULL,NULL,&jpilist[1],iosb,NULL,NULL));
9675 _ckvmssts_noperl(iosb[0]);
9677 mask = jpilist[1].bufadr;
9678 /* Check attribute flags for each identifier (2nd longword); protected
9679 * subsystem identifiers trigger tainting.
9681 for (i = 1; i < (rlen + sizeof(unsigned long int) - 1) / sizeof(unsigned long int); i += 2) {
9682 if (mask[i] & KGB$M_SUBSYSTEM) {
9687 if (mask != rlst) PerlMem_free(mask);
9690 /* When Perl is in decc_filename_unix_report mode and is run from a concealed
9691 * logical, some versions of the CRTL will add a phanthom /000000/
9692 * directory. This needs to be removed.
9694 if (decc_filename_unix_report) {
9697 ulen = strlen(argvp[0][0]);
9699 zeros = strstr(argvp[0][0], "/000000/");
9700 if (zeros != NULL) {
9702 mlen = ulen - (zeros - argvp[0][0]) - 7;
9703 memmove(zeros, &zeros[7], mlen);
9705 argvp[0][0][ulen] = '\0';
9708 /* It also may have a trailing dot that needs to be removed otherwise
9709 * it will be converted to VMS mode incorrectly.
9712 if ((argvp[0][0][ulen] == '.') && (decc_readdir_dropdotnotype))
9713 argvp[0][0][ulen] = '\0';
9716 /* We need to use this hack to tell Perl it should run with tainting,
9717 * since its tainting flag may be part of the PL_curinterp struct, which
9718 * hasn't been allocated when vms_image_init() is called.
9721 char **newargv, **oldargv;
9723 newargv = (char **) PerlMem_malloc(((*argcp)+2) * sizeof(char *));
9724 if (newargv == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9725 newargv[0] = oldargv[0];
9726 newargv[1] = PerlMem_malloc(3 * sizeof(char));
9727 if (newargv[1] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9728 strcpy(newargv[1], "-T");
9729 Copy(&oldargv[1],&newargv[2],(*argcp)-1,char **);
9731 newargv[*argcp] = NULL;
9732 /* We orphan the old argv, since we don't know where it's come from,
9733 * so we don't know how to free it.
9737 else { /* Did user explicitly request tainting? */
9739 char *cp, **av = *argvp;
9740 for (i = 1; i < *argcp; i++) {
9741 if (*av[i] != '-') break;
9742 for (cp = av[i]+1; *cp; cp++) {
9743 if (*cp == 'T') { will_taint = 1; break; }
9744 else if ( (*cp == 'd' || *cp == 'V') && *(cp+1) == ':' ||
9745 strchr("DFIiMmx",*cp)) break;
9747 if (will_taint) break;
9752 len = my_trnlnm("PERL_ENV_TABLES",eqv,tabidx);
9755 tabvec = (struct dsc$descriptor_s **)
9756 PerlMem_malloc(tabct * sizeof(struct dsc$descriptor_s *));
9757 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9759 else if (tabidx >= tabct) {
9761 tabvec = (struct dsc$descriptor_s **) PerlMem_realloc(tabvec, tabct * sizeof(struct dsc$descriptor_s *));
9762 if (tabvec == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9764 tabvec[tabidx] = (struct dsc$descriptor_s *) PerlMem_malloc(sizeof(struct dsc$descriptor_s));
9765 if (tabvec[tabidx] == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9766 tabvec[tabidx]->dsc$w_length = 0;
9767 tabvec[tabidx]->dsc$b_dtype = DSC$K_DTYPE_T;
9768 tabvec[tabidx]->dsc$b_class = DSC$K_CLASS_D;
9769 tabvec[tabidx]->dsc$a_pointer = NULL;
9770 _ckvmssts_noperl(lib$scopy_r_dx(&len,eqv,tabvec[tabidx]));
9772 if (tabidx) { tabvec[tabidx] = NULL; env_tables = tabvec; }
9774 getredirection(argcp,argvp);
9775 #if defined(USE_ITHREADS) && ( defined(__DECC) || defined(__DECCXX) )
9777 # include <reentrancy.h>
9778 decc$set_reentrancy(C$C_MULTITHREAD);
9787 * Trim Unix-style prefix off filespec, so it looks like what a shell
9788 * glob expansion would return (i.e. from specified prefix on, not
9789 * full path). Note that returned filespec is Unix-style, regardless
9790 * of whether input filespec was VMS-style or Unix-style.
9792 * fspec is filespec to be trimmed, and wildspec is wildcard spec used to
9793 * determine prefix (both may be in VMS or Unix syntax). opts is a bit
9794 * vector of options; at present, only bit 0 is used, and if set tells
9795 * trim unixpath to try the current default directory as a prefix when
9796 * presented with a possibly ambiguous ... wildcard.
9798 * Returns !=0 on success, with trimmed filespec replacing contents of
9799 * fspec, and 0 on failure, with contents of fpsec unchanged.
9801 /*{{{int trim_unixpath(char *fspec, char *wildspec, int opts)*/
9803 Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts)
9805 char *unixified, *unixwild,
9806 *template, *base, *end, *cp1, *cp2;
9807 register int tmplen, reslen = 0, dirs = 0;
9809 if (!wildspec || !fspec) return 0;
9811 unixwild = PerlMem_malloc(VMS_MAXRSS);
9812 if (unixwild == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9813 template = unixwild;
9814 if (strpbrk(wildspec,"]>:") != NULL) {
9815 if (int_tounixspec(wildspec, unixwild, NULL) == NULL) {
9816 PerlMem_free(unixwild);
9821 strncpy(unixwild, wildspec, VMS_MAXRSS-1);
9822 unixwild[VMS_MAXRSS-1] = 0;
9824 unixified = PerlMem_malloc(VMS_MAXRSS);
9825 if (unixified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9826 if (strpbrk(fspec,"]>:") != NULL) {
9827 if (int_tounixspec(fspec, unixified, NULL) == NULL) {
9828 PerlMem_free(unixwild);
9829 PerlMem_free(unixified);
9832 else base = unixified;
9833 /* reslen != 0 ==> we had to unixify resultant filespec, so we must
9834 * check to see that final result fits into (isn't longer than) fspec */
9835 reslen = strlen(fspec);
9839 /* No prefix or absolute path on wildcard, so nothing to remove */
9840 if (!*template || *template == '/') {
9841 PerlMem_free(unixwild);
9842 if (base == fspec) {
9843 PerlMem_free(unixified);
9846 tmplen = strlen(unixified);
9847 if (tmplen > reslen) {
9848 PerlMem_free(unixified);
9849 return 0; /* not enough space */
9851 /* Copy unixified resultant, including trailing NUL */
9852 memmove(fspec,unixified,tmplen+1);
9853 PerlMem_free(unixified);
9857 for (end = base; *end; end++) ; /* Find end of resultant filespec */
9858 if ((cp1 = strstr(template,".../")) == NULL) { /* No ...; just count elts */
9859 for (cp1 = template; *cp1; cp1++) if (*cp1 == '/') dirs++;
9860 for (cp1 = end ;cp1 >= base; cp1--)
9861 if ((*cp1 == '/') && !dirs--) /* postdec so we get front of rel path */
9863 if (cp1 != fspec) memmove(fspec,cp1, end - cp1 + 1);
9864 PerlMem_free(unixified);
9865 PerlMem_free(unixwild);
9870 char *front, *nextell, *lcend, *lcfront, *ellipsis = cp1;
9871 int ells = 1, totells, segdirs, match;
9872 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, NULL},
9873 resdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
9875 while ((cp1 = strstr(ellipsis+4,".../")) != NULL) {ellipsis = cp1; ells++;}
9877 for (cp1 = ellipsis+4; *cp1; cp1++) if (*cp1 == '/') dirs++;
9878 tpl = PerlMem_malloc(VMS_MAXRSS);
9879 if (tpl == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9880 if (ellipsis == template && opts & 1) {
9881 /* Template begins with an ellipsis. Since we can't tell how many
9882 * directory names at the front of the resultant to keep for an
9883 * arbitrary starting point, we arbitrarily choose the current
9884 * default directory as a starting point. If it's there as a prefix,
9885 * clip it off. If not, fall through and act as if the leading
9886 * ellipsis weren't there (i.e. return shortest possible path that
9887 * could match template).
9889 if (getcwd(tpl, (VMS_MAXRSS - 1),0) == NULL) {
9891 PerlMem_free(unixified);
9892 PerlMem_free(unixwild);
9895 if (!decc_efs_case_preserve) {
9896 for (cp1 = tpl, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
9897 if (_tolower(*cp1) != _tolower(*cp2)) break;
9899 segdirs = dirs - totells; /* Min # of dirs we must have left */
9900 for (front = cp2+1; *front; front++) if (*front == '/') segdirs--;
9901 if (*cp1 == '\0' && *cp2 == '/' && segdirs < 1) {
9902 memmove(fspec,cp2+1,end - cp2);
9904 PerlMem_free(unixified);
9905 PerlMem_free(unixwild);
9909 /* First off, back up over constant elements at end of path */
9911 for (front = end ; front >= base; front--)
9912 if (*front == '/' && !dirs--) { front++; break; }
9914 lcres = PerlMem_malloc(VMS_MAXRSS);
9915 if (lcres == NULL) _ckvmssts_noperl(SS$_INSFMEM);
9916 for (cp1=template,cp2=lcres; *cp1 && cp2 <= lcres + (VMS_MAXRSS - 1);
9918 if (!decc_efs_case_preserve) {
9919 *cp2 = _tolower(*cp1); /* Make lc copy for match */
9927 PerlMem_free(unixified);
9928 PerlMem_free(unixwild);
9929 PerlMem_free(lcres);
9930 return 0; /* Path too long. */
9933 *cp2 = '\0'; /* Pick up with memcpy later */
9934 lcfront = lcres + (front - base);
9935 /* Now skip over each ellipsis and try to match the path in front of it. */
9937 for (cp1 = ellipsis - 2; cp1 >= template; cp1--)
9938 if (*(cp1) == '.' && *(cp1+1) == '.' &&
9939 *(cp1+2) == '.' && *(cp1+3) == '/' ) break;
9940 if (cp1 < template) break; /* template started with an ellipsis */
9941 if (cp1 + 4 == ellipsis) { /* Consecutive ellipses */
9942 ellipsis = cp1; continue;
9944 wilddsc.dsc$a_pointer = tpl;
9945 wilddsc.dsc$w_length = resdsc.dsc$w_length = ellipsis - 1 - cp1;
9947 for (segdirs = 0, cp2 = tpl;
9948 cp1 <= ellipsis - 1 && cp2 <= tpl + (VMS_MAXRSS-1);
9950 if (*cp1 == '?') *cp2 = '%'; /* Substitute VMS' wildcard for Unix' */
9952 if (!decc_efs_case_preserve) {
9953 *cp2 = _tolower(*cp1); /* else lowercase for match */
9956 *cp2 = *cp1; /* else preserve case for match */
9959 if (*cp2 == '/') segdirs++;
9961 if (cp1 != ellipsis - 1) {
9963 PerlMem_free(unixified);
9964 PerlMem_free(unixwild);
9965 PerlMem_free(lcres);
9966 return 0; /* Path too long */
9968 /* Back up at least as many dirs as in template before matching */
9969 for (cp1 = lcfront - 1; segdirs && cp1 >= lcres; cp1--)
9970 if (*cp1 == '/' && !segdirs--) { cp1++; break; }
9971 for (match = 0; cp1 > lcres;) {
9972 resdsc.dsc$a_pointer = cp1;
9973 if (str$match_wild(&wilddsc,&resdsc) == STR$_MATCH) {
9975 if (match == 1) lcfront = cp1;
9977 for ( ; cp1 >= lcres; cp1--) if (*cp1 == '/') { cp1++; break; }
9981 PerlMem_free(unixified);
9982 PerlMem_free(unixwild);
9983 PerlMem_free(lcres);
9984 return 0; /* Can't find prefix ??? */
9986 if (match > 1 && opts & 1) {
9987 /* This ... wildcard could cover more than one set of dirs (i.e.
9988 * a set of similar dir names is repeated). If the template
9989 * contains more than 1 ..., upstream elements could resolve the
9990 * ambiguity, but it's not worth a full backtracking setup here.
9991 * As a quick heuristic, clip off the current default directory
9992 * if it's present to find the trimmed spec, else use the
9993 * shortest string that this ... could cover.
9995 char def[NAM$C_MAXRSS+1], *st;
9997 if (getcwd(def, sizeof def,0) == NULL) {
9998 PerlMem_free(unixified);
9999 PerlMem_free(unixwild);
10000 PerlMem_free(lcres);
10004 if (!decc_efs_case_preserve) {
10005 for (cp1 = def, cp2 = base; *cp1 && *cp2; cp1++,cp2++)
10006 if (_tolower(*cp1) != _tolower(*cp2)) break;
10008 segdirs = dirs - totells; /* Min # of dirs we must have left */
10009 for (st = cp2+1; *st; st++) if (*st == '/') segdirs--;
10010 if (*cp1 == '\0' && *cp2 == '/') {
10011 memmove(fspec,cp2+1,end - cp2);
10013 PerlMem_free(unixified);
10014 PerlMem_free(unixwild);
10015 PerlMem_free(lcres);
10018 /* Nope -- stick with lcfront from above and keep going. */
10021 memmove(fspec,base + (lcfront - lcres), lcend - lcfront + 1);
10023 PerlMem_free(unixified);
10024 PerlMem_free(unixwild);
10025 PerlMem_free(lcres);
10027 ellipsis = nextell;
10030 } /* end of trim_unixpath() */
10035 * VMS readdir() routines.
10036 * Written by Rich $alz, <rsalz@bbn.com> in August, 1990.
10038 * 21-Jul-1994 Charles Bailey bailey@newman.upenn.edu
10039 * Minor modifications to original routines.
10042 /* readdir may have been redefined by reentr.h, so make sure we get
10043 * the local version for what we do here.
10048 #if !defined(PERL_IMPLICIT_CONTEXT)
10049 # define readdir Perl_readdir
10051 # define readdir(a) Perl_readdir(aTHX_ a)
10054 /* Number of elements in vms_versions array */
10055 #define VERSIZE(e) (sizeof e->vms_versions / sizeof e->vms_versions[0])
10058 * Open a directory, return a handle for later use.
10060 /*{{{ DIR *opendir(char*name) */
10062 Perl_opendir(pTHX_ const char *name)
10068 Newx(dir, VMS_MAXRSS, char);
10069 if (do_tovmspath(name,dir,0,NULL) == NULL) {
10073 /* Check access before stat; otherwise stat does not
10074 * accurately report whether it's a directory.
10076 if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) {
10077 /* cando_by_name has already set errno */
10081 if (flex_stat(dir,&sb) == -1) return NULL;
10082 if (!S_ISDIR(sb.st_mode)) {
10084 set_errno(ENOTDIR); set_vaxc_errno(RMS$_DIR);
10087 /* Get memory for the handle, and the pattern. */
10089 Newx(dd->pattern,strlen(dir)+sizeof "*.*" + 1,char);
10091 /* Fill in the fields; mainly playing with the descriptor. */
10092 sprintf(dd->pattern, "%s*.*",dir);
10097 /* By saying we always want the result of readdir() in unix format, we
10098 * are really saying we want all the escapes removed. Otherwise the caller,
10099 * having no way to know whether it's already in VMS format, might send it
10100 * through tovmsspec again, thus double escaping.
10102 dd->flags = PERL_VMSDIR_M_UNIXSPECS;
10103 dd->pat.dsc$a_pointer = dd->pattern;
10104 dd->pat.dsc$w_length = strlen(dd->pattern);
10105 dd->pat.dsc$b_dtype = DSC$K_DTYPE_T;
10106 dd->pat.dsc$b_class = DSC$K_CLASS_S;
10107 #if defined(USE_ITHREADS)
10108 Newx(dd->mutex,1,perl_mutex);
10109 MUTEX_INIT( (perl_mutex *) dd->mutex );
10115 } /* end of opendir() */
10119 * Set the flag to indicate we want versions or not.
10121 /*{{{ void vmsreaddirversions(DIR *dd, int flag)*/
10123 vmsreaddirversions(DIR *dd, int flag)
10126 dd->flags |= PERL_VMSDIR_M_VERSIONS;
10128 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10133 * Free up an opened directory.
10135 /*{{{ void closedir(DIR *dd)*/
10137 Perl_closedir(DIR *dd)
10141 sts = lib$find_file_end(&dd->context);
10142 Safefree(dd->pattern);
10143 #if defined(USE_ITHREADS)
10144 MUTEX_DESTROY( (perl_mutex *) dd->mutex );
10145 Safefree(dd->mutex);
10152 * Collect all the version numbers for the current file.
10155 collectversions(pTHX_ DIR *dd)
10157 struct dsc$descriptor_s pat;
10158 struct dsc$descriptor_s res;
10160 char *p, *text, *buff;
10162 unsigned long context, tmpsts;
10164 /* Convenient shorthand. */
10167 /* Add the version wildcard, ignoring the "*.*" put on before */
10168 i = strlen(dd->pattern);
10169 Newx(text,i + e->d_namlen + 3,char);
10170 strcpy(text, dd->pattern);
10171 sprintf(&text[i - 3], "%s;*", e->d_name);
10173 /* Set up the pattern descriptor. */
10174 pat.dsc$a_pointer = text;
10175 pat.dsc$w_length = i + e->d_namlen - 1;
10176 pat.dsc$b_dtype = DSC$K_DTYPE_T;
10177 pat.dsc$b_class = DSC$K_CLASS_S;
10179 /* Set up result descriptor. */
10180 Newx(buff, VMS_MAXRSS, char);
10181 res.dsc$a_pointer = buff;
10182 res.dsc$w_length = VMS_MAXRSS - 1;
10183 res.dsc$b_dtype = DSC$K_DTYPE_T;
10184 res.dsc$b_class = DSC$K_CLASS_S;
10186 /* Read files, collecting versions. */
10187 for (context = 0, e->vms_verscount = 0;
10188 e->vms_verscount < VERSIZE(e);
10189 e->vms_verscount++) {
10190 unsigned long rsts;
10191 unsigned long flags = 0;
10193 #ifdef VMS_LONGNAME_SUPPORT
10194 flags = LIB$M_FIL_LONG_NAMES;
10196 tmpsts = lib$find_file(&pat, &res, &context, NULL, NULL, &rsts, &flags);
10197 if (tmpsts == RMS$_NMF || context == 0) break;
10199 buff[VMS_MAXRSS - 1] = '\0';
10200 if ((p = strchr(buff, ';')))
10201 e->vms_versions[e->vms_verscount] = atoi(p + 1);
10203 e->vms_versions[e->vms_verscount] = -1;
10206 _ckvmssts(lib$find_file_end(&context));
10210 } /* end of collectversions() */
10213 * Read the next entry from the directory.
10215 /*{{{ struct dirent *readdir(DIR *dd)*/
10217 Perl_readdir(pTHX_ DIR *dd)
10219 struct dsc$descriptor_s res;
10221 unsigned long int tmpsts;
10222 unsigned long rsts;
10223 unsigned long flags = 0;
10224 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
10225 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
10227 /* Set up result descriptor, and get next file. */
10228 Newx(buff, VMS_MAXRSS, char);
10229 res.dsc$a_pointer = buff;
10230 res.dsc$w_length = VMS_MAXRSS - 1;
10231 res.dsc$b_dtype = DSC$K_DTYPE_T;
10232 res.dsc$b_class = DSC$K_CLASS_S;
10234 #ifdef VMS_LONGNAME_SUPPORT
10235 flags = LIB$M_FIL_LONG_NAMES;
10238 tmpsts = lib$find_file
10239 (&dd->pat, &res, &dd->context, NULL, NULL, &rsts, &flags);
10240 if ( tmpsts == RMS$_NMF || dd->context == 0) return NULL; /* None left. */
10241 if (!(tmpsts & 1)) {
10242 set_vaxc_errno(tmpsts);
10245 set_errno(EACCES); break;
10247 set_errno(ENODEV); break;
10249 set_errno(ENOTDIR); break;
10250 case RMS$_FNF: case RMS$_DNF:
10251 set_errno(ENOENT); break;
10253 set_errno(EVMSERR);
10259 /* Force the buffer to end with a NUL, and downcase name to match C convention. */
10260 buff[res.dsc$w_length] = '\0';
10261 p = buff + res.dsc$w_length;
10262 while (--p >= buff) if (!isspace(*p)) break;
10264 if (!decc_efs_case_preserve) {
10265 for (p = buff; *p; p++) *p = _tolower(*p);
10268 /* Skip any directory component and just copy the name. */
10269 sts = vms_split_path
10284 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10286 /* In Unix report mode, remove the ".dir;1" from the name */
10287 /* if it is a real directory. */
10288 if (decc_filename_unix_report || decc_efs_charset) {
10289 if ((e_len == 4) && (vs_len == 2) && (vs_spec[1] == '1')) {
10290 if ((toupper(e_spec[1]) == 'D') &&
10291 (toupper(e_spec[2]) == 'I') &&
10292 (toupper(e_spec[3]) == 'R')) {
10296 ret_sts = stat(buff, (stat_t *)&statbuf);
10297 if ((ret_sts == 0) && S_ISDIR(statbuf.st_mode)) {
10305 /* Drop NULL extensions on UNIX file specification */
10306 if ((e_len == 1) && decc_readdir_dropdotnotype) {
10312 strncpy(dd->entry.d_name, n_spec, n_len + e_len);
10313 dd->entry.d_name[n_len + e_len] = '\0';
10314 dd->entry.d_namlen = strlen(dd->entry.d_name);
10316 /* Convert the filename to UNIX format if needed */
10317 if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) {
10319 /* Translate the encoded characters. */
10320 /* Fixme: Unicode handling could result in embedded 0 characters */
10321 if (strchr(dd->entry.d_name, '^') != NULL) {
10322 char new_name[256];
10324 p = dd->entry.d_name;
10327 int inchars_read, outchars_added;
10328 inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added);
10330 q += outchars_added;
10332 /* if outchars_added > 1, then this is a wide file specification */
10333 /* Wide file specifications need to be passed in Perl */
10334 /* counted strings apparently with a Unicode flag */
10337 strcpy(dd->entry.d_name, new_name);
10338 dd->entry.d_namlen = strlen(dd->entry.d_name);
10342 dd->entry.vms_verscount = 0;
10343 if (dd->flags & PERL_VMSDIR_M_VERSIONS) collectversions(aTHX_ dd);
10347 } /* end of readdir() */
10351 * Read the next entry from the directory -- thread-safe version.
10353 /*{{{ int readdir_r(DIR *dd, struct dirent *entry, struct dirent **result)*/
10355 Perl_readdir_r(pTHX_ DIR *dd, struct dirent *entry, struct dirent **result)
10359 MUTEX_LOCK( (perl_mutex *) dd->mutex );
10361 entry = readdir(dd);
10363 retval = ( *result == NULL ? errno : 0 );
10365 MUTEX_UNLOCK( (perl_mutex *) dd->mutex );
10369 } /* end of readdir_r() */
10373 * Return something that can be used in a seekdir later.
10375 /*{{{ long telldir(DIR *dd)*/
10377 Perl_telldir(DIR *dd)
10384 * Return to a spot where we used to be. Brute force.
10386 /*{{{ void seekdir(DIR *dd,long count)*/
10388 Perl_seekdir(pTHX_ DIR *dd, long count)
10392 /* If we haven't done anything yet... */
10393 if (dd->count == 0)
10396 /* Remember some state, and clear it. */
10397 old_flags = dd->flags;
10398 dd->flags &= ~PERL_VMSDIR_M_VERSIONS;
10399 _ckvmssts(lib$find_file_end(&dd->context));
10402 /* The increment is in readdir(). */
10403 for (dd->count = 0; dd->count < count; )
10406 dd->flags = old_flags;
10408 } /* end of seekdir() */
10411 /* VMS subprocess management
10413 * my_vfork() - just a vfork(), after setting a flag to record that
10414 * the current script is trying a Unix-style fork/exec.
10416 * vms_do_aexec() and vms_do_exec() are called in response to the
10417 * perl 'exec' function. If this follows a vfork call, then they
10418 * call out the regular perl routines in doio.c which do an
10419 * execvp (for those who really want to try this under VMS).
10420 * Otherwise, they do exactly what the perl docs say exec should
10421 * do - terminate the current script and invoke a new command
10422 * (See below for notes on command syntax.)
10424 * do_aspawn() and do_spawn() implement the VMS side of the perl
10425 * 'system' function.
10427 * Note on command arguments to perl 'exec' and 'system': When handled
10428 * in 'VMSish fashion' (i.e. not after a call to vfork) The args
10429 * are concatenated to form a DCL command string. If the first non-numeric
10430 * arg begins with '$' (i.e. the perl script had "\$ Type" or some such),
10431 * the command string is handed off to DCL directly. Otherwise,
10432 * the first token of the command is taken as the filespec of an image
10433 * to run. The filespec is expanded using a default type of '.EXE' and
10434 * the process defaults for device, directory, etc., and if found, the resultant
10435 * filespec is invoked using the DCL verb 'MCR', and passed the rest of
10436 * the command string as parameters. This is perhaps a bit complicated,
10437 * but I hope it will form a happy medium between what VMS folks expect
10438 * from lib$spawn and what Unix folks expect from exec.
10441 static int vfork_called;
10443 /*{{{int my_vfork()*/
10454 vms_execfree(struct dsc$descriptor_s *vmscmd)
10457 if (vmscmd->dsc$a_pointer) {
10458 PerlMem_free(vmscmd->dsc$a_pointer);
10460 PerlMem_free(vmscmd);
10465 setup_argstr(pTHX_ SV *really, SV **mark, SV **sp)
10467 char *junk, *tmps = NULL;
10468 register size_t cmdlen = 0;
10475 tmps = SvPV(really,rlen);
10477 cmdlen += rlen + 1;
10482 for (idx++; idx <= sp; idx++) {
10484 junk = SvPVx(*idx,rlen);
10485 cmdlen += rlen ? rlen + 1 : 0;
10488 Newx(PL_Cmd, cmdlen+1, char);
10490 if (tmps && *tmps) {
10491 strcpy(PL_Cmd,tmps);
10494 else *PL_Cmd = '\0';
10495 while (++mark <= sp) {
10497 char *s = SvPVx(*mark,n_a);
10499 if (*PL_Cmd) strcat(PL_Cmd," ");
10505 } /* end of setup_argstr() */
10508 static unsigned long int
10509 setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote,
10510 struct dsc$descriptor_s **pvmscmd)
10514 char image_name[NAM$C_MAXRSS+1];
10515 char image_argv[NAM$C_MAXRSS+1];
10516 $DESCRIPTOR(defdsc,".EXE");
10517 $DESCRIPTOR(defdsc2,".");
10518 struct dsc$descriptor_s resdsc;
10519 struct dsc$descriptor_s *vmscmd;
10520 struct dsc$descriptor_s imgdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10521 unsigned long int cxt = 0, flags = 1, retsts = SS$_NORMAL;
10522 register char *s, *rest, *cp, *wordbreak;
10525 register int isdcl;
10527 vmscmd = PerlMem_malloc(sizeof(struct dsc$descriptor_s));
10528 if (vmscmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10530 /* vmsspec is a DCL command buffer, not just a filename */
10531 vmsspec = PerlMem_malloc(MAX_DCL_LINE_LENGTH + 1);
10532 if (vmsspec == NULL)
10533 _ckvmssts_noperl(SS$_INSFMEM);
10535 resspec = PerlMem_malloc(VMS_MAXRSS);
10536 if (resspec == NULL)
10537 _ckvmssts_noperl(SS$_INSFMEM);
10539 /* Make a copy for modification */
10540 cmdlen = strlen(incmd);
10541 cmd = PerlMem_malloc(cmdlen+1);
10542 if (cmd == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10543 strncpy(cmd, incmd, cmdlen);
10548 resdsc.dsc$a_pointer = resspec;
10549 resdsc.dsc$b_dtype = DSC$K_DTYPE_T;
10550 resdsc.dsc$b_class = DSC$K_CLASS_S;
10551 resdsc.dsc$w_length = VMS_MAXRSS - 1;
10553 vmscmd->dsc$a_pointer = NULL;
10554 vmscmd->dsc$b_dtype = DSC$K_DTYPE_T;
10555 vmscmd->dsc$b_class = DSC$K_CLASS_S;
10556 vmscmd->dsc$w_length = 0;
10557 if (pvmscmd) *pvmscmd = vmscmd;
10559 if (suggest_quote) *suggest_quote = 0;
10561 if (strlen(cmd) > MAX_DCL_LINE_LENGTH) {
10563 PerlMem_free(vmsspec);
10564 PerlMem_free(resspec);
10565 return CLI$_BUFOVF; /* continuation lines currently unsupported */
10570 while (*s && isspace(*s)) s++;
10572 if (*s == '@' || *s == '$') {
10573 vmsspec[0] = *s; rest = s + 1;
10574 for (cp = &vmsspec[1]; *rest && isspace(*rest); rest++,cp++) *cp = *rest;
10576 else { cp = vmsspec; rest = s; }
10577 if (*rest == '.' || *rest == '/') {
10579 for (cp2 = resspec;
10580 *rest && !isspace(*rest) && cp2 - resspec < (VMS_MAXRSS - 1);
10581 rest++, cp2++) *cp2 = *rest;
10583 if (int_tovmsspec(resspec, cp, 0, NULL)) {
10586 /* When a UNIX spec with no file type is translated to VMS, */
10587 /* A trailing '.' is appended under ODS-5 rules. */
10588 /* Here we do not want that trailing "." as it prevents */
10589 /* Looking for a implied ".exe" type. */
10590 if (decc_efs_charset) {
10592 i = strlen(vmsspec);
10593 if (vmsspec[i-1] == '.') {
10594 vmsspec[i-1] = '\0';
10599 for (cp2 = vmsspec + strlen(vmsspec);
10600 *rest && cp2 - vmsspec < MAX_DCL_LINE_LENGTH;
10601 rest++, cp2++) *cp2 = *rest;
10606 /* Intuit whether verb (first word of cmd) is a DCL command:
10607 * - if first nonspace char is '@', it's a DCL indirection
10609 * - if verb contains a filespec separator, it's not a DCL command
10610 * - if it doesn't, caller tells us whether to default to a DCL
10611 * command, or to a local image unless told it's DCL (by leading '$')
10615 if (suggest_quote) *suggest_quote = 1;
10617 register char *filespec = strpbrk(s,":<[.;");
10618 rest = wordbreak = strpbrk(s," \"\t/");
10619 if (!wordbreak) wordbreak = s + strlen(s);
10620 if (*s == '$') check_img = 0;
10621 if (filespec && (filespec < wordbreak)) isdcl = 0;
10622 else isdcl = !check_img;
10627 imgdsc.dsc$a_pointer = s;
10628 imgdsc.dsc$w_length = wordbreak - s;
10629 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10631 _ckvmssts_noperl(lib$find_file_end(&cxt));
10632 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10633 if (!(retsts & 1) && *s == '$') {
10634 _ckvmssts_noperl(lib$find_file_end(&cxt));
10635 imgdsc.dsc$a_pointer++; imgdsc.dsc$w_length--;
10636 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc,0,&rsts,&flags);
10638 _ckvmssts_noperl(lib$find_file_end(&cxt));
10639 retsts = lib$find_file(&imgdsc,&resdsc,&cxt,&defdsc2,0,&rsts,&flags);
10643 _ckvmssts_noperl(lib$find_file_end(&cxt));
10648 while (*s && !isspace(*s)) s++;
10651 /* check that it's really not DCL with no file extension */
10652 fp = fopen(resspec,"r","ctx=bin","ctx=rec","shr=get");
10654 char b[256] = {0,0,0,0};
10655 read(fileno(fp), b, 256);
10656 isdcl = isprint(b[0]) && isprint(b[1]) && isprint(b[2]) && isprint(b[3]);
10660 /* Check for script */
10662 if ((b[0] == '#') && (b[1] == '!'))
10664 #ifdef ALTERNATE_SHEBANG
10666 shebang_len = strlen(ALTERNATE_SHEBANG);
10667 if (strncmp(b, ALTERNATE_SHEBANG, shebang_len) == 0) {
10669 perlstr = strstr("perl",b);
10670 if (perlstr == NULL)
10678 if (shebang_len > 0) {
10681 char tmpspec[NAM$C_MAXRSS + 1];
10684 /* Image is following after white space */
10685 /*--------------------------------------*/
10686 while (isprint(b[i]) && isspace(b[i]))
10690 while (isprint(b[i]) && !isspace(b[i])) {
10691 tmpspec[j++] = b[i++];
10692 if (j >= NAM$C_MAXRSS)
10697 /* There may be some default parameters to the image */
10698 /*---------------------------------------------------*/
10700 while (isprint(b[i])) {
10701 image_argv[j++] = b[i++];
10702 if (j >= NAM$C_MAXRSS)
10705 while ((j > 0) && !isprint(image_argv[j-1]))
10709 /* It will need to be converted to VMS format and validated */
10710 if (tmpspec[0] != '\0') {
10713 /* Try to find the exact program requested to be run */
10714 /*---------------------------------------------------*/
10715 iname = int_rmsexpand
10716 (tmpspec, image_name, ".exe",
10717 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10718 if (iname != NULL) {
10719 if (cando_by_name_int
10720 (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) {
10721 /* MCR prefix needed */
10725 /* Try again with a null type */
10726 /*----------------------------*/
10727 iname = int_rmsexpand
10728 (tmpspec, image_name, ".",
10729 PERL_RMSEXPAND_M_VMS, NULL, NULL);
10730 if (iname != NULL) {
10731 if (cando_by_name_int
10732 (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) {
10733 /* MCR prefix needed */
10739 /* Did we find the image to run the script? */
10740 /*------------------------------------------*/
10744 /* Assume DCL or foreign command exists */
10745 /*--------------------------------------*/
10746 tchr = strrchr(tmpspec, '/');
10747 if (tchr != NULL) {
10753 strcpy(image_name, tchr);
10761 if (check_img && isdcl) {
10763 PerlMem_free(resspec);
10764 PerlMem_free(vmsspec);
10768 if (cando_by_name(S_IXUSR,0,resspec)) {
10769 vmscmd->dsc$a_pointer = PerlMem_malloc(MAX_DCL_LINE_LENGTH);
10770 if (vmscmd->dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
10772 strcpy(vmscmd->dsc$a_pointer,"$ MCR ");
10773 if (image_name[0] != 0) {
10774 strcat(vmscmd->dsc$a_pointer, image_name);
10775 strcat(vmscmd->dsc$a_pointer, " ");
10777 } else if (image_name[0] != 0) {
10778 strcpy(vmscmd->dsc$a_pointer, image_name);
10779 strcat(vmscmd->dsc$a_pointer, " ");
10781 strcpy(vmscmd->dsc$a_pointer,"@");
10783 if (suggest_quote) *suggest_quote = 1;
10785 /* If there is an image name, use original command */
10786 if (image_name[0] == 0)
10787 strcat(vmscmd->dsc$a_pointer,resspec);
10790 while (*rest && isspace(*rest)) rest++;
10793 if (image_argv[0] != 0) {
10794 strcat(vmscmd->dsc$a_pointer,image_argv);
10795 strcat(vmscmd->dsc$a_pointer, " ");
10801 rest_len = strlen(rest);
10802 vmscmd_len = strlen(vmscmd->dsc$a_pointer);
10803 if ((rest_len + vmscmd_len) < MAX_DCL_LINE_LENGTH)
10804 strcat(vmscmd->dsc$a_pointer,rest);
10806 retsts = CLI$_BUFOVF;
10808 vmscmd->dsc$w_length = strlen(vmscmd->dsc$a_pointer);
10810 PerlMem_free(vmsspec);
10811 PerlMem_free(resspec);
10812 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10818 /* It's either a DCL command or we couldn't find a suitable image */
10819 vmscmd->dsc$w_length = strlen(cmd);
10821 vmscmd->dsc$a_pointer = PerlMem_malloc(vmscmd->dsc$w_length + 1);
10822 strncpy(vmscmd->dsc$a_pointer,cmd,vmscmd->dsc$w_length);
10823 vmscmd->dsc$a_pointer[vmscmd->dsc$w_length] = 0;
10826 PerlMem_free(resspec);
10827 PerlMem_free(vmsspec);
10829 /* check if it's a symbol (for quoting purposes) */
10830 if (suggest_quote && !*suggest_quote) {
10832 char equiv[LNM$C_NAMLENGTH];
10833 struct dsc$descriptor_s eqvdsc = {sizeof(equiv), DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
10834 eqvdsc.dsc$a_pointer = equiv;
10836 iss = lib$get_symbol(vmscmd,&eqvdsc);
10837 if (iss&1 && (*equiv == '$' || *equiv == '@')) *suggest_quote = 1;
10839 if (!(retsts & 1)) {
10840 /* just hand off status values likely to be due to user error */
10841 if (retsts == RMS$_FNF || retsts == RMS$_DNF || retsts == RMS$_PRV ||
10842 retsts == RMS$_DEV || retsts == RMS$_DIR || retsts == RMS$_SYN ||
10843 (retsts & STS$M_CODE) == (SHR$_NOWILD & STS$M_CODE)) return retsts;
10844 else { _ckvmssts_noperl(retsts); }
10847 return (vmscmd->dsc$w_length > MAX_DCL_LINE_LENGTH ? CLI$_BUFOVF : retsts);
10849 } /* end of setup_cmddsc() */
10852 /* {{{ bool vms_do_aexec(SV *really,SV **mark,SV **sp) */
10854 Perl_vms_do_aexec(pTHX_ SV *really,SV **mark,SV **sp)
10860 if (vfork_called) { /* this follows a vfork - act Unixish */
10862 if (vfork_called < 0) {
10863 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10866 else return do_aexec(really,mark,sp);
10868 /* no vfork - act VMSish */
10869 cmd = setup_argstr(aTHX_ really,mark,sp);
10870 exec_sts = vms_do_exec(cmd);
10871 Safefree(cmd); /* Clean up from setup_argstr() */
10876 } /* end of vms_do_aexec() */
10879 /* {{{bool vms_do_exec(char *cmd) */
10881 Perl_vms_do_exec(pTHX_ const char *cmd)
10883 struct dsc$descriptor_s *vmscmd;
10885 if (vfork_called) { /* this follows a vfork - act Unixish */
10887 if (vfork_called < 0) {
10888 Perl_warn(aTHX_ "Internal inconsistency in tracking vforks");
10891 else return do_exec(cmd);
10894 { /* no vfork - act VMSish */
10895 unsigned long int retsts;
10898 TAINT_PROPER("exec");
10899 if ((retsts = setup_cmddsc(aTHX_ cmd,1,0,&vmscmd)) & 1)
10900 retsts = lib$do_command(vmscmd);
10903 case RMS$_FNF: case RMS$_DNF:
10904 set_errno(ENOENT); break;
10906 set_errno(ENOTDIR); break;
10908 set_errno(ENODEV); break;
10910 set_errno(EACCES); break;
10912 set_errno(EINVAL); break;
10913 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
10914 set_errno(E2BIG); break;
10915 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
10916 _ckvmssts_noperl(retsts); /* fall through */
10917 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
10918 set_errno(EVMSERR);
10920 set_vaxc_errno(retsts);
10921 if (ckWARN(WARN_EXEC)) {
10922 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't exec \"%*s\": %s",
10923 vmscmd->dsc$w_length, vmscmd->dsc$a_pointer, Strerror(errno));
10925 vms_execfree(vmscmd);
10930 } /* end of vms_do_exec() */
10933 int do_spawn2(pTHX_ const char *, int);
10936 Perl_do_aspawn(pTHX_ SV* really, SV** mark, SV** sp)
10938 unsigned long int sts;
10944 /* We'll copy the (undocumented?) Win32 behavior and allow a
10945 * numeric first argument. But the only value we'll support
10946 * through do_aspawn is a value of 1, which means spawn without
10947 * waiting for completion -- other values are ignored.
10949 if (SvNIOKp(*(mark+1)) && !SvPOKp(*(mark+1))) {
10951 flags = SvIVx(*mark);
10954 if (flags && flags == 1) /* the Win32 P_NOWAIT value */
10955 flags = CLI$M_NOWAIT;
10959 cmd = setup_argstr(aTHX_ really, mark, sp);
10960 sts = do_spawn2(aTHX_ cmd, flags);
10961 /* pp_sys will clean up cmd */
10965 } /* end of do_aspawn() */
10969 /* {{{int do_spawn(char* cmd) */
10971 Perl_do_spawn(pTHX_ char* cmd)
10973 PERL_ARGS_ASSERT_DO_SPAWN;
10975 return do_spawn2(aTHX_ cmd, 0);
10979 /* {{{int do_spawn_nowait(char* cmd) */
10981 Perl_do_spawn_nowait(pTHX_ char* cmd)
10983 PERL_ARGS_ASSERT_DO_SPAWN_NOWAIT;
10985 return do_spawn2(aTHX_ cmd, CLI$M_NOWAIT);
10989 /* {{{int do_spawn2(char *cmd) */
10991 do_spawn2(pTHX_ const char *cmd, int flags)
10993 unsigned long int sts, substs;
10995 /* The caller of this routine expects to Safefree(PL_Cmd) */
10996 Newx(PL_Cmd,10,char);
10999 TAINT_PROPER("spawn");
11000 if (!cmd || !*cmd) {
11001 sts = lib$spawn(0,0,0,&flags,0,0,&substs,0,0,0,0,0,0);
11004 case RMS$_FNF: case RMS$_DNF:
11005 set_errno(ENOENT); break;
11007 set_errno(ENOTDIR); break;
11009 set_errno(ENODEV); break;
11011 set_errno(EACCES); break;
11013 set_errno(EINVAL); break;
11014 case CLI$_BUFOVF: case RMS$_RTB: case CLI$_TKNOVF: case CLI$_RSLOVF:
11015 set_errno(E2BIG); break;
11016 case LIB$_INVARG: case LIB$_INVSTRDES: case SS$_ACCVIO: /* shouldn't happen */
11017 _ckvmssts_noperl(sts); /* fall through */
11018 default: /* SS$_DUPLNAM, SS$_CLI, resource exhaustion, etc. */
11019 set_errno(EVMSERR);
11021 set_vaxc_errno(sts);
11022 if (ckWARN(WARN_EXEC)) {
11023 Perl_warner(aTHX_ packWARN(WARN_EXEC),"Can't spawn: %s",
11032 if (flags & CLI$M_NOWAIT)
11035 strcpy(mode, "nW");
11037 fp = safe_popen(aTHX_ cmd, mode, (int *)&sts);
11040 /* sts will be the pid in the nowait case */
11043 } /* end of do_spawn2() */
11047 static unsigned int *sockflags, sockflagsize;
11050 * Shim fdopen to identify sockets for my_fwrite later, since the stdio
11051 * routines found in some versions of the CRTL can't deal with sockets.
11052 * We don't shim the other file open routines since a socket isn't
11053 * likely to be opened by a name.
11055 /*{{{ FILE *my_fdopen(int fd, const char *mode)*/
11056 FILE *my_fdopen(int fd, const char *mode)
11058 FILE *fp = fdopen(fd, mode);
11061 unsigned int fdoff = fd / sizeof(unsigned int);
11062 Stat_t sbuf; /* native stat; we don't need flex_stat */
11063 if (!sockflagsize || fdoff > sockflagsize) {
11064 if (sockflags) Renew( sockflags,fdoff+2,unsigned int);
11065 else Newx (sockflags,fdoff+2,unsigned int);
11066 memset(sockflags+sockflagsize,0,fdoff + 2 - sockflagsize);
11067 sockflagsize = fdoff + 2;
11069 if (fstat(fd, (struct stat *)&sbuf) == 0 && S_ISSOCK(sbuf.st_mode))
11070 sockflags[fdoff] |= 1 << (fd % sizeof(unsigned int));
11079 * Clear the corresponding bit when the (possibly) socket stream is closed.
11080 * There still a small hole: we miss an implicit close which might occur
11081 * via freopen(). >> Todo
11083 /*{{{ int my_fclose(FILE *fp)*/
11084 int my_fclose(FILE *fp) {
11086 unsigned int fd = fileno(fp);
11087 unsigned int fdoff = fd / sizeof(unsigned int);
11089 if (sockflagsize && fdoff < sockflagsize)
11090 sockflags[fdoff] &= ~(1 << fd % sizeof(unsigned int));
11098 * A simple fwrite replacement which outputs itmsz*nitm chars without
11099 * introducing record boundaries every itmsz chars.
11100 * We are using fputs, which depends on a terminating null. We may
11101 * well be writing binary data, so we need to accommodate not only
11102 * data with nulls sprinkled in the middle but also data with no null
11105 /*{{{ int my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)*/
11107 my_fwrite(const void *src, size_t itmsz, size_t nitm, FILE *dest)
11109 register char *cp, *end, *cpd, *data;
11110 register unsigned int fd = fileno(dest);
11111 register unsigned int fdoff = fd / sizeof(unsigned int);
11113 int bufsize = itmsz * nitm + 1;
11115 if (fdoff < sockflagsize &&
11116 (sockflags[fdoff] | 1 << (fd % sizeof(unsigned int)))) {
11117 if (write(fd, src, itmsz * nitm) == EOF) return EOF;
11121 _ckvmssts_noperl(lib$get_vm(&bufsize, &data));
11122 memcpy( data, src, itmsz*nitm );
11123 data[itmsz*nitm] = '\0';
11125 end = data + itmsz * nitm;
11126 retval = (int) nitm; /* on success return # items written */
11129 while (cpd <= end) {
11130 for (cp = cpd; cp <= end; cp++) if (!*cp) break;
11131 if (fputs(cpd,dest) == EOF) { retval = EOF; break; }
11133 if (fputc('\0',dest) == EOF) { retval = EOF; break; }
11137 if (data) _ckvmssts_noperl(lib$free_vm(&bufsize, &data));
11140 } /* end of my_fwrite() */
11143 /*{{{ int my_flush(FILE *fp)*/
11145 Perl_my_flush(pTHX_ FILE *fp)
11148 if ((res = fflush(fp)) == 0 && fp) {
11149 #ifdef VMS_DO_SOCKETS
11151 if (fstat(fileno(fp), &s.crtl_stat) == 0 && !S_ISSOCK(s.st_mode))
11153 res = fsync(fileno(fp));
11156 * If the flush succeeded but set end-of-file, we need to clear
11157 * the error because our caller may check ferror(). BTW, this
11158 * probably means we just flushed an empty file.
11160 if (res == 0 && vaxc$errno == RMS$_EOF) clearerr(fp);
11167 * Here are replacements for the following Unix routines in the VMS environment:
11168 * getpwuid Get information for a particular UIC or UID
11169 * getpwnam Get information for a named user
11170 * getpwent Get information for each user in the rights database
11171 * setpwent Reset search to the start of the rights database
11172 * endpwent Finish searching for users in the rights database
11174 * getpwuid, getpwnam, and getpwent return a pointer to the passwd structure
11175 * (defined in pwd.h), which contains the following fields:-
11177 * char *pw_name; Username (in lower case)
11178 * char *pw_passwd; Hashed password
11179 * unsigned int pw_uid; UIC
11180 * unsigned int pw_gid; UIC group number
11181 * char *pw_unixdir; Default device/directory (VMS-style)
11182 * char *pw_gecos; Owner name
11183 * char *pw_dir; Default device/directory (Unix-style)
11184 * char *pw_shell; Default CLI name (eg. DCL)
11186 * If the specified user does not exist, getpwuid and getpwnam return NULL.
11188 * pw_uid is the full UIC (eg. what's returned by stat() in st_uid).
11189 * not the UIC member number (eg. what's returned by getuid()),
11190 * getpwuid() can accept either as input (if uid is specified, the caller's
11191 * UIC group is used), though it won't recognise gid=0.
11193 * Note that in VMS it is necessary to have GRPPRV or SYSPRV to return
11194 * information about other users in your group or in other groups, respectively.
11195 * If the required privilege is not available, then these routines fill only
11196 * the pw_name, pw_uid, and pw_gid fields (the others point to an empty
11199 * By Tim Adye (T.J.Adye@rl.ac.uk), 10th February 1995.
11202 /* sizes of various UAF record fields */
11203 #define UAI$S_USERNAME 12
11204 #define UAI$S_IDENT 31
11205 #define UAI$S_OWNER 31
11206 #define UAI$S_DEFDEV 31
11207 #define UAI$S_DEFDIR 63
11208 #define UAI$S_DEFCLI 31
11209 #define UAI$S_PWD 8
11211 #define valid_uic(uic) ((uic).uic$v_format == UIC$K_UIC_FORMAT && \
11212 (uic).uic$v_member != UIC$K_WILD_MEMBER && \
11213 (uic).uic$v_group != UIC$K_WILD_GROUP)
11215 static char __empty[]= "";
11216 static struct passwd __passwd_empty=
11217 {(char *) __empty, (char *) __empty, 0, 0,
11218 (char *) __empty, (char *) __empty, (char *) __empty, (char *) __empty};
11219 static int contxt= 0;
11220 static struct passwd __pwdcache;
11221 static char __pw_namecache[UAI$S_IDENT+1];
11224 * This routine does most of the work extracting the user information.
11226 static int fillpasswd (pTHX_ const char *name, struct passwd *pwd)
11229 unsigned char length;
11230 char pw_gecos[UAI$S_OWNER+1];
11232 static union uicdef uic;
11234 unsigned char length;
11235 char pw_dir[UAI$S_DEFDEV+UAI$S_DEFDIR+1];
11238 unsigned char length;
11239 char unixdir[UAI$_DEFDEV+UAI$S_DEFDIR+1];
11242 unsigned char length;
11243 char pw_shell[UAI$S_DEFCLI+1];
11245 static char pw_passwd[UAI$S_PWD+1];
11247 static unsigned short lowner, luic, ldefdev, ldefdir, ldefcli, lpwd;
11248 struct dsc$descriptor_s name_desc;
11249 unsigned long int sts;
11251 static struct itmlst_3 itmlst[]= {
11252 {UAI$S_OWNER+1, UAI$_OWNER, &owner, &lowner},
11253 {sizeof(uic), UAI$_UIC, &uic, &luic},
11254 {UAI$S_DEFDEV+1, UAI$_DEFDEV, &defdev, &ldefdev},
11255 {UAI$S_DEFDIR+1, UAI$_DEFDIR, &defdir, &ldefdir},
11256 {UAI$S_DEFCLI+1, UAI$_DEFCLI, &defcli, &ldefcli},
11257 {UAI$S_PWD, UAI$_PWD, pw_passwd, &lpwd},
11258 {0, 0, NULL, NULL}};
11260 name_desc.dsc$w_length= strlen(name);
11261 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11262 name_desc.dsc$b_class= DSC$K_CLASS_S;
11263 name_desc.dsc$a_pointer= (char *) name; /* read only pointer */
11265 /* Note that sys$getuai returns many fields as counted strings. */
11266 sts= sys$getuai(0, 0, &name_desc, &itmlst, 0, 0, 0);
11267 if (sts == SS$_NOSYSPRV || sts == SS$_NOGRPPRV || sts == RMS$_RNF) {
11268 set_vaxc_errno(sts); set_errno(sts == RMS$_RNF ? EINVAL : EACCES);
11270 else { _ckvmssts(sts); }
11271 if (!(sts & 1)) return 0; /* out here in case _ckvmssts() doesn't abort */
11273 if ((int) owner.length < lowner) lowner= (int) owner.length;
11274 if ((int) defdev.length < ldefdev) ldefdev= (int) defdev.length;
11275 if ((int) defdir.length < ldefdir) ldefdir= (int) defdir.length;
11276 if ((int) defcli.length < ldefcli) ldefcli= (int) defcli.length;
11277 memcpy(&defdev.pw_dir[ldefdev], &defdir.unixdir[0], ldefdir);
11278 owner.pw_gecos[lowner]= '\0';
11279 defdev.pw_dir[ldefdev+ldefdir]= '\0';
11280 defcli.pw_shell[ldefcli]= '\0';
11281 if (valid_uic(uic)) {
11282 pwd->pw_uid= uic.uic$l_uic;
11283 pwd->pw_gid= uic.uic$v_group;
11286 Perl_warn(aTHX_ "getpwnam returned invalid UIC %#o for user \"%s\"");
11287 pwd->pw_passwd= pw_passwd;
11288 pwd->pw_gecos= owner.pw_gecos;
11289 pwd->pw_dir= defdev.pw_dir;
11290 pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL);
11291 pwd->pw_shell= defcli.pw_shell;
11292 if (pwd->pw_unixdir && pwd->pw_unixdir[0]) {
11294 ldir= strlen(pwd->pw_unixdir) - 1;
11295 if (pwd->pw_unixdir[ldir]=='/') pwd->pw_unixdir[ldir]= '\0';
11298 strcpy(pwd->pw_unixdir, pwd->pw_dir);
11299 if (!decc_efs_case_preserve)
11300 __mystrtolower(pwd->pw_unixdir);
11305 * Get information for a named user.
11307 /*{{{struct passwd *getpwnam(char *name)*/
11308 struct passwd *Perl_my_getpwnam(pTHX_ const char *name)
11310 struct dsc$descriptor_s name_desc;
11312 unsigned long int status, sts;
11314 __pwdcache = __passwd_empty;
11315 if (!fillpasswd(aTHX_ name, &__pwdcache)) {
11316 /* We still may be able to determine pw_uid and pw_gid */
11317 name_desc.dsc$w_length= strlen(name);
11318 name_desc.dsc$b_dtype= DSC$K_DTYPE_T;
11319 name_desc.dsc$b_class= DSC$K_CLASS_S;
11320 name_desc.dsc$a_pointer= (char *) name;
11321 if ((sts = sys$asctoid(&name_desc, &uic, 0)) == SS$_NORMAL) {
11322 __pwdcache.pw_uid= uic.uic$l_uic;
11323 __pwdcache.pw_gid= uic.uic$v_group;
11326 if (sts == SS$_NOSUCHID || sts == SS$_IVIDENT || sts == RMS$_PRV) {
11327 set_vaxc_errno(sts);
11328 set_errno(sts == RMS$_PRV ? EACCES : EINVAL);
11331 else { _ckvmssts(sts); }
11334 strncpy(__pw_namecache, name, sizeof(__pw_namecache));
11335 __pw_namecache[sizeof __pw_namecache - 1] = '\0';
11336 __pwdcache.pw_name= __pw_namecache;
11337 return &__pwdcache;
11338 } /* end of my_getpwnam() */
11342 * Get information for a particular UIC or UID.
11343 * Called by my_getpwent with uid=-1 to list all users.
11345 /*{{{struct passwd *my_getpwuid(Uid_t uid)*/
11346 struct passwd *Perl_my_getpwuid(pTHX_ Uid_t uid)
11348 const $DESCRIPTOR(name_desc,__pw_namecache);
11349 unsigned short lname;
11351 unsigned long int status;
11353 if (uid == (unsigned int) -1) {
11355 status = sys$idtoasc(-1, &lname, &name_desc, &uic, 0, &contxt);
11356 if (status == SS$_NOSUCHID || status == RMS$_PRV) {
11357 set_vaxc_errno(status);
11358 set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11362 else { _ckvmssts(status); }
11363 } while (!valid_uic (uic));
11366 uic.uic$l_uic= uid;
11367 if (!uic.uic$v_group)
11368 uic.uic$v_group= PerlProc_getgid();
11369 if (valid_uic(uic))
11370 status = sys$idtoasc(uic.uic$l_uic, &lname, &name_desc, 0, 0, 0);
11371 else status = SS$_IVIDENT;
11372 if (status == SS$_IVIDENT || status == SS$_NOSUCHID ||
11373 status == RMS$_PRV) {
11374 set_vaxc_errno(status); set_errno(status == RMS$_PRV ? EACCES : EINVAL);
11377 else { _ckvmssts(status); }
11379 __pw_namecache[lname]= '\0';
11380 __mystrtolower(__pw_namecache);
11382 __pwdcache = __passwd_empty;
11383 __pwdcache.pw_name = __pw_namecache;
11385 /* Fill in the uid and gid in case fillpasswd can't (eg. no privilege).
11386 The identifier's value is usually the UIC, but it doesn't have to be,
11387 so if we can, we let fillpasswd update this. */
11388 __pwdcache.pw_uid = uic.uic$l_uic;
11389 __pwdcache.pw_gid = uic.uic$v_group;
11391 fillpasswd(aTHX_ __pw_namecache, &__pwdcache);
11392 return &__pwdcache;
11394 } /* end of my_getpwuid() */
11398 * Get information for next user.
11400 /*{{{struct passwd *my_getpwent()*/
11401 struct passwd *Perl_my_getpwent(pTHX)
11403 return (my_getpwuid((unsigned int) -1));
11408 * Finish searching rights database for users.
11410 /*{{{void my_endpwent()*/
11411 void Perl_my_endpwent(pTHX)
11414 _ckvmssts(sys$finish_rdb(&contxt));
11420 #ifdef HOMEGROWN_POSIX_SIGNALS
11421 /* Signal handling routines, pulled into the core from POSIX.xs.
11423 * We need these for threads, so they've been rolled into the core,
11424 * rather than left in POSIX.xs.
11426 * (DRS, Oct 23, 1997)
11429 /* sigset_t is atomic under VMS, so these routines are easy */
11430 /*{{{int my_sigemptyset(sigset_t *) */
11431 int my_sigemptyset(sigset_t *set) {
11432 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11433 *set = 0; return 0;
11438 /*{{{int my_sigfillset(sigset_t *)*/
11439 int my_sigfillset(sigset_t *set) {
11441 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11442 for (i = 0; i < NSIG; i++) *set |= (1 << i);
11448 /*{{{int my_sigaddset(sigset_t *set, int sig)*/
11449 int my_sigaddset(sigset_t *set, int sig) {
11450 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11451 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11452 *set |= (1 << (sig - 1));
11458 /*{{{int my_sigdelset(sigset_t *set, int sig)*/
11459 int my_sigdelset(sigset_t *set, int sig) {
11460 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11461 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11462 *set &= ~(1 << (sig - 1));
11468 /*{{{int my_sigismember(sigset_t *set, int sig)*/
11469 int my_sigismember(sigset_t *set, int sig) {
11470 if (!set) { SETERRNO(EFAULT,SS$_ACCVIO); return -1; }
11471 if (sig > NSIG) { SETERRNO(EINVAL,LIB$_INVARG); return -1; }
11472 return *set & (1 << (sig - 1));
11477 /*{{{int my_sigprocmask(int how, sigset_t *set, sigset_t *oset)*/
11478 int my_sigprocmask(int how, sigset_t *set, sigset_t *oset) {
11481 /* If set and oset are both null, then things are badly wrong. Bail out. */
11482 if ((oset == NULL) && (set == NULL)) {
11483 set_errno(EFAULT); set_vaxc_errno(SS$_ACCVIO);
11487 /* If set's null, then we're just handling a fetch. */
11489 tempmask = sigblock(0);
11494 tempmask = sigsetmask(*set);
11497 tempmask = sigblock(*set);
11500 tempmask = sigblock(0);
11501 sigsetmask(*oset & ~tempmask);
11504 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11509 /* Did they pass us an oset? If so, stick our holding mask into it */
11516 #endif /* HOMEGROWN_POSIX_SIGNALS */
11519 /* Used for UTC calculation in my_gmtime(), my_localtime(), my_time(),
11520 * my_utime(), and flex_stat(), all of which operate on UTC unless
11521 * VMSISH_TIMES is true.
11523 /* method used to handle UTC conversions:
11524 * 1 == CRTL gmtime(); 2 == SYS$TIMEZONE_DIFFERENTIAL; 3 == no correction
11526 static int gmtime_emulation_type;
11527 /* number of secs to add to UTC POSIX-style time to get local time */
11528 static long int utc_offset_secs;
11530 /* We #defined 'gmtime', 'localtime', and 'time' as 'my_gmtime' etc.
11531 * in vmsish.h. #undef them here so we can call the CRTL routines
11540 * DEC C previous to 6.0 corrupts the behavior of the /prefix
11541 * qualifier with the extern prefix pragma. This provisional
11542 * hack circumvents this prefix pragma problem in previous
11545 #if defined(__VMS_VER) && __VMS_VER >= 70000000
11546 # if defined(VMS_WE_ARE_CASE_SENSITIVE) && (__DECC_VER < 60000000)
11547 # pragma __extern_prefix save
11548 # pragma __extern_prefix "" /* set to empty to prevent prefixing */
11549 # define gmtime decc$__utctz_gmtime
11550 # define localtime decc$__utctz_localtime
11551 # define time decc$__utc_time
11552 # pragma __extern_prefix restore
11554 struct tm *gmtime(), *localtime();
11560 static time_t toutc_dst(time_t loc) {
11563 if ((rsltmp = localtime(&loc)) == NULL) return -1;
11564 loc -= utc_offset_secs;
11565 if (rsltmp->tm_isdst) loc -= 3600;
11568 #define _toutc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11569 ((gmtime_emulation_type || my_time(NULL)), \
11570 (gmtime_emulation_type == 1 ? toutc_dst(secs) : \
11571 ((secs) - utc_offset_secs))))
11573 static time_t toloc_dst(time_t utc) {
11576 utc += utc_offset_secs;
11577 if ((rsltmp = localtime(&utc)) == NULL) return -1;
11578 if (rsltmp->tm_isdst) utc += 3600;
11581 #define _toloc(secs) ((secs) == (time_t) -1 ? (time_t) -1 : \
11582 ((gmtime_emulation_type || my_time(NULL)), \
11583 (gmtime_emulation_type == 1 ? toloc_dst(secs) : \
11584 ((secs) + utc_offset_secs))))
11586 #ifndef RTL_USES_UTC
11589 ucx$tz = "EST5EDT4,M4.1.0,M10.5.0" typical
11590 DST starts on 1st sun of april at 02:00 std time
11591 ends on last sun of october at 02:00 dst time
11592 see the UCX management command reference, SET CONFIG TIMEZONE
11593 for formatting info.
11595 No, it's not as general as it should be, but then again, NOTHING
11596 will handle UK times in a sensible way.
11601 parse the DST start/end info:
11602 (Jddd|ddd|Mmon.nth.dow)[/hh:mm:ss]
11606 tz_parse_startend(char *s, struct tm *w, int *past)
11608 int dinm[] = {31,28,31,30,31,30,31,31,30,31,30,31};
11609 int ly, dozjd, d, m, n, hour, min, sec, j, k;
11614 if (!past) return 0;
11617 if (w->tm_year % 4 == 0) ly = 1;
11618 if (w->tm_year % 100 == 0) ly = 0;
11619 if (w->tm_year+1900 % 400 == 0) ly = 1;
11622 dozjd = isdigit(*s);
11623 if (*s == 'J' || *s == 'j' || dozjd) {
11624 if (!dozjd && !isdigit(*++s)) return 0;
11627 d = d*10 + *s++ - '0';
11629 d = d*10 + *s++ - '0';
11632 if (d == 0) return 0;
11633 if (d > 366) return 0;
11635 if (!dozjd && d > 58 && ly) d++; /* after 28 feb */
11638 } else if (*s == 'M' || *s == 'm') {
11639 if (!isdigit(*++s)) return 0;
11641 if (isdigit(*s)) m = 10*m + *s++ - '0';
11642 if (*s != '.') return 0;
11643 if (!isdigit(*++s)) return 0;
11645 if (n < 1 || n > 5) return 0;
11646 if (*s != '.') return 0;
11647 if (!isdigit(*++s)) return 0;
11649 if (d > 6) return 0;
11653 if (!isdigit(*++s)) return 0;
11655 if (isdigit(*s)) hour = 10*hour + *s++ - '0';
11657 if (!isdigit(*++s)) return 0;
11659 if (isdigit(*s)) min = 10*min + *s++ - '0';
11661 if (!isdigit(*++s)) return 0;
11663 if (isdigit(*s)) sec = 10*sec + *s++ - '0';
11673 if (w->tm_yday < d) goto before;
11674 if (w->tm_yday > d) goto after;
11676 if (w->tm_mon+1 < m) goto before;
11677 if (w->tm_mon+1 > m) goto after;
11679 j = (42 + w->tm_wday - w->tm_mday)%7; /*dow of mday 0 */
11680 k = d - j; /* mday of first d */
11681 if (k <= 0) k += 7;
11682 k += 7 * ((n>4?4:n)-1); /* mday of n'th d */
11683 if (n == 5 && k+7 <= dinm[w->tm_mon]) k += 7;
11684 if (w->tm_mday < k) goto before;
11685 if (w->tm_mday > k) goto after;
11688 if (w->tm_hour < hour) goto before;
11689 if (w->tm_hour > hour) goto after;
11690 if (w->tm_min < min) goto before;
11691 if (w->tm_min > min) goto after;
11692 if (w->tm_sec < sec) goto before;
11706 /* parse the offset: (+|-)hh[:mm[:ss]] */
11709 tz_parse_offset(char *s, int *offset)
11711 int hour = 0, min = 0, sec = 0;
11714 if (!offset) return 0;
11716 if (*s == '-') {neg++; s++;}
11717 if (*s == '+') s++;
11718 if (!isdigit(*s)) return 0;
11720 if (isdigit(*s)) hour = hour*10+(*s++ - '0');
11721 if (hour > 24) return 0;
11723 if (!isdigit(*++s)) return 0;
11725 if (isdigit(*s)) min = min*10 + (*s++ - '0');
11726 if (min > 59) return 0;
11728 if (!isdigit(*++s)) return 0;
11730 if (isdigit(*s)) sec = sec*10 + (*s++ - '0');
11731 if (sec > 59) return 0;
11735 *offset = (hour*60+min)*60 + sec;
11736 if (neg) *offset = -*offset;
11741 input time is w, whatever type of time the CRTL localtime() uses.
11742 sets dst, the zone, and the gmtoff (seconds)
11744 caches the value of TZ and UCX$TZ env variables; note that
11745 my_setenv looks for these and sets a flag if they're changed
11748 We have to watch out for the "australian" case (dst starts in
11749 october, ends in april)...flagged by "reverse" and checked by
11750 scanning through the months of the previous year.
11755 tz_parse(pTHX_ time_t *w, int *dst, char *zone, int *gmtoff)
11760 char *dstzone, *tz, *s_start, *s_end;
11761 int std_off, dst_off, isdst;
11762 int y, dststart, dstend;
11763 static char envtz[1025]; /* longer than any logical, symbol, ... */
11764 static char ucxtz[1025];
11765 static char reversed = 0;
11771 reversed = -1; /* flag need to check */
11772 envtz[0] = ucxtz[0] = '\0';
11773 tz = my_getenv("TZ",0);
11774 if (tz) strcpy(envtz, tz);
11775 tz = my_getenv("UCX$TZ",0);
11776 if (tz) strcpy(ucxtz, tz);
11777 if (!envtz[0] && !ucxtz[0]) return 0; /* we give up */
11780 if (!*tz) tz = ucxtz;
11783 while (isalpha(*s)) s++;
11784 s = tz_parse_offset(s, &std_off);
11786 if (!*s) { /* no DST, hurray we're done! */
11792 while (isalpha(*s)) s++;
11793 s2 = tz_parse_offset(s, &dst_off);
11797 dst_off = std_off - 3600;
11800 if (!*s) { /* default dst start/end?? */
11801 if (tz != ucxtz) { /* if TZ tells zone only, UCX$TZ tells rule */
11802 s = strchr(ucxtz,',');
11804 if (!s || !*s) s = ",M4.1.0,M10.5.0"; /* we know we do dst, default rule */
11806 if (*s != ',') return 0;
11809 when = _toutc(when); /* convert to utc */
11810 when = when - std_off; /* convert to pseudolocal time*/
11812 w2 = localtime(&when);
11815 s = tz_parse_startend(s_start,w2,&dststart);
11817 if (*s != ',') return 0;
11820 when = _toutc(when); /* convert to utc */
11821 when = when - dst_off; /* convert to pseudolocal time*/
11822 w2 = localtime(&when);
11823 if (w2->tm_year != y) { /* spans a year, just check one time */
11824 when += dst_off - std_off;
11825 w2 = localtime(&when);
11828 s = tz_parse_startend(s_end,w2,&dstend);
11831 if (reversed == -1) { /* need to check if start later than end */
11835 if (when < 2*365*86400) {
11836 when += 2*365*86400;
11840 w2 =localtime(&when);
11841 when = when + (15 - w2->tm_yday) * 86400; /* jan 15 */
11843 for (j = 0; j < 12; j++) {
11844 w2 =localtime(&when);
11845 tz_parse_startend(s_start,w2,&ds);
11846 tz_parse_startend(s_end,w2,&de);
11847 if (ds != de) break;
11851 if (de && !ds) reversed = 1;
11854 isdst = dststart && !dstend;
11855 if (reversed) isdst = dststart || !dstend;
11858 if (dst) *dst = isdst;
11859 if (gmtoff) *gmtoff = isdst ? dst_off : std_off;
11860 if (isdst) tz = dstzone;
11862 while(isalpha(*tz)) *zone++ = *tz++;
11868 #endif /* !RTL_USES_UTC */
11870 /* my_time(), my_localtime(), my_gmtime()
11871 * By default traffic in UTC time values, using CRTL gmtime() or
11872 * SYS$TIMEZONE_DIFFERENTIAL to determine offset from local time zone.
11873 * Note: We need to use these functions even when the CRTL has working
11874 * UTC support, since they also handle C<use vmsish qw(times);>
11876 * Contributed by Chuck Lane <lane@duphy4.physics.drexel.edu>
11877 * Modified by Charles Bailey <bailey@newman.upenn.edu>
11880 /*{{{time_t my_time(time_t *timep)*/
11881 time_t Perl_my_time(pTHX_ time_t *timep)
11886 if (gmtime_emulation_type == 0) {
11888 time_t base = 15 * 86400; /* 15jan71; to avoid month/year ends between */
11889 /* results of calls to gmtime() and localtime() */
11890 /* for same &base */
11892 gmtime_emulation_type++;
11893 if ((tm_p = gmtime(&base)) == NULL) { /* CRTL gmtime() is a fake */
11894 char off[LNM$C_NAMLENGTH+1];;
11896 gmtime_emulation_type++;
11897 if (!vmstrnenv("SYS$TIMEZONE_DIFFERENTIAL",off,0,fildev,0)) {
11898 gmtime_emulation_type++;
11899 utc_offset_secs = 0;
11900 Perl_warn(aTHX_ "no UTC offset information; assuming local time is UTC");
11902 else { utc_offset_secs = atol(off); }
11904 else { /* We've got a working gmtime() */
11905 struct tm gmt, local;
11908 tm_p = localtime(&base);
11910 utc_offset_secs = (local.tm_mday - gmt.tm_mday) * 86400;
11911 utc_offset_secs += (local.tm_hour - gmt.tm_hour) * 3600;
11912 utc_offset_secs += (local.tm_min - gmt.tm_min) * 60;
11913 utc_offset_secs += (local.tm_sec - gmt.tm_sec);
11918 # ifdef VMSISH_TIME
11919 # ifdef RTL_USES_UTC
11920 if (VMSISH_TIME) when = _toloc(when);
11922 if (!VMSISH_TIME) when = _toutc(when);
11925 if (timep != NULL) *timep = when;
11928 } /* end of my_time() */
11932 /*{{{struct tm *my_gmtime(const time_t *timep)*/
11934 Perl_my_gmtime(pTHX_ const time_t *timep)
11940 if (timep == NULL) {
11941 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11944 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11947 # ifdef VMSISH_TIME
11948 if (VMSISH_TIME) when = _toutc(when); /* Input was local time */
11950 # ifdef RTL_USES_UTC /* this implies that the CRTL has a working gmtime() */
11951 return gmtime(&when);
11953 /* CRTL localtime() wants local time as input, so does no tz correction */
11954 rsltmp = localtime(&when);
11955 if (rsltmp) rsltmp->tm_isdst = 0; /* We already took DST into account */
11958 } /* end of my_gmtime() */
11962 /*{{{struct tm *my_localtime(const time_t *timep)*/
11964 Perl_my_localtime(pTHX_ const time_t *timep)
11966 time_t when, whenutc;
11970 if (timep == NULL) {
11971 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
11974 if (*timep == 0) gmtime_emulation_type = 0; /* possibly reset TZ */
11975 if (gmtime_emulation_type == 0) my_time(NULL); /* Init UTC */
11978 # ifdef RTL_USES_UTC
11979 # ifdef VMSISH_TIME
11980 if (VMSISH_TIME) when = _toutc(when);
11982 /* CRTL localtime() wants UTC as input, does tz correction itself */
11983 return localtime(&when);
11985 # else /* !RTL_USES_UTC */
11987 # ifdef VMSISH_TIME
11988 if (!VMSISH_TIME) when = _toloc(whenutc); /* input was UTC */
11989 if (VMSISH_TIME) whenutc = _toutc(when); /* input was truelocal */
11992 #ifndef RTL_USES_UTC
11993 if (tz_parse(aTHX_ &when, &dst, 0, &offset)) { /* truelocal determines DST*/
11994 when = whenutc - offset; /* pseudolocal time*/
11997 /* CRTL localtime() wants local time as input, so does no tz correction */
11998 rsltmp = localtime(&when);
11999 if (rsltmp && gmtime_emulation_type != 1) rsltmp->tm_isdst = dst;
12003 } /* end of my_localtime() */
12006 /* Reset definitions for later calls */
12007 #define gmtime(t) my_gmtime(t)
12008 #define localtime(t) my_localtime(t)
12009 #define time(t) my_time(t)
12012 /* my_utime - update modification/access time of a file
12014 * VMS 7.3 and later implementation
12015 * Only the UTC translation is home-grown. The rest is handled by the
12016 * CRTL utime(), which will take into account the relevant feature
12017 * logicals and ODS-5 volume characteristics for true access times.
12019 * pre VMS 7.3 implementation:
12020 * The calling sequence is identical to POSIX utime(), but under
12021 * VMS with ODS-2, only the modification time is changed; ODS-2 does
12022 * not maintain access times. Restrictions differ from the POSIX
12023 * definition in that the time can be changed as long as the
12024 * caller has permission to execute the necessary IO$_MODIFY $QIO;
12025 * no separate checks are made to insure that the caller is the
12026 * owner of the file or has special privs enabled.
12027 * Code here is based on Joe Meadows' FILE utility.
12031 /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00)
12032 * to VMS epoch (01-JAN-1858 00:00:00.00)
12033 * in 100 ns intervals.
12035 static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 };
12037 /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/
12038 int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes)
12040 #if __CRTL_VER >= 70300000
12041 struct utimbuf utc_utimes, *utc_utimesp;
12043 if (utimes != NULL) {
12044 utc_utimes.actime = utimes->actime;
12045 utc_utimes.modtime = utimes->modtime;
12046 # ifdef VMSISH_TIME
12047 /* If input was local; convert to UTC for sys svc */
12049 utc_utimes.actime = _toutc(utimes->actime);
12050 utc_utimes.modtime = _toutc(utimes->modtime);
12053 utc_utimesp = &utc_utimes;
12056 utc_utimesp = NULL;
12059 return utime(file, utc_utimesp);
12061 #else /* __CRTL_VER < 70300000 */
12065 long int bintime[2], len = 2, lowbit, unixtime,
12066 secscale = 10000000; /* seconds --> 100 ns intervals */
12067 unsigned long int chan, iosb[2], retsts;
12068 char vmsspec[NAM$C_MAXRSS+1], rsa[NAM$C_MAXRSS], esa[NAM$C_MAXRSS];
12069 struct FAB myfab = cc$rms_fab;
12070 struct NAM mynam = cc$rms_nam;
12071 #if defined (__DECC) && defined (__VAX)
12072 /* VAX DEC C atrdef.h has unsigned type for pointer member atr$l_addr,
12073 * at least through VMS V6.1, which causes a type-conversion warning.
12075 # pragma message save
12076 # pragma message disable cvtdiftypes
12078 struct atrdef myatr[2] = {{sizeof bintime, ATR$C_REVDATE, bintime}, {0,0,0}};
12079 struct fibdef myfib;
12080 #if defined (__DECC) && defined (__VAX)
12081 /* This should be right after the declaration of myatr, but due
12082 * to a bug in VAX DEC C, this takes effect a statement early.
12084 # pragma message restore
12086 /* cast ok for read only parameter */
12087 struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib},
12088 devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0},
12089 fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0};
12091 if (file == NULL || *file == '\0') {
12092 SETERRNO(ENOENT, LIB$_INVARG);
12096 /* Convert to VMS format ensuring that it will fit in 255 characters */
12097 if (int_rmsexpand_tovms(file, vmsspec, 0) == NULL) {
12098 SETERRNO(ENOENT, LIB$_INVARG);
12101 if (utimes != NULL) {
12102 /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00)
12103 * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00).
12104 * Since time_t is unsigned long int, and lib$emul takes a signed long int
12105 * as input, we force the sign bit to be clear by shifting unixtime right
12106 * one bit, then multiplying by an extra factor of 2 in lib$emul().
12108 lowbit = (utimes->modtime & 1) ? secscale : 0;
12109 unixtime = (long int) utimes->modtime;
12110 # ifdef VMSISH_TIME
12111 /* If input was UTC; convert to local for sys svc */
12112 if (!VMSISH_TIME) unixtime = _toloc(unixtime);
12114 unixtime >>= 1; secscale <<= 1;
12115 retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime);
12116 if (!(retsts & 1)) {
12117 SETERRNO(EVMSERR, retsts);
12120 retsts = lib$addx(bintime,utime_baseadjust,bintime,&len);
12121 if (!(retsts & 1)) {
12122 SETERRNO(EVMSERR, retsts);
12127 /* Just get the current time in VMS format directly */
12128 retsts = sys$gettim(bintime);
12129 if (!(retsts & 1)) {
12130 SETERRNO(EVMSERR, retsts);
12135 myfab.fab$l_fna = vmsspec;
12136 myfab.fab$b_fns = (unsigned char) strlen(vmsspec);
12137 myfab.fab$l_nam = &mynam;
12138 mynam.nam$l_esa = esa;
12139 mynam.nam$b_ess = (unsigned char) sizeof esa;
12140 mynam.nam$l_rsa = rsa;
12141 mynam.nam$b_rss = (unsigned char) sizeof rsa;
12142 if (decc_efs_case_preserve)
12143 mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE;
12145 /* Look for the file to be affected, letting RMS parse the file
12146 * specification for us as well. I have set errno using only
12147 * values documented in the utime() man page for VMS POSIX.
12149 retsts = sys$parse(&myfab,0,0);
12150 if (!(retsts & 1)) {
12151 set_vaxc_errno(retsts);
12152 if (retsts == RMS$_PRV) set_errno(EACCES);
12153 else if (retsts == RMS$_DIR) set_errno(ENOTDIR);
12154 else set_errno(EVMSERR);
12157 retsts = sys$search(&myfab,0,0);
12158 if (!(retsts & 1)) {
12159 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12160 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12161 set_vaxc_errno(retsts);
12162 if (retsts == RMS$_PRV) set_errno(EACCES);
12163 else if (retsts == RMS$_FNF) set_errno(ENOENT);
12164 else set_errno(EVMSERR);
12168 devdsc.dsc$w_length = mynam.nam$b_dev;
12169 /* cast ok for read only parameter */
12170 devdsc.dsc$a_pointer = (char *) mynam.nam$l_dev;
12172 retsts = sys$assign(&devdsc,&chan,0,0);
12173 if (!(retsts & 1)) {
12174 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12175 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12176 set_vaxc_errno(retsts);
12177 if (retsts == SS$_IVDEVNAM) set_errno(ENOTDIR);
12178 else if (retsts == SS$_NOPRIV) set_errno(EACCES);
12179 else if (retsts == SS$_NOSUCHDEV) set_errno(ENOTDIR);
12180 else set_errno(EVMSERR);
12184 fnmdsc.dsc$a_pointer = mynam.nam$l_name;
12185 fnmdsc.dsc$w_length = mynam.nam$b_name + mynam.nam$b_type + mynam.nam$b_ver;
12187 memset((void *) &myfib, 0, sizeof myfib);
12188 #if defined(__DECC) || defined(__DECCXX)
12189 for (i=0;i<3;i++) myfib.fib$w_fid[i] = mynam.nam$w_fid[i];
12190 for (i=0;i<3;i++) myfib.fib$w_did[i] = mynam.nam$w_did[i];
12191 /* This prevents the revision time of the file being reset to the current
12192 * time as a result of our IO$_MODIFY $QIO. */
12193 myfib.fib$l_acctl = FIB$M_NORECORD;
12195 for (i=0;i<3;i++) myfib.fib$r_fid_overlay.fib$w_fid[i] = mynam.nam$w_fid[i];
12196 for (i=0;i<3;i++) myfib.fib$r_did_overlay.fib$w_did[i] = mynam.nam$w_did[i];
12197 myfib.fib$r_acctl_overlay.fib$l_acctl = FIB$M_NORECORD;
12199 retsts = sys$qiow(0,chan,IO$_MODIFY,iosb,0,0,&fibdsc,&fnmdsc,0,0,myatr,0);
12200 mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL;
12201 myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0);
12202 _ckvmssts(sys$dassgn(chan));
12203 if (retsts & 1) retsts = iosb[0];
12204 if (!(retsts & 1)) {
12205 set_vaxc_errno(retsts);
12206 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12207 else set_errno(EVMSERR);
12213 #endif /* #if __CRTL_VER >= 70300000 */
12215 } /* end of my_utime() */
12219 * flex_stat, flex_lstat, flex_fstat
12220 * basic stat, but gets it right when asked to stat
12221 * a Unix-style path ending in a directory name (e.g. dir1/dir2/dir3)
12224 #ifndef _USE_STD_STAT
12225 /* encode_dev packs a VMS device name string into an integer to allow
12226 * simple comparisons. This can be used, for example, to check whether two
12227 * files are located on the same device, by comparing their encoded device
12228 * names. Even a string comparison would not do, because stat() reuses the
12229 * device name buffer for each call; so without encode_dev, it would be
12230 * necessary to save the buffer and use strcmp (this would mean a number of
12231 * changes to the standard Perl code, to say nothing of what a Perl script
12232 * would have to do.
12234 * The device lock id, if it exists, should be unique (unless perhaps compared
12235 * with lock ids transferred from other nodes). We have a lock id if the disk is
12236 * mounted cluster-wide, which is when we tend to get long (host-qualified)
12237 * device names. Thus we use the lock id in preference, and only if that isn't
12238 * available, do we try to pack the device name into an integer (flagged by
12239 * the sign bit (LOCKID_MASK) being set).
12241 * Note that encode_dev cannot guarantee an 1-to-1 correspondence twixt device
12242 * name and its encoded form, but it seems very unlikely that we will find
12243 * two files on different disks that share the same encoded device names,
12244 * and even more remote that they will share the same file id (if the test
12245 * is to check for the same file).
12247 * A better method might be to use sys$device_scan on the first call, and to
12248 * search for the device, returning an index into the cached array.
12249 * The number returned would be more intelligible.
12250 * This is probably not worth it, and anyway would take quite a bit longer
12251 * on the first call.
12253 #define LOCKID_MASK 0x80000000 /* Use 0 to force device name use only */
12254 static mydev_t encode_dev (pTHX_ const char *dev)
12257 unsigned long int f;
12262 if (!dev || !dev[0]) return 0;
12266 struct dsc$descriptor_s dev_desc;
12267 unsigned long int status, lockid = 0, item = DVI$_LOCKID;
12269 /* For cluster-mounted disks, the disk lock identifier is unique, so we
12270 can try that first. */
12271 dev_desc.dsc$w_length = strlen (dev);
12272 dev_desc.dsc$b_dtype = DSC$K_DTYPE_T;
12273 dev_desc.dsc$b_class = DSC$K_CLASS_S;
12274 dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */
12275 status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0);
12276 if (!$VMS_STATUS_SUCCESS(status)) {
12278 case SS$_NOSUCHDEV:
12279 SETERRNO(ENODEV, status);
12285 if (lockid) return (lockid & ~LOCKID_MASK);
12289 /* Otherwise we try to encode the device name */
12293 for (q = dev + strlen(dev); q--; q >= dev) {
12298 else if (isalpha (toupper (*q)))
12299 c= toupper (*q) - 'A' + (char)10;
12301 continue; /* Skip '$'s */
12303 if (i>6) break; /* 36^7 is too large to fit in an unsigned long int */
12305 enc += f * (unsigned long int) c;
12307 return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */
12309 } /* end of encode_dev() */
12310 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12311 device_no = encode_dev(aTHX_ devname)
12313 #define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \
12314 device_no = new_dev_no
12318 is_null_device(name)
12321 if (decc_bug_devnull != 0) {
12322 if (strncmp("/dev/null", name, 9) == 0)
12325 /* The VMS null device is named "_NLA0:", usually abbreviated as "NL:".
12326 The underscore prefix, controller letter, and unit number are
12327 independently optional; for our purposes, the colon punctuation
12328 is not. The colon can be trailed by optional directory and/or
12329 filename, but two consecutive colons indicates a nodename rather
12330 than a device. [pr] */
12331 if (*name == '_') ++name;
12332 if (tolower(*name++) != 'n') return 0;
12333 if (tolower(*name++) != 'l') return 0;
12334 if (tolower(*name) == 'a') ++name;
12335 if (*name == '0') ++name;
12336 return (*name++ == ':') && (*name != ':');
12341 Perl_cando_by_name_int
12342 (pTHX_ I32 bit, bool effective, const char *fname, int opts)
12344 char usrname[L_cuserid];
12345 struct dsc$descriptor_s usrdsc =
12346 {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname};
12347 char *vmsname = NULL, *fileified = NULL;
12348 unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags;
12349 unsigned short int retlen, trnlnm_iter_count;
12350 struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12351 union prvdef curprv;
12352 struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen},
12353 {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},
12354 {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}};
12355 struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen},
12356 {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length},
12358 struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen},
12360 struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
12362 static int profile_context = -1;
12364 if (!fname || !*fname) return FALSE;
12366 /* Make sure we expand logical names, since sys$check_access doesn't */
12367 fileified = PerlMem_malloc(VMS_MAXRSS);
12368 if (fileified == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12369 if (!strpbrk(fname,"/]>:")) {
12370 strcpy(fileified,fname);
12371 trnlnm_iter_count = 0;
12372 while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) {
12373 trnlnm_iter_count++;
12374 if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break;
12379 vmsname = PerlMem_malloc(VMS_MAXRSS);
12380 if (vmsname == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12381 if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) {
12382 /* Don't know if already in VMS format, so make sure */
12383 if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) {
12384 PerlMem_free(fileified);
12385 PerlMem_free(vmsname);
12390 strcpy(vmsname,fname);
12393 /* sys$check_access needs a file spec, not a directory spec.
12394 * Don't use flex_stat here, as that depends on thread context
12395 * having been initialized, and we may get here during startup.
12398 retlen = namdsc.dsc$w_length = strlen(vmsname);
12399 if (vmsname[retlen-1] == ']'
12400 || vmsname[retlen-1] == '>'
12401 || vmsname[retlen-1] == ':'
12402 || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) {
12404 if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) {
12405 PerlMem_free(fileified);
12406 PerlMem_free(vmsname);
12415 retlen = namdsc.dsc$w_length = strlen(fname);
12416 namdsc.dsc$a_pointer = (char *)fname;
12419 case S_IXUSR: case S_IXGRP: case S_IXOTH:
12420 access = ARM$M_EXECUTE;
12421 flags = CHP$M_READ;
12423 case S_IRUSR: case S_IRGRP: case S_IROTH:
12424 access = ARM$M_READ;
12425 flags = CHP$M_READ | CHP$M_USEREADALL;
12427 case S_IWUSR: case S_IWGRP: case S_IWOTH:
12428 access = ARM$M_WRITE;
12429 flags = CHP$M_READ | CHP$M_WRITE;
12431 case S_IDUSR: case S_IDGRP: case S_IDOTH:
12432 access = ARM$M_DELETE;
12433 flags = CHP$M_READ | CHP$M_WRITE;
12436 if (fileified != NULL)
12437 PerlMem_free(fileified);
12438 if (vmsname != NULL)
12439 PerlMem_free(vmsname);
12443 /* Before we call $check_access, create a user profile with the current
12444 * process privs since otherwise it just uses the default privs from the
12445 * UAF and might give false positives or negatives. This only works on
12446 * VMS versions v6.0 and later since that's when sys$create_user_profile
12447 * became available.
12450 /* get current process privs and username */
12451 _ckvmssts_noperl(sys$getjpiw(0,0,0,jpilst,iosb,0,0));
12452 _ckvmssts_noperl(iosb[0]);
12454 #if defined(__VMS_VER) && __VMS_VER >= 60000000
12456 /* find out the space required for the profile */
12457 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,0,
12458 &usrprodsc.dsc$w_length,&profile_context));
12460 /* allocate space for the profile and get it filled in */
12461 usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length);
12462 if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12463 _ckvmssts_noperl(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer,
12464 &usrprodsc.dsc$w_length,&profile_context));
12466 /* use the profile to check access to the file; free profile & analyze results */
12467 retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc);
12468 PerlMem_free(usrprodsc.dsc$a_pointer);
12469 if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */
12473 retsts = sys$check_access(&objtyp,&namdsc,&usrdsc,armlst);
12477 if (retsts == SS$_NOPRIV || retsts == SS$_NOSUCHOBJECT ||
12478 retsts == SS$_INVFILFOROP || retsts == RMS$_FNF || retsts == RMS$_SYN ||
12479 retsts == RMS$_DIR || retsts == RMS$_DEV || retsts == RMS$_DNF) {
12480 set_vaxc_errno(retsts);
12481 if (retsts == SS$_NOPRIV) set_errno(EACCES);
12482 else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL);
12483 else set_errno(ENOENT);
12484 if (fileified != NULL)
12485 PerlMem_free(fileified);
12486 if (vmsname != NULL)
12487 PerlMem_free(vmsname);
12490 if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) {
12491 if (fileified != NULL)
12492 PerlMem_free(fileified);
12493 if (vmsname != NULL)
12494 PerlMem_free(vmsname);
12497 _ckvmssts_noperl(retsts);
12499 if (fileified != NULL)
12500 PerlMem_free(fileified);
12501 if (vmsname != NULL)
12502 PerlMem_free(vmsname);
12503 return FALSE; /* Should never get here */
12507 /* Do the permissions allow some operation? Assumes PL_statcache already set. */
12508 /* Do this via $Check_Access on VMS, since the CRTL stat() returns only a
12509 * subset of the applicable information.
12512 Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp)
12514 return cando_by_name_int
12515 (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN);
12516 } /* end of cando() */
12520 /*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/
12522 Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname)
12524 return cando_by_name_int(bit, effective, fname, 0);
12526 } /* end of cando_by_name() */
12530 /*{{{ int flex_fstat(int fd, Stat_t *statbuf)*/
12532 Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp)
12534 if (!fstat(fd,(stat_t *) statbufp)) {
12536 char *vms_filename;
12537 vms_filename = PerlMem_malloc(VMS_MAXRSS);
12538 if (vms_filename == NULL) _ckvmssts(SS$_INSFMEM);
12540 /* Save name for cando by name in VMS format */
12541 cptr = getname(fd, vms_filename, 1);
12543 /* This should not happen, but just in case */
12544 if (cptr == NULL) {
12545 statbufp->st_devnam[0] = 0;
12548 /* Make sure that the saved name fits in 255 characters */
12549 cptr = int_rmsexpand_vms
12551 statbufp->st_devnam,
12554 statbufp->st_devnam[0] = 0;
12556 PerlMem_free(vms_filename);
12558 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12560 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12562 # ifdef RTL_USES_UTC
12563 # ifdef VMSISH_TIME
12565 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12566 statbufp->st_atime = _toloc(statbufp->st_atime);
12567 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12571 # ifdef VMSISH_TIME
12572 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12576 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12577 statbufp->st_atime = _toutc(statbufp->st_atime);
12578 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12585 } /* end of flex_fstat() */
12588 #if !defined(__VAX) && __CRTL_VER >= 80200000
12596 #define lstat(_x, _y) stat(_x, _y)
12599 #define flex_stat_int(a,b,c) Perl_flex_stat_int(aTHX_ a,b,c)
12602 Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag)
12604 char fileified[VMS_MAXRSS];
12605 char temp_fspec[VMS_MAXRSS];
12610 if (!fspec) return retval;
12612 strcpy(temp_fspec, fspec);
12614 if (decc_bug_devnull != 0) {
12615 if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */
12616 memset(statbufp,0,sizeof *statbufp);
12617 VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0);
12618 statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC;
12619 statbufp->st_uid = 0x00010001;
12620 statbufp->st_gid = 0x0001;
12621 time((time_t *)&statbufp->st_mtime);
12622 statbufp->st_atime = statbufp->st_ctime = statbufp->st_mtime;
12627 /* Try for a directory name first. If fspec contains a filename without
12628 * a type (e.g. sea:[wine.dark]water), and both sea:[wine.dark]water.dir
12629 * and sea:[wine.dark]water. exist, we prefer the directory here.
12630 * Similarly, sea:[wine.dark] returns the result for sea:[wine]dark.dir,
12631 * not sea:[wine.dark]., if the latter exists. If the intended target is
12632 * the file with null type, specify this by calling flex_stat() with
12633 * a '.' at the end of fspec.
12635 * If we are in Posix filespec mode, accept the filename as is.
12639 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12640 /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless
12641 * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already.
12643 if (!decc_efs_charset)
12644 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1);
12647 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12648 if (decc_posix_compliant_pathnames == 0) {
12650 if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) {
12651 if (lstat_flag == 0)
12652 retval = stat(fileified,(stat_t *) statbufp);
12654 retval = lstat(fileified,(stat_t *) statbufp);
12655 save_spec = fileified;
12658 if (lstat_flag == 0)
12659 retval = stat(temp_fspec,(stat_t *) statbufp);
12661 retval = lstat(temp_fspec,(stat_t *) statbufp);
12662 save_spec = temp_fspec;
12665 * In debugging, on 8.3 Alpha, I found a case where stat was returning a
12666 * file not found error for a directory named foo:[bar.t] or /foo/bar/t
12667 * and lstat was working correctly for the same file.
12668 * The only syntax that was working for stat was "foo:[bar]t.dir".
12670 * Other directories with the same syntax worked fine.
12671 * So work around the problem when it shows up here.
12674 int save_errno = errno;
12675 if (do_tovmsspec(fspec, temp_fspec, 0, NULL) != NULL) {
12676 if (do_fileify_dirspec(temp_fspec, fileified, 0, NULL) != NULL) {
12677 retval = stat(fileified, (stat_t *) statbufp);
12678 save_spec = fileified;
12681 /* Restore the errno value if third stat does not succeed */
12683 errno = save_errno;
12685 #if __CRTL_VER >= 80200000 && !defined(__VAX)
12687 if (lstat_flag == 0)
12688 retval = stat(temp_fspec,(stat_t *) statbufp);
12690 retval = lstat(temp_fspec,(stat_t *) statbufp);
12691 save_spec = temp_fspec;
12695 #if __CRTL_VER >= 70300000 && !defined(__VAX)
12696 /* As you were... */
12697 if (!decc_efs_charset)
12698 decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0);
12703 int rmsex_flags = PERL_RMSEXPAND_M_VMS;
12705 /* If this is an lstat, do not follow the link */
12707 rmsex_flags |= PERL_RMSEXPAND_M_SYMLINK;
12709 cptr = int_rmsexpand_tovms(save_spec, statbufp->st_devnam, rmsex_flags);
12711 statbufp->st_devnam[0] = 0;
12713 VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino);
12715 (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev);
12716 # ifdef RTL_USES_UTC
12717 # ifdef VMSISH_TIME
12719 statbufp->st_mtime = _toloc(statbufp->st_mtime);
12720 statbufp->st_atime = _toloc(statbufp->st_atime);
12721 statbufp->st_ctime = _toloc(statbufp->st_ctime);
12725 # ifdef VMSISH_TIME
12726 if (!VMSISH_TIME) { /* Return UTC instead of local time */
12730 statbufp->st_mtime = _toutc(statbufp->st_mtime);
12731 statbufp->st_atime = _toutc(statbufp->st_atime);
12732 statbufp->st_ctime = _toutc(statbufp->st_ctime);
12736 /* If we were successful, leave errno where we found it */
12737 if (retval == 0) RESTORE_ERRNO;
12740 } /* end of flex_stat_int() */
12743 /*{{{ int flex_stat(const char *fspec, Stat_t *statbufp)*/
12745 Perl_flex_stat(pTHX_ const char *fspec, Stat_t *statbufp)
12747 return flex_stat_int(fspec, statbufp, 0);
12751 /*{{{ int flex_lstat(const char *fspec, Stat_t *statbufp)*/
12753 Perl_flex_lstat(pTHX_ const char *fspec, Stat_t *statbufp)
12755 return flex_stat_int(fspec, statbufp, 1);
12760 /*{{{char *my_getlogin()*/
12761 /* VMS cuserid == Unix getlogin, except calling sequence */
12765 static char user[L_cuserid];
12766 return cuserid(user);
12771 /* rmscopy - copy a file using VMS RMS routines
12773 * Copies contents and attributes of spec_in to spec_out, except owner
12774 * and protection information. Name and type of spec_in are used as
12775 * defaults for spec_out. The third parameter specifies whether rmscopy()
12776 * should try to propagate timestamps from the input file to the output file.
12777 * If it is less than 0, no timestamps are preserved. If it is 0, then
12778 * rmscopy() will behave similarly to the DCL COPY command: timestamps are
12779 * propagated to the output file at creation iff the output file specification
12780 * did not contain an explicit name or type, and the revision date is always
12781 * updated at the end of the copy operation. If it is greater than 0, then
12782 * it is interpreted as a bitmask, in which bit 0 indicates that timestamps
12783 * other than the revision date should be propagated, and bit 1 indicates
12784 * that the revision date should be propagated.
12786 * Returns 1 on success; returns 0 and sets errno and vaxc$errno on failure.
12788 * Copyright 1996 by Charles Bailey <bailey@newman.upenn.edu>.
12789 * Incorporates, with permission, some code from EZCOPY by Tim Adye
12790 * <T.J.Adye@rl.ac.uk>. Permission is given to distribute this code
12791 * as part of the Perl standard distribution under the terms of the
12792 * GNU General Public License or the Perl Artistic License. Copies
12793 * of each may be found in the Perl standard distribution.
12795 /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/
12797 Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates)
12799 char *vmsin, * vmsout, *esa, *esal, *esa_out, *esal_out,
12800 *rsa, *rsal, *rsa_out, *rsal_out, *ubf;
12801 unsigned long int i, sts, sts2;
12803 struct FAB fab_in, fab_out;
12804 struct RAB rab_in, rab_out;
12805 rms_setup_nam(nam);
12806 rms_setup_nam(nam_out);
12807 struct XABDAT xabdat;
12808 struct XABFHC xabfhc;
12809 struct XABRDT xabrdt;
12810 struct XABSUM xabsum;
12812 vmsin = PerlMem_malloc(VMS_MAXRSS);
12813 if (vmsin == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12814 vmsout = PerlMem_malloc(VMS_MAXRSS);
12815 if (vmsout == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12816 if (!spec_in || !*spec_in || !int_tovmsspec(spec_in, vmsin, 1, NULL) ||
12817 !spec_out || !*spec_out || !int_tovmsspec(spec_out, vmsout, 1, NULL)) {
12818 PerlMem_free(vmsin);
12819 PerlMem_free(vmsout);
12820 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
12824 esa = PerlMem_malloc(VMS_MAXRSS);
12825 if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12827 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12828 esal = PerlMem_malloc(VMS_MAXRSS);
12829 if (esal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12831 fab_in = cc$rms_fab;
12832 rms_set_fna(fab_in, nam, vmsin, strlen(vmsin));
12833 fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI;
12834 fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET;
12835 fab_in.fab$l_fop = FAB$M_SQO;
12836 rms_bind_fab_nam(fab_in, nam);
12837 fab_in.fab$l_xab = (void *) &xabdat;
12839 rsa = PerlMem_malloc(VMS_MAXRSS);
12840 if (rsa == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12842 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12843 rsal = PerlMem_malloc(VMS_MAXRSS);
12844 if (rsal == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12846 rms_set_rsal(nam, rsa, NAM$C_MAXRSS, rsal, (VMS_MAXRSS - 1));
12847 rms_set_esal(nam, esa, NAM$C_MAXRSS, esal, (VMS_MAXRSS - 1));
12848 rms_nam_esl(nam) = 0;
12849 rms_nam_rsl(nam) = 0;
12850 rms_nam_esll(nam) = 0;
12851 rms_nam_rsll(nam) = 0;
12852 #ifdef NAM$M_NO_SHORT_UPCASE
12853 if (decc_efs_case_preserve)
12854 rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE);
12857 xabdat = cc$rms_xabdat; /* To get creation date */
12858 xabdat.xab$l_nxt = (void *) &xabfhc;
12860 xabfhc = cc$rms_xabfhc; /* To get record length */
12861 xabfhc.xab$l_nxt = (void *) &xabsum;
12863 xabsum = cc$rms_xabsum; /* To get key and area information */
12865 if (!((sts = sys$open(&fab_in)) & 1)) {
12866 PerlMem_free(vmsin);
12867 PerlMem_free(vmsout);
12870 PerlMem_free(esal);
12873 PerlMem_free(rsal);
12874 set_vaxc_errno(sts);
12876 case RMS$_FNF: case RMS$_DNF:
12877 set_errno(ENOENT); break;
12879 set_errno(ENOTDIR); break;
12881 set_errno(ENODEV); break;
12883 set_errno(EINVAL); break;
12885 set_errno(EACCES); break;
12887 set_errno(EVMSERR);
12894 fab_out.fab$w_ifi = 0;
12895 fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT;
12896 fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI;
12897 fab_out.fab$l_fop = FAB$M_SQO;
12898 rms_bind_fab_nam(fab_out, nam_out);
12899 rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout));
12900 dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0;
12901 rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len);
12902 esa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12903 if (esa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12904 rsa_out = PerlMem_malloc(NAM$C_MAXRSS + 1);
12905 if (rsa_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12908 #if !defined(__VAX) && defined(NAML$C_MAXRSS)
12909 esal_out = PerlMem_malloc(VMS_MAXRSS);
12910 if (esal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12911 rsal_out = PerlMem_malloc(VMS_MAXRSS);
12912 if (rsal_out == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12914 rms_set_rsal(nam_out, rsa_out, NAM$C_MAXRSS, rsal_out, (VMS_MAXRSS - 1));
12915 rms_set_esal(nam_out, esa_out, NAM$C_MAXRSS, esal_out, (VMS_MAXRSS - 1));
12917 if (preserve_dates == 0) { /* Act like DCL COPY */
12918 rms_set_nam_nop(nam_out, NAM$M_SYNCHK);
12919 fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */
12920 if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) {
12921 PerlMem_free(vmsin);
12922 PerlMem_free(vmsout);
12925 PerlMem_free(esal);
12928 PerlMem_free(rsal);
12929 PerlMem_free(esa_out);
12930 if (esal_out != NULL)
12931 PerlMem_free(esal_out);
12932 PerlMem_free(rsa_out);
12933 if (rsal_out != NULL)
12934 PerlMem_free(rsal_out);
12935 set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR);
12936 set_vaxc_errno(sts);
12939 fab_out.fab$l_xab = (void *) &xabdat;
12940 if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE))
12941 preserve_dates = 1;
12943 if (preserve_dates < 0) /* Clear all bits; we'll use it as a */
12944 preserve_dates =0; /* bitmask from this point forward */
12946 if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc;
12947 if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) {
12948 PerlMem_free(vmsin);
12949 PerlMem_free(vmsout);
12952 PerlMem_free(esal);
12955 PerlMem_free(rsal);
12956 PerlMem_free(esa_out);
12957 if (esal_out != NULL)
12958 PerlMem_free(esal_out);
12959 PerlMem_free(rsa_out);
12960 if (rsal_out != NULL)
12961 PerlMem_free(rsal_out);
12962 set_vaxc_errno(sts);
12965 set_errno(ENOENT); break;
12967 set_errno(ENOTDIR); break;
12969 set_errno(ENODEV); break;
12971 set_errno(EINVAL); break;
12973 set_errno(EACCES); break;
12975 set_errno(EVMSERR);
12979 fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */
12980 if (preserve_dates & 2) {
12981 /* sys$close() will process xabrdt, not xabdat */
12982 xabrdt = cc$rms_xabrdt;
12984 xabrdt.xab$q_rdt = xabdat.xab$q_rdt;
12986 /* gcc doesn't like the assignment, since its prototype for xab$q_rdt
12987 * is unsigned long[2], while DECC & VAXC use a struct */
12988 memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt);
12990 fab_out.fab$l_xab = (void *) &xabrdt;
12993 ubf = PerlMem_malloc(32256);
12994 if (ubf == NULL) _ckvmssts_noperl(SS$_INSFMEM);
12995 rab_in = cc$rms_rab;
12996 rab_in.rab$l_fab = &fab_in;
12997 rab_in.rab$l_rop = RAB$M_BIO;
12998 rab_in.rab$l_ubf = ubf;
12999 rab_in.rab$w_usz = 32256;
13000 if (!((sts = sys$connect(&rab_in)) & 1)) {
13001 sys$close(&fab_in); sys$close(&fab_out);
13002 PerlMem_free(vmsin);
13003 PerlMem_free(vmsout);
13007 PerlMem_free(esal);
13010 PerlMem_free(rsal);
13011 PerlMem_free(esa_out);
13012 if (esal_out != NULL)
13013 PerlMem_free(esal_out);
13014 PerlMem_free(rsa_out);
13015 if (rsal_out != NULL)
13016 PerlMem_free(rsal_out);
13017 set_errno(EVMSERR); set_vaxc_errno(sts);
13021 rab_out = cc$rms_rab;
13022 rab_out.rab$l_fab = &fab_out;
13023 rab_out.rab$l_rbf = ubf;
13024 if (!((sts = sys$connect(&rab_out)) & 1)) {
13025 sys$close(&fab_in); sys$close(&fab_out);
13026 PerlMem_free(vmsin);
13027 PerlMem_free(vmsout);
13031 PerlMem_free(esal);
13034 PerlMem_free(rsal);
13035 PerlMem_free(esa_out);
13036 if (esal_out != NULL)
13037 PerlMem_free(esal_out);
13038 PerlMem_free(rsa_out);
13039 if (rsal_out != NULL)
13040 PerlMem_free(rsal_out);
13041 set_errno(EVMSERR); set_vaxc_errno(sts);
13045 while ((sts = sys$read(&rab_in))) { /* always true */
13046 if (sts == RMS$_EOF) break;
13047 rab_out.rab$w_rsz = rab_in.rab$w_rsz;
13048 if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) {
13049 sys$close(&fab_in); sys$close(&fab_out);
13050 PerlMem_free(vmsin);
13051 PerlMem_free(vmsout);
13055 PerlMem_free(esal);
13058 PerlMem_free(rsal);
13059 PerlMem_free(esa_out);
13060 if (esal_out != NULL)
13061 PerlMem_free(esal_out);
13062 PerlMem_free(rsa_out);
13063 if (rsal_out != NULL)
13064 PerlMem_free(rsal_out);
13065 set_errno(EVMSERR); set_vaxc_errno(sts);
13071 fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */
13072 sys$close(&fab_in); sys$close(&fab_out);
13073 sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts;
13075 PerlMem_free(vmsin);
13076 PerlMem_free(vmsout);
13080 PerlMem_free(esal);
13083 PerlMem_free(rsal);
13084 PerlMem_free(esa_out);
13085 if (esal_out != NULL)
13086 PerlMem_free(esal_out);
13087 PerlMem_free(rsa_out);
13088 if (rsal_out != NULL)
13089 PerlMem_free(rsal_out);
13092 set_errno(EVMSERR); set_vaxc_errno(sts);
13098 } /* end of rmscopy() */
13102 /*** The following glue provides 'hooks' to make some of the routines
13103 * from this file available from Perl. These routines are sufficiently
13104 * basic, and are required sufficiently early in the build process,
13105 * that's it's nice to have them available to miniperl as well as the
13106 * full Perl, so they're set up here instead of in an extension. The
13107 * Perl code which handles importation of these names into a given
13108 * package lives in [.VMS]Filespec.pm in @INC.
13112 rmsexpand_fromperl(pTHX_ CV *cv)
13115 char *fspec, *defspec = NULL, *rslt;
13117 int fs_utf8, dfs_utf8;
13121 if (!items || items > 2)
13122 Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])");
13123 fspec = SvPV(ST(0),n_a);
13124 fs_utf8 = SvUTF8(ST(0));
13125 if (!fspec || !*fspec) XSRETURN_UNDEF;
13127 defspec = SvPV(ST(1),n_a);
13128 dfs_utf8 = SvUTF8(ST(1));
13130 rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8);
13131 ST(0) = sv_newmortal();
13132 if (rslt != NULL) {
13133 sv_usepvn(ST(0),rslt,strlen(rslt));
13142 vmsify_fromperl(pTHX_ CV *cv)
13149 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)");
13150 utf8_fl = SvUTF8(ST(0));
13151 vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13152 ST(0) = sv_newmortal();
13153 if (vmsified != NULL) {
13154 sv_usepvn(ST(0),vmsified,strlen(vmsified));
13163 unixify_fromperl(pTHX_ CV *cv)
13170 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)");
13171 utf8_fl = SvUTF8(ST(0));
13172 unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13173 ST(0) = sv_newmortal();
13174 if (unixified != NULL) {
13175 sv_usepvn(ST(0),unixified,strlen(unixified));
13184 fileify_fromperl(pTHX_ CV *cv)
13191 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)");
13192 utf8_fl = SvUTF8(ST(0));
13193 fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13194 ST(0) = sv_newmortal();
13195 if (fileified != NULL) {
13196 sv_usepvn(ST(0),fileified,strlen(fileified));
13205 pathify_fromperl(pTHX_ CV *cv)
13212 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)");
13213 utf8_fl = SvUTF8(ST(0));
13214 pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13215 ST(0) = sv_newmortal();
13216 if (pathified != NULL) {
13217 sv_usepvn(ST(0),pathified,strlen(pathified));
13226 vmspath_fromperl(pTHX_ CV *cv)
13233 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)");
13234 utf8_fl = SvUTF8(ST(0));
13235 vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13236 ST(0) = sv_newmortal();
13237 if (vmspath != NULL) {
13238 sv_usepvn(ST(0),vmspath,strlen(vmspath));
13247 unixpath_fromperl(pTHX_ CV *cv)
13254 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)");
13255 utf8_fl = SvUTF8(ST(0));
13256 unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl);
13257 ST(0) = sv_newmortal();
13258 if (unixpath != NULL) {
13259 sv_usepvn(ST(0),unixpath,strlen(unixpath));
13268 candelete_fromperl(pTHX_ CV *cv)
13276 if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::candelete(spec)");
13278 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13279 Newx(fspec, VMS_MAXRSS, char);
13280 if (fspec == NULL) _ckvmssts(SS$_INSFMEM);
13281 if (SvTYPE(mysv) == SVt_PVGV) {
13282 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),fspec)) {
13283 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13291 if (mysv != ST(0) || !(fsp = SvPV(mysv,n_a)) || !*fsp) {
13292 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13299 ST(0) = boolSV(cando_by_name(S_IDUSR,0,fsp));
13305 rmscopy_fromperl(pTHX_ CV *cv)
13308 char *inspec, *outspec, *inp, *outp;
13310 struct dsc$descriptor indsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0},
13311 outdsc = { 0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13312 unsigned long int sts;
13317 if (items < 2 || items > 3)
13318 Perl_croak(aTHX_ "Usage: File::Copy::rmscopy(from,to[,date_flag])");
13320 mysv = SvROK(ST(0)) ? SvRV(ST(0)) : ST(0);
13321 Newx(inspec, VMS_MAXRSS, char);
13322 if (SvTYPE(mysv) == SVt_PVGV) {
13323 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),inspec)) {
13324 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13332 if (mysv != ST(0) || !(inp = SvPV(mysv,n_a)) || !*inp) {
13333 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13339 mysv = SvROK(ST(1)) ? SvRV(ST(1)) : ST(1);
13340 Newx(outspec, VMS_MAXRSS, char);
13341 if (SvTYPE(mysv) == SVt_PVGV) {
13342 if (!(io = GvIOp(mysv)) || !PerlIO_getname(IoIFP(io),outspec)) {
13343 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13352 if (mysv != ST(1) || !(outp = SvPV(mysv,n_a)) || !*outp) {
13353 set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG);
13360 date_flag = (items == 3) ? SvIV(ST(2)) : 0;
13362 ST(0) = boolSV(rmscopy(inp,outp,date_flag));
13368 /* The mod2fname is limited to shorter filenames by design, so it should
13369 * not be modified to support longer EFS pathnames
13372 mod2fname(pTHX_ CV *cv)
13375 char ultimate_name[NAM$C_MAXRSS+1], work_name[NAM$C_MAXRSS*8 + 1],
13376 workbuff[NAM$C_MAXRSS*1 + 1];
13377 int total_namelen = 3, counter, num_entries;
13378 /* ODS-5 ups this, but we want to be consistent, so... */
13379 int max_name_len = 39;
13380 AV *in_array = (AV *)SvRV(ST(0));
13382 num_entries = av_len(in_array);
13384 /* All the names start with PL_. */
13385 strcpy(ultimate_name, "PL_");
13387 /* Clean up our working buffer */
13388 Zero(work_name, sizeof(work_name), char);
13390 /* Run through the entries and build up a working name */
13391 for(counter = 0; counter <= num_entries; counter++) {
13392 /* If it's not the first name then tack on a __ */
13394 strcat(work_name, "__");
13396 strcat(work_name, SvPV_nolen(*av_fetch(in_array, counter, FALSE)));
13399 /* Check to see if we actually have to bother...*/
13400 if (strlen(work_name) + 3 <= max_name_len) {
13401 strcat(ultimate_name, work_name);
13403 /* It's too darned big, so we need to go strip. We use the same */
13404 /* algorithm as xsubpp does. First, strip out doubled __ */
13405 char *source, *dest, last;
13408 for (source = work_name; *source; source++) {
13409 if (last == *source && last == '_') {
13415 /* Go put it back */
13416 strcpy(work_name, workbuff);
13417 /* Is it still too big? */
13418 if (strlen(work_name) + 3 > max_name_len) {
13419 /* Strip duplicate letters */
13422 for (source = work_name; *source; source++) {
13423 if (last == toupper(*source)) {
13427 last = toupper(*source);
13429 strcpy(work_name, workbuff);
13432 /* Is it *still* too big? */
13433 if (strlen(work_name) + 3 > max_name_len) {
13434 /* Too bad, we truncate */
13435 work_name[max_name_len - 2] = 0;
13437 strcat(ultimate_name, work_name);
13440 /* Okay, return it */
13441 ST(0) = sv_2mortal(newSVpv(ultimate_name, 0));
13446 hushexit_fromperl(pTHX_ CV *cv)
13451 VMSISH_HUSHED = SvTRUE(ST(0));
13453 ST(0) = boolSV(VMSISH_HUSHED);
13459 Perl_vms_start_glob
13460 (pTHX_ SV *tmpglob,
13464 struct vs_str_st *rslt;
13468 $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
13471 struct dsc$descriptor_s wilddsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13472 struct dsc$descriptor_vs rsdsc;
13473 unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0;
13474 unsigned long hasver = 0, isunix = 0;
13475 unsigned long int lff_flags = 0;
13477 int vms_old_glob = 1;
13479 if (!SvOK(tmpglob)) {
13480 SETERRNO(ENOENT,RMS$_FNF);
13484 vms_old_glob = !decc_filename_unix_report;
13486 #ifdef VMS_LONGNAME_SUPPORT
13487 lff_flags = LIB$M_FIL_LONG_NAMES;
13489 /* The Newx macro will not allow me to assign a smaller array
13490 * to the rslt pointer, so we will assign it to the begin char pointer
13491 * and then copy the value into the rslt pointer.
13493 Newx(begin, VMS_MAXRSS + sizeof(unsigned short int), char);
13494 rslt = (struct vs_str_st *)begin;
13496 rstr = &rslt->str[0];
13497 rsdsc.dsc$a_pointer = (char *) rslt; /* cast required */
13498 rsdsc.dsc$w_maxstrlen = VMS_MAXRSS + sizeof(unsigned short int);
13499 rsdsc.dsc$b_dtype = DSC$K_DTYPE_VT;
13500 rsdsc.dsc$b_class = DSC$K_CLASS_VS;
13502 Newx(vmsspec, VMS_MAXRSS, char);
13504 /* We could find out if there's an explicit dev/dir or version
13505 by peeking into lib$find_file's internal context at
13506 ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
13507 but that's unsupported, so I don't want to do it now and
13508 have it bite someone in the future. */
13509 /* Fix-me: vms_split_path() is the only way to do this, the
13510 existing method will fail with many legal EFS or UNIX specifications
13513 cp = SvPV(tmpglob,i);
13516 if (cp[i] == ';') hasver = 1;
13517 if (cp[i] == '.') {
13518 if (sts) hasver = 1;
13521 if (cp[i] == '/') {
13522 hasdir = isunix = 1;
13525 if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
13531 /* In UNIX report mode, assume UNIX unless VMS directory delimiters seen */
13532 if ((hasdir == 0) && decc_filename_unix_report) {
13536 if ((tmpfp = PerlIO_tmpfile()) != NULL) {
13537 char * wv_spec, * wr_spec, * wd_spec, * wn_spec, * we_spec, * wvs_spec;
13538 int wv_sts, wv_len, wr_len, wd_len, wn_len, we_len, wvs_len;
13544 stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st);
13545 if (!stat_sts && S_ISDIR(st.st_mode)) {
13547 const char * fname;
13550 /* Test to see if SvPVX_const(tmpglob) ends with a VMS */
13551 /* path delimiter of ':>]', if so, then the old behavior has */
13552 /* obviously been specificially requested */
13554 fname = SvPVX_const(tmpglob);
13555 fname_len = strlen(fname);
13556 vms_dir = strpbrk(&fname[fname_len - 1], ":>]");
13557 if (vms_old_glob || (vms_dir != NULL)) {
13558 wilddsc.dsc$a_pointer = tovmspath_utf8(
13559 SvPVX(tmpglob),vmsspec,NULL);
13560 ok = (wilddsc.dsc$a_pointer != NULL);
13561 /* maybe passed 'foo' rather than '[.foo]', thus not
13565 /* Operate just on the directory, the special stat/fstat for */
13566 /* leaves the fileified specification in the st_devnam */
13568 wilddsc.dsc$a_pointer = st.st_devnam;
13573 wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL);
13574 ok = (wilddsc.dsc$a_pointer != NULL);
13577 wilddsc.dsc$w_length = strlen(wilddsc.dsc$a_pointer);
13579 /* If not extended character set, replace ? with % */
13580 /* With extended character set, ? is a wildcard single character */
13581 for (cp=wilddsc.dsc$a_pointer; ok && cp && *cp; cp++) {
13584 if (!decc_efs_case_preserve)
13586 } else if (*cp == '%') {
13588 } else if (*cp == '*') {
13594 wv_sts = vms_split_path(
13595 wilddsc.dsc$a_pointer, &wv_spec, &wv_len, &wr_spec, &wr_len,
13596 &wd_spec, &wd_len, &wn_spec, &wn_len, &we_spec, &we_len,
13597 &wvs_spec, &wvs_len);
13606 while (ok && $VMS_STATUS_SUCCESS(sts)) {
13607 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13608 int v_sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13612 sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
13613 &dfltdsc,NULL,&rms_sts,&lff_flags);
13614 if (!$VMS_STATUS_SUCCESS(sts))
13617 /* with varying string, 1st word of buffer contains result length */
13618 rstr[rslt->length] = '\0';
13620 /* Find where all the components are */
13621 v_sts = vms_split_path
13636 /* If no version on input, truncate the version on output */
13637 if (!hasver && (vs_len > 0)) {
13644 /* In Unix report mode, remove the ".dir;1" from the name */
13645 /* if it is a real directory */
13646 if (decc_filename_unix_report || decc_efs_charset) {
13647 if (is_dir_ext(e_spec, e_len, vs_spec, vs_len)) {
13651 ret_sts = flex_lstat(rstr, &statbuf);
13652 if ((ret_sts == 0) &&
13653 S_ISDIR(statbuf.st_mode)) {
13660 /* No version & a null extension on UNIX handling */
13661 if ((e_len == 1) && decc_readdir_dropdotnotype) {
13667 if (!decc_efs_case_preserve) {
13668 for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
13671 /* Find File treats a Null extension as return all extensions */
13672 /* This is contrary to Perl expectations */
13674 if (wildstar || wildquery || vms_old_glob) {
13675 /* really need to see if the returned file name matched */
13676 /* but for now will assume that it matches */
13679 /* Exact Match requested */
13680 /* How are directories handled? - like a file */
13681 if ((e_len == we_len) && (n_len == wn_len)) {
13685 t1 = strncmp(e_spec, we_spec, e_len);
13689 t1 = strncmp(n_spec, we_spec, n_len);
13700 if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
13704 /* Start with the name */
13707 strcat(begin,"\n");
13708 ok = (PerlIO_puts(tmpfp,begin) != EOF);
13711 if (cxt) (void)lib$find_file_end(&cxt);
13714 /* Be POSIXish: return the input pattern when no matches */
13715 strcpy(rstr,SvPVX(tmpglob));
13717 ok = (PerlIO_puts(tmpfp,rstr) != EOF);
13720 if (ok && sts != RMS$_NMF &&
13721 sts != RMS$_DNF && sts != RMS_FNF) ok = 0;
13724 SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
13726 PerlIO_close(tmpfp);
13730 PerlIO_rewind(tmpfp);
13731 IoTYPE(io) = IoTYPE_RDONLY;
13732 IoIFP(io) = fp = tmpfp;
13733 IoFLAGS(io) &= ~IOf_UNTAINT; /* maybe redundant */
13743 mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec,
13747 unixrealpath_fromperl(pTHX_ CV *cv)
13750 char *fspec, *rslt_spec, *rslt;
13753 if (!items || items != 1)
13754 Perl_croak(aTHX_ "Usage: VMS::Filespec::unixrealpath(spec)");
13756 fspec = SvPV(ST(0),n_a);
13757 if (!fspec || !*fspec) XSRETURN_UNDEF;
13759 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13760 rslt = do_vms_realpath(fspec, rslt_spec, NULL);
13762 ST(0) = sv_newmortal();
13764 sv_usepvn(ST(0),rslt,strlen(rslt));
13766 Safefree(rslt_spec);
13771 mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec,
13775 vmsrealpath_fromperl(pTHX_ CV *cv)
13778 char *fspec, *rslt_spec, *rslt;
13781 if (!items || items != 1)
13782 Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsrealpath(spec)");
13784 fspec = SvPV(ST(0),n_a);
13785 if (!fspec || !*fspec) XSRETURN_UNDEF;
13787 Newx(rslt_spec, VMS_MAXRSS + 1, char);
13788 rslt = do_vms_realname(fspec, rslt_spec, NULL);
13790 ST(0) = sv_newmortal();
13792 sv_usepvn(ST(0),rslt,strlen(rslt));
13794 Safefree(rslt_spec);
13800 * A thin wrapper around decc$symlink to make sure we follow the
13801 * standard and do not create a symlink with a zero-length name.
13803 * Also in ODS-2 mode, existing tests assume that the link target
13804 * will be converted to UNIX format.
13806 /*{{{ int my_symlink(pTHX_ const char *contents, const char *link_name)*/
13807 int Perl_my_symlink(pTHX_ const char *contents, const char *link_name) {
13808 if (!link_name || !*link_name) {
13809 SETERRNO(ENOENT, SS$_NOSUCHFILE);
13813 if (decc_efs_charset) {
13814 return symlink(contents, link_name);
13819 /* Unless we are in ODS-5 mode, convert the symlink target to UNIX */
13820 /* because in order to work, the symlink target must be in UNIX format */
13822 /* As symbolic links can hold things other than files, we will only do */
13823 /* the conversion in in ODS-2 mode */
13825 Newx(utarget, VMS_MAXRSS + 1, char);
13826 if (int_tounixspec(contents, utarget, NULL) == NULL) {
13828 /* This should not fail, as an untranslatable filename */
13829 /* should be passed through */
13830 utarget = (char *)contents;
13832 sts = symlink(utarget, link_name);
13840 #endif /* HAS_SYMLINK */
13842 int do_vms_case_tolerant(void);
13845 case_tolerant_process_fromperl(pTHX_ CV *cv)
13848 ST(0) = boolSV(do_vms_case_tolerant());
13852 #ifdef USE_ITHREADS
13855 Perl_sys_intern_dup(pTHX_ struct interp_intern *src,
13856 struct interp_intern *dst)
13858 PERL_ARGS_ASSERT_SYS_INTERN_DUP;
13860 memcpy(dst,src,sizeof(struct interp_intern));
13866 Perl_sys_intern_clear(pTHX)
13871 Perl_sys_intern_init(pTHX)
13873 unsigned int ix = RAND_MAX;
13878 MY_POSIX_EXIT = vms_posix_exit;
13881 MY_INV_RAND_MAX = 1./x;
13885 init_os_extras(void)
13888 char* file = __FILE__;
13889 if (decc_disable_to_vms_logname_translation) {
13890 no_translate_barewords = TRUE;
13892 no_translate_barewords = FALSE;
13895 newXSproto("VMS::Filespec::rmsexpand",rmsexpand_fromperl,file,"$;$");
13896 newXSproto("VMS::Filespec::vmsify",vmsify_fromperl,file,"$");
13897 newXSproto("VMS::Filespec::unixify",unixify_fromperl,file,"$");
13898 newXSproto("VMS::Filespec::pathify",pathify_fromperl,file,"$");
13899 newXSproto("VMS::Filespec::fileify",fileify_fromperl,file,"$");
13900 newXSproto("VMS::Filespec::vmspath",vmspath_fromperl,file,"$");
13901 newXSproto("VMS::Filespec::unixpath",unixpath_fromperl,file,"$");
13902 newXSproto("VMS::Filespec::candelete",candelete_fromperl,file,"$");
13903 newXSproto("DynaLoader::mod2fname", mod2fname, file, "$");
13904 newXS("File::Copy::rmscopy",rmscopy_fromperl,file);
13905 newXSproto("vmsish::hushed",hushexit_fromperl,file,";$");
13906 newXSproto("VMS::Filespec::unixrealpath",unixrealpath_fromperl,file,"$;$");
13907 newXSproto("VMS::Filespec::vmsrealpath",vmsrealpath_fromperl,file,"$;$");
13908 newXSproto("VMS::Filespec::case_tolerant_process",
13909 case_tolerant_process_fromperl,file,"");
13911 store_pipelocs(aTHX); /* will redo any earlier attempts */
13916 #if __CRTL_VER == 80200000
13917 /* This missed getting in to the DECC SDK for 8.2 */
13918 char *realpath(const char *file_name, char * resolved_name, ...);
13921 /*{{{char *do_vms_realpath(const char *file_name, char *resolved_name)*/
13922 /* wrapper for the realpath() function added with 8.2 RMS SYMLINK SDK.
13923 * The perl fallback routine to provide realpath() is not as efficient
13927 /* Hack, use old stat() as fastest way of getting ino_t and device */
13928 int decc$stat(const char *name, void * statbuf);
13931 /* Realpath is fragile. In 8.3 it does not work if the feature
13932 * DECC$POSIX_COMPLIANT_PATHNAMES is not enabled, even though symbolic
13933 * links are implemented in RMS, not the CRTL. It also can fail if the
13934 * user does not have read/execute access to some of the directories.
13935 * So in order for Do What I Mean mode to work, if realpath() fails,
13936 * fall back to looking up the filename by the device name and FID.
13939 int vms_fid_to_name(char * outname, int outlen, const char * name)
13943 unsigned short st_ino[3];
13944 unsigned short padw;
13945 unsigned long padl[30]; /* plenty of room */
13948 struct dsc$descriptor_s dvidsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13949 struct dsc$descriptor_s specdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
13951 sts = decc$stat(name, &statbuf);
13954 dvidsc.dsc$a_pointer=statbuf.st_dev;
13955 dvidsc.dsc$w_length=strlen(statbuf.st_dev);
13957 specdsc.dsc$a_pointer = outname;
13958 specdsc.dsc$w_length = outlen-1;
13960 sts = lib$fid_to_name
13961 (&dvidsc, statbuf.st_ino, &specdsc, &specdsc.dsc$w_length);
13962 if ($VMS_STATUS_SUCCESS(sts)) {
13963 outname[specdsc.dsc$w_length] = 0;
13973 mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf,
13976 char * rslt = NULL;
13979 if (decc_posix_compliant_pathnames > 0 ) {
13980 /* realpath currently only works if posix compliant pathnames are
13981 * enabled. It may start working when they are not, but in that
13982 * case we still want the fallback behavior for backwards compatibility
13984 rslt = realpath(filespec, outbuf);
13988 if (rslt == NULL) {
13990 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
13991 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
13994 /* Fall back to fid_to_name */
13996 Newx(vms_spec, VMS_MAXRSS + 1, char);
13998 sts = vms_fid_to_name(vms_spec, VMS_MAXRSS + 1, filespec);
14002 /* Now need to trim the version off */
14003 sts = vms_split_path
14023 /* Trim off the version */
14024 int file_len = v_len + r_len + d_len + n_len + e_len;
14025 vms_spec[file_len] = 0;
14027 /* The result is expected to be in UNIX format */
14028 rslt = int_tounixspec(vms_spec, outbuf, utf8_fl);
14030 /* Downcase if input had any lower case letters and
14031 * case preservation is not in effect.
14033 if (!decc_efs_case_preserve) {
14034 for (cp = filespec; *cp; cp++)
14035 if (islower(*cp)) { haslower = 1; break; }
14037 if (haslower) __mystrtolower(rslt);
14042 /* Now for some hacks to deal with backwards and forward */
14044 if (!decc_efs_charset) {
14046 /* 1. ODS-2 mode wants to do a syntax only translation */
14047 rslt = int_rmsexpand(filespec, outbuf,
14048 NULL, 0, NULL, utf8_fl);
14051 if (decc_filename_unix_report) {
14053 char * vms_dir_name;
14056 /* 2. ODS-5 / UNIX report mode should return a failure */
14057 /* if the parent directory also does not exist */
14058 /* Otherwise, get the real path for the parent */
14059 /* and add the child to it.
14061 /* basename / dirname only available for VMS 7.0+ */
14062 /* So we may need to implement them as common routines */
14064 Newx(dir_name, VMS_MAXRSS + 1, char);
14065 Newx(vms_dir_name, VMS_MAXRSS + 1, char);
14066 dir_name[0] = '\0';
14069 /* First try a VMS parse */
14070 sts = vms_split_path
14088 int dir_len = v_len + r_len + d_len + n_len;
14090 strncpy(dir_name, filespec, dir_len);
14091 dir_name[dir_len] = '\0';
14092 file_name = (char *)&filespec[dir_len + 1];
14095 /* This must be UNIX */
14098 tchar = strrchr(filespec, '/');
14100 if (tchar != NULL) {
14101 int dir_len = tchar - filespec;
14102 strncpy(dir_name, filespec, dir_len);
14103 dir_name[dir_len] = '\0';
14104 file_name = (char *) &filespec[dir_len + 1];
14108 /* Dir name is defaulted */
14109 if (dir_name[0] == 0) {
14111 dir_name[1] = '\0';
14114 /* Need realpath for the directory */
14115 sts = vms_fid_to_name(vms_dir_name,
14120 /* Now need to pathify it.
14121 char *tdir = int_pathify_dirspec(vms_dir_name,
14124 /* And now add the original filespec to it */
14125 if (file_name != NULL) {
14126 strcat(outbuf, file_name);
14130 Safefree(vms_dir_name);
14131 Safefree(dir_name);
14135 Safefree(vms_spec);
14141 mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf,
14144 char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec;
14145 int sts, v_len, r_len, d_len, n_len, e_len, vs_len;
14148 /* Fall back to fid_to_name */
14150 sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec);
14157 /* Now need to trim the version off */
14158 sts = vms_split_path
14178 /* Trim off the version */
14179 int file_len = v_len + r_len + d_len + n_len + e_len;
14180 outbuf[file_len] = 0;
14182 /* Downcase if input had any lower case letters and
14183 * case preservation is not in effect.
14185 if (!decc_efs_case_preserve) {
14186 for (cp = filespec; *cp; cp++)
14187 if (islower(*cp)) { haslower = 1; break; }
14189 if (haslower) __mystrtolower(outbuf);
14198 /* External entry points */
14199 char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14200 { return do_vms_realpath(filespec, outbuf, utf8_fl); }
14202 char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl)
14203 { return do_vms_realname(filespec, outbuf, utf8_fl); }
14205 /* case_tolerant */
14207 /*{{{int do_vms_case_tolerant(void)*/
14208 /* OpenVMS provides a case sensitive implementation of ODS-5 and this is
14209 * controlled by a process setting.
14211 int do_vms_case_tolerant(void)
14213 return vms_process_case_tolerant;
14216 /* External entry points */
14217 #if __CRTL_VER >= 70301000 && !defined(__VAX)
14218 int Perl_vms_case_tolerant(void)
14219 { return do_vms_case_tolerant(); }
14221 int Perl_vms_case_tolerant(void)
14222 { return vms_process_case_tolerant; }
14226 /* Start of DECC RTL Feature handling */
14228 static int sys_trnlnm
14229 (const char * logname,
14233 const $DESCRIPTOR(table_dsc, "LNM$FILE_DEV");
14234 const unsigned long attr = LNM$M_CASE_BLIND;
14235 struct dsc$descriptor_s name_dsc;
14237 unsigned short result;
14238 struct itmlst_3 itlst[2] = {{value_len, LNM$_STRING, value, &result},
14241 name_dsc.dsc$w_length = strlen(logname);
14242 name_dsc.dsc$a_pointer = (char *)logname;
14243 name_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14244 name_dsc.dsc$b_class = DSC$K_CLASS_S;
14246 status = sys$trnlnm(&attr, &table_dsc, &name_dsc, 0, itlst);
14248 if ($VMS_STATUS_SUCCESS(status)) {
14250 /* Null terminate and return the string */
14251 /*--------------------------------------*/
14258 static int sys_crelnm
14259 (const char * logname,
14260 const char * value)
14263 const char * proc_table = "LNM$PROCESS_TABLE";
14264 struct dsc$descriptor_s proc_table_dsc;
14265 struct dsc$descriptor_s logname_dsc;
14266 struct itmlst_3 item_list[2];
14268 proc_table_dsc.dsc$a_pointer = (char *) proc_table;
14269 proc_table_dsc.dsc$w_length = strlen(proc_table);
14270 proc_table_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14271 proc_table_dsc.dsc$b_class = DSC$K_CLASS_S;
14273 logname_dsc.dsc$a_pointer = (char *) logname;
14274 logname_dsc.dsc$w_length = strlen(logname);
14275 logname_dsc.dsc$b_dtype = DSC$K_DTYPE_T;
14276 logname_dsc.dsc$b_class = DSC$K_CLASS_S;
14278 item_list[0].buflen = strlen(value);
14279 item_list[0].itmcode = LNM$_STRING;
14280 item_list[0].bufadr = (char *)value;
14281 item_list[0].retlen = NULL;
14283 item_list[1].buflen = 0;
14284 item_list[1].itmcode = 0;
14286 ret_val = sys$crelnm
14288 (const struct dsc$descriptor_s *)&proc_table_dsc,
14289 (const struct dsc$descriptor_s *)&logname_dsc,
14291 (const struct item_list_3 *) item_list);
14296 /* C RTL Feature settings */
14298 static int set_features
14299 (int (* init_coroutine)(int *, int *, void *), /* Needs casts if used */
14300 int (* cli_routine)(void), /* Not documented */
14301 void *image_info) /* Not documented */
14307 #if defined(JPI$_CASE_LOOKUP_PERM) && !defined(__VAX)
14308 const unsigned long int jpicode1 = JPI$_CASE_LOOKUP_PERM;
14309 const unsigned long int jpicode2 = JPI$_CASE_LOOKUP_IMAGE;
14310 unsigned long case_perm;
14311 unsigned long case_image;
14314 /* Allow an exception to bring Perl into the VMS debugger */
14315 vms_debug_on_exception = 0;
14316 status = sys_trnlnm("PERL_VMS_EXCEPTION_DEBUG", val_str, sizeof(val_str));
14317 if ($VMS_STATUS_SUCCESS(status)) {
14318 val_str[0] = _toupper(val_str[0]);
14319 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14320 vms_debug_on_exception = 1;
14322 vms_debug_on_exception = 0;
14325 /* Debug unix/vms file translation routines */
14326 vms_debug_fileify = 0;
14327 status = sys_trnlnm("PERL_VMS_FILEIFY_DEBUG", val_str, sizeof(val_str));
14328 if ($VMS_STATUS_SUCCESS(status)) {
14329 val_str[0] = _toupper(val_str[0]);
14330 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14331 vms_debug_fileify = 1;
14333 vms_debug_fileify = 0;
14337 /* Historically PERL has been doing vmsify / stat differently than */
14338 /* the CRTL. In particular, under some conditions the CRTL will */
14339 /* remove some illegal characters like spaces from filenames */
14340 /* resulting in some differences. The stat()/lstat() wrapper has */
14341 /* been reporting such file names as invalid and fails to stat them */
14342 /* fixing this bug so that stat()/lstat() accept these like the */
14343 /* CRTL does will result in several tests failing. */
14344 /* This should really be fixed, but for now, set up a feature to */
14345 /* enable it so that the impact can be studied. */
14346 vms_bug_stat_filename = 0;
14347 status = sys_trnlnm("PERL_VMS_BUG_STAT_FILENAME", val_str, sizeof(val_str));
14348 if ($VMS_STATUS_SUCCESS(status)) {
14349 val_str[0] = _toupper(val_str[0]);
14350 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14351 vms_bug_stat_filename = 1;
14353 vms_bug_stat_filename = 0;
14357 /* Create VTF-7 filenames from Unicode instead of UTF-8 */
14358 vms_vtf7_filenames = 0;
14359 status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str));
14360 if ($VMS_STATUS_SUCCESS(status)) {
14361 val_str[0] = _toupper(val_str[0]);
14362 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14363 vms_vtf7_filenames = 1;
14365 vms_vtf7_filenames = 0;
14368 /* unlink all versions on unlink() or rename() */
14369 vms_unlink_all_versions = 0;
14370 status = sys_trnlnm
14371 ("PERL_VMS_UNLINK_ALL_VERSIONS", val_str, sizeof(val_str));
14372 if ($VMS_STATUS_SUCCESS(status)) {
14373 val_str[0] = _toupper(val_str[0]);
14374 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14375 vms_unlink_all_versions = 1;
14377 vms_unlink_all_versions = 0;
14380 /* Dectect running under GNV Bash or other UNIX like shell */
14381 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14382 gnv_unix_shell = 0;
14383 status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str));
14384 if ($VMS_STATUS_SUCCESS(status)) {
14385 gnv_unix_shell = 1;
14386 set_feature_default("DECC$EFS_CASE_PRESERVE", 1);
14387 set_feature_default("DECC$EFS_CHARSET", 1);
14388 set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1);
14389 set_feature_default("DECC$FILENAME_UNIX_REPORT", 1);
14390 set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1);
14391 set_feature_default("DECC$DISABLE_POSIX_ROOT", 0);
14392 vms_unlink_all_versions = 1;
14393 vms_posix_exit = 1;
14397 /* hacks to see if known bugs are still present for testing */
14399 /* PCP mode requires creating /dev/null special device file */
14400 decc_bug_devnull = 0;
14401 status = sys_trnlnm("DECC_BUG_DEVNULL", val_str, sizeof(val_str));
14402 if ($VMS_STATUS_SUCCESS(status)) {
14403 val_str[0] = _toupper(val_str[0]);
14404 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14405 decc_bug_devnull = 1;
14407 decc_bug_devnull = 0;
14410 /* UNIX directory names with no paths are broken in a lot of places */
14411 decc_dir_barename = 1;
14412 status = sys_trnlnm("DECC_DIR_BARENAME", val_str, sizeof(val_str));
14413 if ($VMS_STATUS_SUCCESS(status)) {
14414 val_str[0] = _toupper(val_str[0]);
14415 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14416 decc_dir_barename = 1;
14418 decc_dir_barename = 0;
14421 #if __CRTL_VER >= 70300000 && !defined(__VAX)
14422 s = decc$feature_get_index("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION");
14424 decc_disable_to_vms_logname_translation = decc$feature_get_value(s, 1);
14425 if (decc_disable_to_vms_logname_translation < 0)
14426 decc_disable_to_vms_logname_translation = 0;
14429 s = decc$feature_get_index("DECC$EFS_CASE_PRESERVE");
14431 decc_efs_case_preserve = decc$feature_get_value(s, 1);
14432 if (decc_efs_case_preserve < 0)
14433 decc_efs_case_preserve = 0;
14436 s = decc$feature_get_index("DECC$EFS_CHARSET");
14437 decc_efs_charset_index = s;
14439 decc_efs_charset = decc$feature_get_value(s, 1);
14440 if (decc_efs_charset < 0)
14441 decc_efs_charset = 0;
14444 s = decc$feature_get_index("DECC$FILENAME_UNIX_REPORT");
14446 decc_filename_unix_report = decc$feature_get_value(s, 1);
14447 if (decc_filename_unix_report > 0) {
14448 decc_filename_unix_report = 1;
14449 vms_posix_exit = 1;
14452 decc_filename_unix_report = 0;
14455 s = decc$feature_get_index("DECC$FILENAME_UNIX_ONLY");
14457 decc_filename_unix_only = decc$feature_get_value(s, 1);
14458 if (decc_filename_unix_only > 0) {
14459 decc_filename_unix_only = 1;
14462 decc_filename_unix_only = 0;
14466 s = decc$feature_get_index("DECC$FILENAME_UNIX_NO_VERSION");
14468 decc_filename_unix_no_version = decc$feature_get_value(s, 1);
14469 if (decc_filename_unix_no_version < 0)
14470 decc_filename_unix_no_version = 0;
14473 s = decc$feature_get_index("DECC$READDIR_DROPDOTNOTYPE");
14475 decc_readdir_dropdotnotype = decc$feature_get_value(s, 1);
14476 if (decc_readdir_dropdotnotype < 0)
14477 decc_readdir_dropdotnotype = 0;
14480 #if __CRTL_VER >= 80200000
14481 s = decc$feature_get_index("DECC$POSIX_COMPLIANT_PATHNAMES");
14483 decc_posix_compliant_pathnames = decc$feature_get_value(s, 1);
14484 if (decc_posix_compliant_pathnames < 0)
14485 decc_posix_compliant_pathnames = 0;
14486 if (decc_posix_compliant_pathnames > 4)
14487 decc_posix_compliant_pathnames = 0;
14492 status = sys_trnlnm
14493 ("DECC$DISABLE_TO_VMS_LOGNAME_TRANSLATION", val_str, sizeof(val_str));
14494 if ($VMS_STATUS_SUCCESS(status)) {
14495 val_str[0] = _toupper(val_str[0]);
14496 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14497 decc_disable_to_vms_logname_translation = 1;
14502 status = sys_trnlnm("DECC$EFS_CASE_PRESERVE", val_str, sizeof(val_str));
14503 if ($VMS_STATUS_SUCCESS(status)) {
14504 val_str[0] = _toupper(val_str[0]);
14505 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14506 decc_efs_case_preserve = 1;
14511 status = sys_trnlnm("DECC$FILENAME_UNIX_REPORT", val_str, sizeof(val_str));
14512 if ($VMS_STATUS_SUCCESS(status)) {
14513 val_str[0] = _toupper(val_str[0]);
14514 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14515 decc_filename_unix_report = 1;
14518 status = sys_trnlnm("DECC$FILENAME_UNIX_ONLY", val_str, sizeof(val_str));
14519 if ($VMS_STATUS_SUCCESS(status)) {
14520 val_str[0] = _toupper(val_str[0]);
14521 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14522 decc_filename_unix_only = 1;
14523 decc_filename_unix_report = 1;
14526 status = sys_trnlnm("DECC$FILENAME_UNIX_NO_VERSION", val_str, sizeof(val_str));
14527 if ($VMS_STATUS_SUCCESS(status)) {
14528 val_str[0] = _toupper(val_str[0]);
14529 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14530 decc_filename_unix_no_version = 1;
14533 status = sys_trnlnm("DECC$READDIR_DROPDOTNOTYPE", val_str, sizeof(val_str));
14534 if ($VMS_STATUS_SUCCESS(status)) {
14535 val_str[0] = _toupper(val_str[0]);
14536 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) {
14537 decc_readdir_dropdotnotype = 1;
14542 #if defined(JPI$_CASE_LOOKUP_PERM) && defined(PPROP$K_CASE_BLIND) && !defined(__VAX)
14544 /* Report true case tolerance */
14545 /*----------------------------*/
14546 status = lib$getjpi(&jpicode1, 0, 0, &case_perm, 0, 0);
14547 if (!$VMS_STATUS_SUCCESS(status))
14548 case_perm = PPROP$K_CASE_BLIND;
14549 status = lib$getjpi(&jpicode2, 0, 0, &case_image, 0, 0);
14550 if (!$VMS_STATUS_SUCCESS(status))
14551 case_image = PPROP$K_CASE_BLIND;
14552 if ((case_perm == PPROP$K_CASE_SENSITIVE) ||
14553 (case_image == PPROP$K_CASE_SENSITIVE))
14554 vms_process_case_tolerant = 0;
14558 /* USE POSIX/DCL Exit codes - Recommended, but needs to default to */
14559 /* for strict backward compatibilty */
14560 status = sys_trnlnm
14561 ("PERL_VMS_POSIX_EXIT", val_str, sizeof(val_str));
14562 if ($VMS_STATUS_SUCCESS(status)) {
14563 val_str[0] = _toupper(val_str[0]);
14564 if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T'))
14565 vms_posix_exit = 1;
14567 vms_posix_exit = 0;
14571 /* CRTL can be initialized past this point, but not before. */
14572 /* DECC$CRTL_INIT(); */
14579 #pragma extern_model save
14580 #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt
14581 const __align (LONGWORD) int spare[8] = {0};
14583 /* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */
14584 #if __DECC_VER >= 60560002
14585 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long
14587 #pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long
14589 #endif /* __DECC */
14591 const long vms_cc_features = (const long)set_features;
14594 ** Force a reference to LIB$INITIALIZE to ensure it
14595 ** exists in the image.
14597 int lib$initialize(void);
14599 #pragma extern_model strict_refdef
14601 int lib_init_ref = (int) lib$initialize;
14604 #pragma extern_model restore