X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=vms%2Fvms.c;h=27214f7ad63d390ef50567c9f7d6156e2d742aa7;hb=5c4d031a9f33835f94f9c1d101c900979c2aca6e;hp=c684e7a753333973a7b5d39b1dc907882e8b9927;hpb=988c775cbb77355593cf99dafc219bbd3d6a62d5;p=p5sagit%2Fp5-mst-13.2.git diff --git a/vms/vms.c b/vms/vms.c index c684e7a..27214f7 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -17,6 +17,7 @@ #include #include #include +#include #include #include #include @@ -47,6 +48,13 @@ #include #include #include +#include +#if __CRTL_VER >= 70000000 /* FIXME to earliest version */ +#include +#define NO_EFN EFN$C_ENF +#else +#define NO_EFN 0; +#endif #if __CRTL_VER < 70301000 && __CRTL_VER >= 70300000 int decc$feature_get_index(const char *name); @@ -57,6 +65,32 @@ int decc$feature_set_value(int index, int mode, int value); #include #endif +#pragma member_alignment save +#pragma nomember_alignment longword +struct item_list_3 { + unsigned short len; + unsigned short code; + void * bufadr; + unsigned short * retadr; +}; +#pragma member_alignment restore + +/* More specific prototype than in starlet_c.h makes programming errors + more visible. + */ +#ifdef sys$getdviw +#undef sys$getdviw +int sys$getdviw + (unsigned long efn, + unsigned short chan, + const struct dsc$descriptor_s * devnam, + const struct item_list_3 * itmlst, + void * iosb, + void * (astadr)(unsigned long), + void * astprm, + void * nullarg); +#endif + #if __CRTL_VER >= 70300000 && !defined(__VAX) static int set_feature_default(const char *name, int value) @@ -110,6 +144,21 @@ return 0; # define RTL_USES_UTC 1 #endif +#ifdef USE_VMS_DECTERM + +/* Routine to create a decterm for use with the Perl debugger */ +/* No headers, this information was found in the Programming Concepts Manual */ + +int decw$term_port + (const struct dsc$descriptor_s * display, + const struct dsc$descriptor_s * setup_file, + const struct dsc$descriptor_s * customization, + struct dsc$descriptor_s * result_device_name, + unsigned short * result_device_name_length, + void * controller, + void * char_buffer, + void * char_change_buffer); +#endif /* gcc's header files don't #define direct access macros * corresponding to VAXC's variant structs */ @@ -157,22 +206,22 @@ struct vs_str_st { #pragma member_alignment restore #endif -#define do_fileify_dirspec(a,b,c) mp_do_fileify_dirspec(aTHX_ a,b,c) -#define do_pathify_dirspec(a,b,c) mp_do_pathify_dirspec(aTHX_ a,b,c) -#define do_tovmsspec(a,b,c) mp_do_tovmsspec(aTHX_ a,b,c) -#define do_tovmspath(a,b,c) mp_do_tovmspath(aTHX_ a,b,c) -#define do_rmsexpand(a,b,c,d,e) mp_do_rmsexpand(aTHX_ a,b,c,d,e) -#define do_vms_realpath(a,b) mp_do_vms_realpath(aTHX_ a,b) -#define do_tounixspec(a,b,c) mp_do_tounixspec(aTHX_ a,b,c) -#define do_tounixpath(a,b,c) mp_do_tounixpath(aTHX_ a,b,c) +#define do_fileify_dirspec(a,b,c,d) mp_do_fileify_dirspec(aTHX_ a,b,c,d) +#define do_pathify_dirspec(a,b,c,d) mp_do_pathify_dirspec(aTHX_ a,b,c,d) +#define do_tovmsspec(a,b,c,d) mp_do_tovmsspec(aTHX_ a,b,c,0,d) +#define do_tovmspath(a,b,c,d) mp_do_tovmspath(aTHX_ a,b,c,d) +#define do_rmsexpand(a,b,c,d,e,f,g) mp_do_rmsexpand(aTHX_ a,b,c,d,e,f,g) +#define do_vms_realpath(a,b,c) mp_do_vms_realpath(aTHX_ a,b,c) +#define do_tounixspec(a,b,c,d) mp_do_tounixspec(aTHX_ a,b,c,d) +#define do_tounixpath(a,b,c,d) mp_do_tounixpath(aTHX_ a,b,c,d) #define do_vms_case_tolerant(a) mp_do_vms_case_tolerant(a) #define expand_wild_cards(a,b,c,d) mp_expand_wild_cards(aTHX_ a,b,c,d) #define getredirection(a,b) mp_getredirection(aTHX_ a,b) -static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts); -static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts); -static char *mp_do_tounixspec(pTHX_ const char *, char *, int); -static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts); +static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int *); +static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int *); +static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *); +static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int *); /* see system service docs for $TRNLNM -- NOT the same as LNM$_MAX_INDEX */ #define PERL_LNM_MAX_ALLOWED_INDEX 127 @@ -228,6 +277,8 @@ int decc_filename_unix_report = 0; int decc_posix_compliant_pathnames = 0; int decc_readdir_dropdotnotype = 0; static int vms_process_case_tolerant = 1; +int vms_vtf7_filenames = 0; +int gnv_unix_shell = 0; /* bug workarounds if needed */ int decc_bug_readdir_efs1 = 0; @@ -267,6 +318,242 @@ const char * pch1; return ret_val; } +/* This routine converts a UCS-2 character to be VTF-7 encoded. + */ + +static void ucs2_to_vtf7 + (char *outspec, + unsigned long ucs2_char, + int * output_cnt) +{ +unsigned char * ucs_ptr; +int hex; + + ucs_ptr = (unsigned char *)&ucs2_char; + + outspec[0] = '^'; + outspec[1] = 'U'; + hex = (ucs_ptr[1] >> 4) & 0xf; + if (hex < 0xA) + outspec[2] = hex + '0'; + else + outspec[2] = (hex - 9) + 'A'; + hex = ucs_ptr[1] & 0xF; + if (hex < 0xA) + outspec[3] = hex + '0'; + else { + outspec[3] = (hex - 9) + 'A'; + } + hex = (ucs_ptr[0] >> 4) & 0xf; + if (hex < 0xA) + outspec[4] = hex + '0'; + else + outspec[4] = (hex - 9) + 'A'; + hex = ucs_ptr[1] & 0xF; + if (hex < 0xA) + outspec[5] = hex + '0'; + else { + outspec[5] = (hex - 9) + 'A'; + } + *output_cnt = 6; +} + + +/* This handles the conversion of a UNIX extended character set to a ^ + * escaped VMS character. + * in a UNIX file specification. + * + * The output count variable contains the number of characters added + * to the output string. + * + * The return value is the number of characters read from the input string + */ +static int copy_expand_unix_filename_escape + (char *outspec, const char *inspec, int *output_cnt, const int * utf8_fl) +{ +int count; +int scnt; +int utf8_flag; + + utf8_flag = 0; + if (utf8_fl) + utf8_flag = *utf8_fl; + + count = 0; + *output_cnt = 0; + if (*inspec >= 0x80) { + if (utf8_fl && vms_vtf7_filenames) { + unsigned long ucs_char; + + ucs_char = 0; + + if ((*inspec & 0xE0) == 0xC0) { + /* 2 byte Unicode */ + ucs_char = ((inspec[0] & 0x1F) << 6) + (inspec[1] & 0x3f); + if (ucs_char >= 0x80) { + ucs2_to_vtf7(outspec, ucs_char, output_cnt); + return 2; + } + } else if ((*inspec & 0xF0) == 0xE0) { + /* 3 byte Unicode */ + ucs_char = ((inspec[0] & 0xF) << 12) + + ((inspec[1] & 0x3f) << 6) + + (inspec[2] & 0x3f); + if (ucs_char >= 0x800) { + ucs2_to_vtf7(outspec, ucs_char, output_cnt); + return 3; + } + +#if 0 /* I do not see longer sequences supported by OpenVMS */ + /* Maybe some one can fix this later */ + } else if ((*inspec & 0xF8) == 0xF0) { + /* 4 byte Unicode */ + /* UCS-4 to UCS-2 */ + } else if ((*inspec & 0xFC) == 0xF8) { + /* 5 byte Unicode */ + /* UCS-4 to UCS-2 */ + } else if ((*inspec & 0xFE) == 0xFC) { + /* 6 byte Unicode */ + /* UCS-4 to UCS-2 */ +#endif + } + } + + /* High bit set, but not a Unicode character! */ + + /* Non printing DECMCS or ISO Latin-1 character? */ + if (*inspec <= 0x9F) { + int hex; + outspec[0] = '^'; + outspec++; + hex = (*inspec >> 4) & 0xF; + if (hex < 0xA) + outspec[1] = hex + '0'; + else { + outspec[1] = (hex - 9) + 'A'; + } + hex = *inspec & 0xF; + if (hex < 0xA) + outspec[2] = hex + '0'; + else { + outspec[2] = (hex - 9) + 'A'; + } + *output_cnt = 3; + return 1; + } else if (*inspec == 0xA0) { + outspec[0] = '^'; + outspec[1] = 'A'; + outspec[2] = '0'; + *output_cnt = 3; + return 1; + } else if (*inspec == 0xFF) { + outspec[0] = '^'; + outspec[1] = 'F'; + outspec[2] = 'F'; + *output_cnt = 3; + return 1; + } + *outspec = *inspec; + *output_cnt = 1; + return 1; + } + + /* Is this a macro that needs to be passed through? + * Macros start with $( and an alpha character, followed + * by a string of alpha numeric characters ending with a ) + * If this does not match, then encode it as ODS-5. + */ + if ((inspec[0] == '$') && (inspec[1] == '(')) { + int tcnt; + + if (isalnum(inspec[2]) || (inspec[2] == '.') || (inspec[2] == '_')) { + tcnt = 3; + outspec[0] = inspec[0]; + outspec[1] = inspec[1]; + outspec[2] = inspec[2]; + + while(isalnum(inspec[tcnt]) || + (inspec[2] == '.') || (inspec[2] == '_')) { + outspec[tcnt] = inspec[tcnt]; + tcnt++; + } + if (inspec[tcnt] == ')') { + outspec[tcnt] = inspec[tcnt]; + tcnt++; + *output_cnt = tcnt; + return tcnt; + } + } + } + + switch (*inspec) { + case 0x7f: + outspec[0] = '^'; + outspec[1] = '7'; + outspec[2] = 'F'; + *output_cnt = 3; + return 1; + break; + case '?': + if (decc_efs_charset == 0) + outspec[0] = '%'; + else + outspec[0] = '?'; + *output_cnt = 1; + return 1; + break; + case '.': + case '~': + case '!': + case '#': + case '&': + case '\'': + case '`': + case '(': + case ')': + case '+': + case '@': + case '{': + case '}': + case ',': + case ';': + case '[': + case ']': + case '%': + case '^': + /* Don't escape again if following character is + * already something we escape. + */ + if (strchr(".~!#&\'`()+@{},;[]%^=_", *(inspec+1))) { + *outspec = *inspec; + *output_cnt = 1; + return 1; + break; + } + /* But otherwise fall through and escape it. */ + case '=': + /* Assume that this is to be escaped */ + outspec[0] = '^'; + outspec[1] = *inspec; + *output_cnt = 2; + return 1; + break; + case ' ': /* space */ + /* Assume that this is to be escaped */ + outspec[0] = '^'; + outspec[1] = '_'; + *output_cnt = 2; + return 1; + break; + default: + *outspec = *inspec; + *output_cnt = 1; + return 1; + break; + } +} + + /* This handles the expansion of a '^' prefix to the proper character * in a UNIX file specification. * @@ -287,19 +574,27 @@ int scnt; if (*inspec == '^') { inspec++; switch (*inspec) { + /* Spaces and non-trailing dots should just be passed through, + * but eat the escape character. + */ case '.': - /* Non trailing dots should just be passed through */ *outspec = *inspec; - count++; + count += 2; (*output_cnt)++; break; case '_': /* space */ *outspec = ' '; - inspec++; - count++; + count += 2; (*output_cnt)++; break; - case 'U': /* Unicode */ + case '^': + /* Hmm. Better leave the escape escaped. */ + outspec[0] = '^'; + outspec[1] = '^'; + count += 2; + (*output_cnt) += 2; + break; + case 'U': /* Unicode - FIX-ME this is wrong. */ inspec++; count++; scnt = strspn(inspec, "0123456789ABCDEFabcdef"); @@ -350,13 +645,15 @@ int scnt; return count; } - -int SYS$FILESCAN +#ifdef sys$filescan +#undef sys$filescan +int sys$filescan (const struct dsc$descriptor_s * srcstr, struct filescan_itmlst_2 * valuelist, unsigned long * fldflags, struct dsc$descriptor_s *auxout, unsigned short * retlen); +#endif /* vms_split_path - Verify that the input file specification is a * VMS format file specification, and provide pointers to the components of @@ -368,7 +665,7 @@ int SYS$FILESCAN * path. */ static int vms_split_path - (pTHX_ const char * path, + (const char * path, char * * volume, int * vol_len, char * * root, @@ -462,10 +759,10 @@ const int verspec = 7; item_list[8].length = 0; item_list[8].component = NULL; - status = SYS$FILESCAN + status = sys$filescan ((const struct dsc$descriptor_s *)&path_desc, item_list, &flags, NULL, NULL); - _ckvmssts(status); /* All failure status values indicate a coding error */ + _ckvmssts_noperl(status); /* All failure status values indicate a coding error */ /* If we parsed it successfully these two lengths should be the same */ if (path_desc.dsc$w_length != item_list[filespec].length) @@ -979,7 +1276,7 @@ prime_env_iter(void) for (i = 0; env_tables[i]; i++) { if (!have_sym && (tmpdsc.dsc$a_pointer = env_tables[i]->dsc$a_pointer) && !str$case_blind_compare(&tmpdsc,&clisym)) have_sym = 1; - if (!have_lnm && !str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1; + if (!have_lnm && str$case_blind_compare(env_tables[i],&crtlenv)) have_lnm = 1; } if (have_sym || have_lnm) { long int syiitm = SYI$_MAXBUF, dviitm = DVI$_DEVNAM; @@ -1097,8 +1394,9 @@ prime_env_iter(void) */ char lnm[LNM$C_NAMLENGTH+1]; char eqv[MAX_DCL_SYMBOL+1]; + int trnlen; strncpy(lnm, key, keylen); - int trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0); + trnlen = vmstrnenv(lnm, eqv, 0, fildev, 0); sv = newSVpvn(eqv, strlen(eqv)); } else { @@ -1288,7 +1586,7 @@ Perl_vmssetenv(pTHX_ const char *lnm, const char *eqv, struct dsc$descriptor_s * case LIB$_NOSUCHSYM: case SS$_NOLOGNAM: set_errno(EINVAL); break; case SS$_NOPRIV: - set_errno(EACCES); + set_errno(EACCES); break; default: _ckvmssts(retsts); set_errno(EVMSERR); @@ -1432,9 +1730,9 @@ Perl_my_crypt(pTHX_ const char *textpasswd, const char *usrname) /*}}}*/ -static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned); -static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int); -static char *mp_do_tovmsspec(pTHX_ const char *, char *, int); +static char *mp_do_rmsexpand(pTHX_ const char *, char *, int, const char *, unsigned, int *, int *); +static char *mp_do_fileify_dirspec(pTHX_ const char *, char *, int, int *); +static char *mp_do_tovmsspec(pTHX_ const char *, char *, int, int, int *); /* fixup barenames that are directories for internal use. * There have been problems with the consistent handling of UNIX @@ -1493,7 +1791,7 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) vmsname = PerlMem_malloc(NAM$C_MAXRSS+1); if (vmsname == NULL) _ckvmssts(SS$_INSFMEM); - if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) { + if (do_rmsexpand(name, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) { PerlMem_free(vmsname); return -1; } @@ -1506,7 +1804,7 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) else { rspec = PerlMem_malloc(NAM$C_MAXRSS+1); if (rspec == NULL) _ckvmssts(SS$_INSFMEM); - if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) { + if (do_rmsexpand(vmsname, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) { PerlMem_free(rspec); PerlMem_free(vmsname); return -1; @@ -1521,7 +1819,7 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) remove_name = PerlMem_malloc(NAM$C_MAXRSS+1); if (remove_name == NULL) _ckvmssts(SS$_INSFMEM); - do_pathify_dirspec(name, remove_name, 0); + do_pathify_dirspec(name, remove_name, 0, NULL); if (!rmdir(remove_name)) { PerlMem_free(remove_name); @@ -1591,7 +1889,7 @@ mp_do_kill_file(pTHX_ const char *name, int dirflag) remove_name = PerlMem_malloc(NAM$C_MAXRSS+1); if (remove_name == NULL) _ckvmssts(SS$_INSFMEM); - do_pathify_dirspec(name, remove_name, 0); + do_pathify_dirspec(name, remove_name, 0, NULL); rmsts = rmdir(remove_name); PerlMem_free(remove_name); } @@ -1644,7 +1942,7 @@ Perl_do_rmdir(pTHX_ const char *name) int retval; Stat_t st; - if (do_fileify_dirspec(name,dirfile,0) == NULL) return -1; + if (do_fileify_dirspec(name,dirfile,0,NULL) == NULL) return -1; if (flex_stat(dirfile,&st) || !S_ISDIR(st.st_mode)) retval = -1; else retval = mp_do_kill_file(aTHX_ dirfile, 1); return retval; @@ -1689,7 +1987,7 @@ Perl_kill_file(pTHX_ const char *name) /* Expand the input spec using RMS, since the CRTL remove() and * system services won't do this by themselves, so we may miss * a file "hiding" behind a logical name or search list. */ - tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS); + tspec = do_rmsexpand(name, rspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL); if (tspec == NULL) return -1; if (!remove(rspec)) return 0; /* Can we just get rid of it? */ /* If not, can changing protections help? */ @@ -1903,7 +2201,7 @@ Perl_my_sigaction (pTHX_ int sig, const struct sigaction* act, than signalling with an unrecognized (and unhandled by CRTL) code. */ -#define _MY_SIG_MAX 17 +#define _MY_SIG_MAX 28 static unsigned int Perl_sig_to_vmscondition_int(int sig) @@ -1931,7 +2229,18 @@ Perl_sig_to_vmscondition_int(int sig) SS$_ASTFLT, /* 14 SIGALRM */ 4, /* 15 SIGTERM */ 0, /* 16 SIGUSR1 */ - 0 /* 17 SIGUSR2 */ + 0, /* 17 SIGUSR2 */ + 0, /* 18 */ + 0, /* 19 */ + 0, /* 20 SIGCHLD */ + 0, /* 21 SIGCONT */ + 0, /* 22 SIGSTOP */ + 0, /* 23 SIGTSTP */ + 0, /* 24 SIGTTIN */ + 0, /* 25 SIGTTOU */ + 0, /* 26 */ + 0, /* 27 */ + 0 /* 28 SIGWINCH */ }; #if __VMS_VER >= 60200000 @@ -1940,6 +2249,12 @@ Perl_sig_to_vmscondition_int(int sig) initted = 1; sig_code[16] = C$_SIGUSR1; sig_code[17] = C$_SIGUSR2; +#if __CRTL_VER >= 70000000 + sig_code[20] = C$_SIGCHLD; +#endif +#if __CRTL_VER >= 70300000 + sig_code[28] = C$_SIGWINCH; +#endif } #endif @@ -2481,6 +2796,8 @@ struct pipe_details int in_done; /* true when in pipe finished */ int out_done; int err_done; + unsigned short xchan; /* channel to debug xterm */ + unsigned short xchan_valid; /* channel is assigned */ }; struct exit_control_block @@ -2525,14 +2842,20 @@ pipe_exit_routine(pTHX) unsigned long int retsts = SS$_NORMAL, abort = SS$_TIMEOUT; int sts, did_stuff, need_eof, j; - /* - flush any pending i/o + /* + * Flush any pending i/o, but since we are in process run-down, be + * careful about referencing PerlIO structures that may already have + * been deallocated. We may not even have an interpreter anymore. */ info = open_pipes; while (info) { if (info->fp) { - if (!info->useFILE) - PerlIO_flush(info->fp); /* first, flush data */ + if (!info->useFILE +#if defined(USE_ITHREADS) + && my_perl +#endif + && PL_perlio_fd_refcnt) + PerlIO_flush(info->fp); else fflush((FILE *)info->fp); } @@ -2614,6 +2937,7 @@ pipe_exit_routine(pTHX) if (!info->done) { /* We tried to be nice . . . */ sts = sys$delprc(&info->pid,0); if (!(sts&1) && sts != SS$_NONEXPR) _ckvmssts_noperl(sts); + info->done = 1; /* sys$delprc is as done as we're going to get. */ } _ckvmssts_noperl(sys$setast(1)); info = info->next; @@ -3068,14 +3392,43 @@ pipe_mbxtofd_setup(pTHX_ int fd, char *out) /* things like terminals and mbx's don't need this filter */ if (fd && fstat(fd,&s) == 0) { unsigned long dviitm = DVI$_DEVCHAR, devchar; - struct dsc$descriptor_s d_dev = {strlen(s.st_dev), DSC$K_DTYPE_T, - DSC$K_CLASS_S, s.st_dev}; - - _ckvmssts(lib$getdvi(&dviitm,0,&d_dev,&devchar,0,0)); - if (!(devchar & DEV$M_DIR)) { /* non directory structured...*/ - strcpy(out, s.st_dev); - return 0; - } + char device[65]; + unsigned short dev_len; + struct dsc$descriptor_s d_dev; + char * cptr; + struct item_list_3 items[3]; + int status; + unsigned short dvi_iosb[4]; + + cptr = getname(fd, out, 1); + if (cptr == NULL) _ckvmssts(SS$_NOSUCHDEV); + d_dev.dsc$a_pointer = out; + d_dev.dsc$w_length = strlen(out); + d_dev.dsc$b_dtype = DSC$K_DTYPE_T; + d_dev.dsc$b_class = DSC$K_CLASS_S; + + items[0].len = 4; + items[0].code = DVI$_DEVCHAR; + items[0].bufadr = &devchar; + items[0].retadr = NULL; + items[1].len = 64; + items[1].code = DVI$_FULLDEVNAM; + items[1].bufadr = device; + items[1].retadr = &dev_len; + items[2].len = 0; + items[2].code = 0; + + status = sys$getdviw + (NO_EFN, 0, &d_dev, items, dvi_iosb, NULL, NULL, NULL); + _ckvmssts(status); + if ($VMS_STATUS_SUCCESS(dvi_iosb[0])) { + device[dev_len] = 0; + + if (!(devchar & DEV$M_DIR)) { + strcpy(out, device); + return 0; + } + } } _ckvmssts(lib$get_vm(&n, &p)); @@ -3216,7 +3569,7 @@ store_pipelocs(pTHX) temp[1] = '\0'; } - if ((tounixpath(temp, unixdir)) != Nullch) { + if ((tounixpath_utf8(temp, unixdir, NULL)) != Nullch) { p = (pPLOC) PerlMem_malloc(sizeof(PLOC)); if (p == NULL) _ckvmssts(SS$_INSFMEM); p->next = head_PLOC; @@ -3239,7 +3592,7 @@ store_pipelocs(pTHX) if (SvROK(dirsv)) continue; dir = SvPVx(dirsv,n_a); if (strcmp(dir,".") == 0) continue; - if ((tounixpath(dir, unixdir)) == Nullch) + if ((tounixpath_utf8(dir, unixdir, NULL)) == Nullch) continue; p = (pPLOC) PerlMem_malloc(sizeof(PLOC)); @@ -3252,7 +3605,7 @@ store_pipelocs(pTHX) /* most likely spot (ARCHLIB) put first in the list */ #ifdef ARCHLIB_EXP - if ((tounixpath(ARCHLIB_EXP, unixdir)) != Nullch) { + if ((tounixpath_utf8(ARCHLIB_EXP, unixdir, NULL)) != Nullch) { p = (pPLOC) PerlMem_malloc(sizeof(PLOC)); if (p == NULL) _ckvmssts(SS$_INSFMEM); p->next = head_PLOC; @@ -3264,6 +3617,14 @@ store_pipelocs(pTHX) PerlMem_free(unixdir); } +static I32 +Perl_cando_by_name_int + (pTHX_ I32 bit, bool effective, const char *fname, int opts); +#if !defined(PERL_IMPLICIT_CONTEXT) +#define cando_by_name_int Perl_cando_by_name_int +#else +#define cando_by_name_int(a,b,c,d) Perl_cando_by_name_int(aTHX_ a,b,c,d) +#endif static char * find_vmspipe(pTHX) @@ -3274,8 +3635,9 @@ find_vmspipe(pTHX) /* already found? Check and use ... need read+execute permission */ if (vmspipe_file_status == 1) { - if (cando_by_name(S_IRUSR, 0, vmspipe_file) - && cando_by_name(S_IXUSR, 0, vmspipe_file)) { + if (cando_by_name_int(S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN) + && cando_by_name_int + (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) { return vmspipe_file; } vmspipe_file_status = 0; @@ -3297,11 +3659,13 @@ find_vmspipe(pTHX) p = p->next; exp_res = do_rmsexpand - (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS); + (file, vmspipe_file, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL); if (!exp_res) continue; - if (cando_by_name(S_IRUSR, 0, vmspipe_file) - && cando_by_name(S_IXUSR, 0, vmspipe_file)) { + if (cando_by_name_int + (S_IRUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN) + && cando_by_name_int + (S_IXUSR, 0, vmspipe_file, PERL_RMSEXPAND_M_VMS_IN)) { vmspipe_file_status = 1; return vmspipe_file; } @@ -3390,7 +3754,7 @@ vmspipe_tempfile(pTHX) fclose(fp); if (decc_filename_unix_only) - do_tounixspec(file, file, 0); + do_tounixspec(file, file, 0, NULL); fp = fopen(file,"r","shr=get"); if (!fp) return 0; fstat(fileno(fp), (struct stat *)&s1); @@ -3405,6 +3769,234 @@ vmspipe_tempfile(pTHX) } +#ifdef USE_VMS_DECTERM + +static int vms_is_syscommand_xterm(void) +{ + const static struct dsc$descriptor_s syscommand_dsc = + { 11, DSC$K_DTYPE_T, DSC$K_CLASS_S, "SYS$COMMAND" }; + + const static struct dsc$descriptor_s decwdisplay_dsc = + { 12, DSC$K_DTYPE_T, DSC$K_CLASS_S, "DECW$DISPLAY" }; + + struct item_list_3 items[2]; + unsigned short dvi_iosb[4]; + unsigned long devchar; + unsigned long devclass; + int status; + + /* Very simple check to guess if sys$command is a decterm? */ + /* First see if the DECW$DISPLAY: device exists */ + items[0].len = 4; + items[0].code = DVI$_DEVCHAR; + items[0].bufadr = &devchar; + items[0].retadr = NULL; + items[1].len = 0; + items[1].code = 0; + + status = sys$getdviw + (NO_EFN, 0, &decwdisplay_dsc, items, dvi_iosb, NULL, NULL, NULL); + + if ($VMS_STATUS_SUCCESS(status)) { + status = dvi_iosb[0]; + } + + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return -1; + } + + /* If it does, then for now assume that we are on a workstation */ + /* Now verify that SYS$COMMAND is a terminal */ + /* for creating the debugger DECTerm */ + + items[0].len = 4; + items[0].code = DVI$_DEVCLASS; + items[0].bufadr = &devclass; + items[0].retadr = NULL; + items[1].len = 0; + items[1].code = 0; + + status = sys$getdviw + (NO_EFN, 0, &syscommand_dsc, items, dvi_iosb, NULL, NULL, NULL); + + if ($VMS_STATUS_SUCCESS(status)) { + status = dvi_iosb[0]; + } + + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return -1; + } + else { + if (devclass == DC$_TERM) { + return 0; + } + } + return -1; +} + +/* If we are on a DECTerm, we can pretend to fork xterms when requested */ +static PerlIO * create_forked_xterm(pTHX_ const char *cmd, const char *mode) +{ + int status; + int ret_stat; + char * ret_char; + char device_name[65]; + unsigned short device_name_len; + struct dsc$descriptor_s customization_dsc; + struct dsc$descriptor_s device_name_dsc; + const char * cptr; + char * tptr; + char customization[200]; + char title[40]; + pInfo info = NULL; + char mbx1[64]; + unsigned short p_chan; + int n; + unsigned short iosb[4]; + struct item_list_3 items[2]; + const char * cust_str = + "DECW$TERMINAL.iconName:\tPerl Dbg\nDECW$TERMINAL.title:\t%40s\n"; + struct dsc$descriptor_s d_mbx1 = {sizeof mbx1, DSC$K_DTYPE_T, + DSC$K_CLASS_S, mbx1}; + + ret_char = strstr(cmd," xterm "); + if (ret_char == NULL) + return NULL; + cptr = ret_char + 7; + ret_char = strstr(cmd,"tty"); + if (ret_char == NULL) + return NULL; + ret_char = strstr(cmd,"sleep"); + if (ret_char == NULL) + return NULL; + + /* Are we on a workstation? */ + /* to do: capture the rows / columns and pass their properties */ + ret_stat = vms_is_syscommand_xterm(); + if (ret_stat < 0) + return NULL; + + /* Make the title: */ + ret_char = strstr(cptr,"-title"); + if (ret_char != NULL) { + while ((*cptr != 0) && (*cptr != '\"')) { + cptr++; + } + if (*cptr == '\"') + cptr++; + n = 0; + while ((*cptr != 0) && (*cptr != '\"')) { + title[n] = *cptr; + n++; + if (n == 39) { + title[39] == 0; + break; + } + cptr++; + } + title[n] = 0; + } + else { + /* Default title */ + strcpy(title,"Perl Debug DECTerm"); + } + sprintf(customization, cust_str, title); + + customization_dsc.dsc$a_pointer = customization; + customization_dsc.dsc$w_length = strlen(customization); + customization_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + customization_dsc.dsc$b_class = DSC$K_CLASS_S; + + device_name_dsc.dsc$a_pointer = device_name; + device_name_dsc.dsc$w_length = sizeof device_name -1; + device_name_dsc.dsc$b_dtype = DSC$K_DTYPE_T; + device_name_dsc.dsc$b_class = DSC$K_CLASS_S; + + device_name_len = 0; + + /* Try to create the window */ + status = decw$term_port + (NULL, + NULL, + &customization_dsc, + &device_name_dsc, + &device_name_len, + NULL, + NULL, + NULL); + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return NULL; + } + + device_name[device_name_len] = '\0'; + + /* Need to set this up to look like a pipe for cleanup */ + n = sizeof(Info); + status = lib$get_vm(&n, &info); + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(ENOMEM, status); + return NULL; + } + + info->mode = *mode; + info->done = FALSE; + info->completion = 0; + info->closing = FALSE; + info->in = 0; + info->out = 0; + info->err = 0; + info->fp = Nullfp; + info->useFILE = 0; + info->waiting = 0; + info->in_done = TRUE; + info->out_done = TRUE; + info->err_done = TRUE; + + /* Assign a channel on this so that it will persist, and not login */ + /* We stash this channel in the info structure for reference. */ + /* The created xterm self destructs when the last channel is removed */ + /* and it appears that perl5db.pl (perl debugger) does this routinely */ + /* So leave this assigned. */ + device_name_dsc.dsc$w_length = device_name_len; + status = sys$assign(&device_name_dsc,&info->xchan,0,0); + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return NULL; + } + info->xchan_valid = 1; + + /* Now create a mailbox to be read by the application */ + + create_mbx(aTHX_ &p_chan, &d_mbx1); + + /* write the name of the created terminal to the mailbox */ + status = sys$qiow(NO_EFN, p_chan, IO$_WRITEVBLK|IO$M_NOW, + iosb, NULL, NULL, device_name, device_name_len, 0, 0, 0, 0); + + if (!$VMS_STATUS_SUCCESS(status)) { + SETERRNO(EVMSERR, status); + return NULL; + } + + info->fp = PerlIO_open(mbx1, mode); + + /* Done with this channel */ + sys$dassgn(p_chan); + + /* If any errors, then clean up */ + if (!info->fp) { + n = sizeof(Info); + _ckvmssts(lib$free_vm(&n, &info)); + return NULL; + } + + /* All done */ + return info->fp; +} +#endif static PerlIO * safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) @@ -3418,7 +4010,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) unsigned int table = LIB$K_CLI_LOCAL_SYM; int j, wait = 0, n; char *p, mode[10], symbol[MAX_DCL_SYMBOL+1], *vmspipe; - char in[512], out[512], err[512], mbx[512]; + char *in, *out, *err, mbx[512]; FILE *tpipe = 0; char tfilebuf[NAM$C_MAXRSS+1]; pInfo info = NULL; @@ -3433,7 +4025,21 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) $DESCRIPTOR(d_sym_in ,"PERL_POPEN_IN"); $DESCRIPTOR(d_sym_out,"PERL_POPEN_OUT"); $DESCRIPTOR(d_sym_err,"PERL_POPEN_ERR"); - + +#ifdef USE_VMS_DECTERM + /* Check here for Xterm create request. This means looking for + * "3>&1 xterm\b" and "\btty 1>&3\b$" in the command, and that it + * is possible to create an xterm. + */ + if (*in_mode == 'r') { + PerlIO * xterm_fd; + + xterm_fd = create_forked_xterm(aTHX_ cmd, in_mode); + if (xterm_fd != Nullfp) + return xterm_fd; + } +#endif + if (!head_PLOC) store_pipelocs(aTHX); /* at least TRY to use a static vmspipe file */ /* once-per-program initialization... @@ -3502,7 +4108,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) set_errno(EVMSERR); } set_vaxc_errno(sts); - if (*mode != 'n' && ckWARN(WARN_PIPE)) { + if (*in_mode != 'n' && ckWARN(WARN_PIPE)) { Perl_warner(aTHX_ packWARN(WARN_PIPE),"Can't pipe \"%*s\": %s", strlen(cmd), cmd, Strerror(errno)); } *psts = sts; @@ -3525,6 +4131,16 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) info->in_done = TRUE; info->out_done = TRUE; info->err_done = TRUE; + info->xchan = 0; + info->xchan_valid = 0; + + in = PerlMem_malloc(VMS_MAXRSS); + if (in == NULL) _ckvmssts(SS$_INSFMEM); + out = PerlMem_malloc(VMS_MAXRSS); + if (out == NULL) _ckvmssts(SS$_INSFMEM); + err = PerlMem_malloc(VMS_MAXRSS); + if (err == NULL) _ckvmssts(SS$_INSFMEM); + in[0] = out[0] = err[0] = '\0'; if ((p = strchr(mode,'F')) != NULL) { /* F -> use FILE* */ @@ -3545,7 +4161,7 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) info->out->info = info; } if (!info->useFILE) { - info->fp = PerlIO_open(mbx, mode); + info->fp = PerlIO_open(mbx, mode); } else { info->fp = (PerlIO *) freopen(mbx, mode, stdin); Perl_vmssetuserlnm(aTHX_ "SYS$INPUT",mbx); @@ -3670,6 +4286,11 @@ safe_popen(pTHX_ const char *cmd, const char *in_mode, int *psts) d_symbol.dsc$w_length = strlen(symbol); _ckvmssts(lib$set_symbol(&d_sym_out, &d_symbol, &table)); + /* Done with the names for the pipes */ + PerlMem_free(err); + PerlMem_free(out); + PerlMem_free(in); + p = vmscmd->dsc$a_pointer; while (*p == ' ' || *p == '\t') p++; /* remove leading whitespace */ if (*p == '$') p++; /* remove leading $ */ @@ -3762,6 +4383,7 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp) pInfo info, last = NULL; unsigned long int retsts; int done, iss, n; + int status; for (info = open_pipes; info != NULL; last = info, info = info->next) if (info->fp == fp) break; @@ -3780,8 +4402,12 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp) * the first EOF closing the pipe (and DASSGN'ing the channel)... */ if (info->fp) { - if (!info->useFILE) - PerlIO_flush(info->fp); /* first, flush data */ + if (!info->useFILE +#if defined(USE_ITHREADS) + && my_perl +#endif + && PL_perlio_fd_refcnt) + PerlIO_flush(info->fp); else fflush((FILE *)info->fp); } @@ -3803,7 +4429,11 @@ I32 Perl_my_pclose(pTHX_ PerlIO *fp) 0, 0, 0, 0, 0, 0)); _ckvmssts(sys$setast(1)); if (info->fp) { - if (!info->useFILE) + if (!info->useFILE +#if defined(USE_ITHREADS) + && my_perl +#endif + && PL_perlio_fd_refcnt) PerlIO_close(info->fp); else fclose((FILE *)info->fp); @@ -4056,20 +4686,21 @@ struct NAM * nam; #define rms_nam_rsl(nam) nam.nam$b_rsl #define rms_bind_fab_nam(fab, nam) fab.fab$l_nam = &nam #define rms_set_fna(fab, nam, name, size) \ - fab.fab$b_fns = size; fab.fab$l_fna = name; + { fab.fab$b_fns = size; fab.fab$l_fna = name; } #define rms_get_fna(fab, nam) fab.fab$l_fna #define rms_set_dna(fab, nam, name, size) \ - fab.fab$b_dns = size; fab.fab$l_dna = name; -#define rms_nam_dns(fab, nam) fab.fab$b_dns; + { fab.fab$b_dns = size; fab.fab$l_dna = name; } +#define rms_nam_dns(fab, nam) fab.fab$b_dns #define rms_set_esa(fab, nam, name, size) \ - nam.nam$b_ess = size; nam.nam$l_esa = name; + { nam.nam$b_ess = size; nam.nam$l_esa = name; } #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \ - nam.nam$l_esa = s_name; nam.nam$b_ess = s_size; + { nam.nam$l_esa = s_name; nam.nam$b_ess = s_size;} #define rms_set_rsa(nam, name, size) \ - nam.nam$l_rsa = name; nam.nam$b_rss = size; + { nam.nam$l_rsa = name; nam.nam$b_rss = size; } #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \ - nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; - + { nam.nam$l_rsa = s_name; nam.nam$b_rss = s_size; } +#define rms_nam_name_type_l_size(nam) \ + (nam.nam$b_name + nam.nam$b_type) #else static int rms_free_search_context(struct FAB * fab) { @@ -4101,32 +4732,33 @@ struct NAML * nam; #define rms_nam_rsl(nam) nam.naml$b_rsl #define rms_bind_fab_nam(fab, nam) fab.fab$l_naml = &nam #define rms_set_fna(fab, nam, name, size) \ - fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \ + { fab.fab$b_fns = 0; fab.fab$l_fna = (char *) -1; \ nam.naml$l_long_filename_size = size; \ - nam.naml$l_long_filename = name + nam.naml$l_long_filename = name;} #define rms_get_fna(fab, nam) nam.naml$l_long_filename #define rms_set_dna(fab, nam, name, size) \ - fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \ + { fab.fab$b_dns = 0; fab.fab$l_dna = (char *) -1; \ nam.naml$l_long_defname_size = size; \ - nam.naml$l_long_defname = name + nam.naml$l_long_defname = name; } #define rms_nam_dns(fab, nam) nam.naml$l_long_defname_size #define rms_set_esa(fab, nam, name, size) \ - nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \ + { nam.naml$b_ess = 0; nam.naml$l_esa = (char *) -1; \ nam.naml$l_long_expand_alloc = size; \ - nam.naml$l_long_expand = name + nam.naml$l_long_expand = name; } #define rms_set_esal(nam, s_name, s_size, l_name, l_size) \ - nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \ + { nam.naml$l_esa = s_name; nam.naml$b_ess = s_size; \ nam.naml$l_long_expand = l_name; \ - nam.naml$l_long_expand_alloc = l_size; + nam.naml$l_long_expand_alloc = l_size; } #define rms_set_rsa(nam, name, size) \ - nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \ + { nam.naml$l_rsa = NULL; nam.naml$b_rss = 0; \ nam.naml$l_long_result = name; \ - nam.naml$l_long_result_alloc = size; + nam.naml$l_long_result_alloc = size; } #define rms_set_rsal(nam, s_name, s_size, l_name, l_size) \ - nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \ + { nam.naml$l_rsa = s_name; nam.naml$b_rss = s_size; \ nam.naml$l_long_result = l_name; \ - nam.naml$l_long_result_alloc = l_size; - + nam.naml$l_long_result_alloc = l_size; } +#define rms_nam_name_type_l_size(nam) \ + (nam.naml$l_long_name_size + nam.naml$l_long_type_size) #endif @@ -4144,234 +4776,72 @@ struct NAML * nam; * * New functionality for previously unused opts value: * PERL_RMSEXPAND_M_VMS - Force output file specification to VMS format. + * PERL_RMSEXPAND_M_LONG - Want output in long formst + * PERL_RMSEXPAND_M_VMS_IN - Input is already in VMS, so do not vmsify */ -static char *mp_do_tounixspec(pTHX_ const char *, char *, int); +static char *mp_do_tounixspec(pTHX_ const char *, char *, int, int *); -#if defined(__VAX) || !defined(NAML$C_MAXRSS) -/* ODS-2 only version */ static char * -mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts) -{ - static char __rmsexpand_retbuf[NAM$C_MAXRSS+1]; - char vmsfspec[NAM$C_MAXRSS+1], tmpfspec[NAM$C_MAXRSS+1]; - char esa[NAM$C_MAXRSS+1], *cp, *out = NULL; +mp_do_rmsexpand + (pTHX_ const char *filespec, + char *outbuf, + int ts, + const char *defspec, + unsigned opts, + int * fs_utf8, + int * dfs_utf8) +{ + static char __rmsexpand_retbuf[VMS_MAXRSS]; + char * vmsfspec, *tmpfspec; + char * esa, *cp, *out = NULL; + char * tbuf; + char * esal = NULL; + char * outbufl; struct FAB myfab = cc$rms_fab; - struct NAM mynam = cc$rms_nam; + rms_setup_nam(mynam); STRLEN speclen; unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; int sts; + /* temp hack until UTF8 is actually implemented */ + if (fs_utf8 != NULL) + *fs_utf8 = 0; + if (!filespec || !*filespec) { set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); return NULL; } if (!outbuf) { - if (ts) out = Newx(outbuf,NAM$C_MAXRSS+1,char); + if (ts) out = Newx(outbuf,VMS_MAXRSS,char); else outbuf = __rmsexpand_retbuf; } - isunix = is_unix_filespec(filespec); - if (isunix) { - if (do_tovmsspec(filespec,vmsfspec,0) == NULL) { - if (out) - Safefree(out); - return NULL; - } - filespec = vmsfspec; - } - myfab.fab$l_fna = (char *)filespec; /* cast ok for read only pointer */ - myfab.fab$b_fns = strlen(filespec); - myfab.fab$l_nam = &mynam; + vmsfspec = NULL; + tmpfspec = NULL; + outbufl = NULL; - if (defspec && *defspec) { - if (strchr(defspec,'/') != NULL) { - if (do_tovmsspec(defspec,tmpfspec,0) == NULL) { + isunix = 0; + if ((opts & PERL_RMSEXPAND_M_VMS_IN) == 0) { + isunix = is_unix_filespec(filespec); + if (isunix) { + vmsfspec = PerlMem_malloc(VMS_MAXRSS); + if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM); + if (do_tovmsspec(filespec,vmsfspec,0,fs_utf8) == NULL) { + PerlMem_free(vmsfspec); if (out) Safefree(out); return NULL; } - defspec = tmpfspec; - } - myfab.fab$l_dna = (char *)defspec; /* cast ok for read only pointer */ - myfab.fab$b_dns = strlen(defspec); - } + filespec = vmsfspec; - mynam.nam$l_esa = esa; - mynam.nam$b_ess = NAM$C_MAXRSS; - mynam.nam$l_rsa = outbuf; - mynam.nam$b_rss = NAM$C_MAXRSS; - -#ifdef NAM$M_NO_SHORT_UPCASE - if (decc_efs_case_preserve) - mynam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; -#endif - - retsts = sys$parse(&myfab,0,0); - if (!(retsts & 1)) { - mynam.nam$b_nop |= NAM$M_SYNCHK; - if (retsts == RMS$_DNF || retsts == RMS$_DIR || retsts == RMS$_DEV) { - retsts = sys$parse(&myfab,0,0); - if (retsts & 1) goto expanded; - } - mynam.nam$l_rlf = NULL; myfab.fab$b_dns = 0; - sts = sys$parse(&myfab,0,0); /* Free search context */ - if (out) Safefree(out); - set_vaxc_errno(retsts); - if (retsts == RMS$_PRV) set_errno(EACCES); - else if (retsts == RMS$_DEV) set_errno(ENODEV); - else if (retsts == RMS$_DIR) set_errno(ENOTDIR); - else set_errno(EVMSERR); - return NULL; - } - retsts = sys$search(&myfab,0,0); - if (!(retsts & 1) && retsts != RMS$_FNF) { - mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; - myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */ - if (out) Safefree(out); - set_vaxc_errno(retsts); - if (retsts == RMS$_PRV) set_errno(EACCES); - else set_errno(EVMSERR); - return NULL; - } - - /* If the input filespec contained any lowercase characters, - * downcase the result for compatibility with Unix-minded code. */ - expanded: - if (!decc_efs_case_preserve) { - for (out = myfab.fab$l_fna; *out; out++) - if (islower(*out)) { haslower = 1; break; } - } - if (mynam.nam$b_rsl) { out = outbuf; speclen = mynam.nam$b_rsl; } - else { out = esa; speclen = mynam.nam$b_esl; } - out[speclen] = 0; - /* Trim off null fields added by $PARSE - * If type > 1 char, must have been specified in original or default spec - * (not true for version; $SEARCH may have added version of existing file). - */ - trimver = !(mynam.nam$l_fnb & NAM$M_EXP_VER); - trimtype = !(mynam.nam$l_fnb & NAM$M_EXP_TYPE) && - (mynam.nam$l_ver - mynam.nam$l_type == 1); - if (trimver || trimtype) { - if (defspec && *defspec) { - char defesa[NAM$C_MAXRSS]; - struct FAB deffab = cc$rms_fab; - struct NAM defnam = cc$rms_nam; - - deffab.fab$l_nam = &defnam; - /* cast below ok for read only pointer */ - deffab.fab$l_fna = (char *)defspec; deffab.fab$b_fns = myfab.fab$b_dns; - defnam.nam$l_esa = defesa; defnam.nam$b_ess = NAM$C_MAXRSS; - defnam.nam$b_nop = NAM$M_SYNCHK; -#ifdef NAM$M_NO_SHORT_UPCASE - if (decc_efs_case_preserve) - defnam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; -#endif - if (sys$parse(&deffab,0,0) & 1) { - if (trimver) trimver = !(defnam.nam$l_fnb & NAM$M_EXP_VER); - if (trimtype) trimtype = !(defnam.nam$l_fnb & NAM$M_EXP_TYPE); - } - } - if (trimver) { - if (*mynam.nam$l_ver != '\"') - speclen = mynam.nam$l_ver - out; - } - if (trimtype) { - /* If we didn't already trim version, copy down */ - if (speclen > mynam.nam$l_ver - out) - memmove(mynam.nam$l_type, mynam.nam$l_ver, - speclen - (mynam.nam$l_ver - out)); - speclen -= mynam.nam$l_ver - mynam.nam$l_type; - } - } - /* If we just had a directory spec on input, $PARSE "helpfully" - * adds an empty name and type for us */ - if (mynam.nam$l_name == mynam.nam$l_type && - mynam.nam$l_ver == mynam.nam$l_type + 1 && - !(mynam.nam$l_fnb & NAM$M_EXP_NAME)) - speclen = mynam.nam$l_name - out; - - /* Posix format specifications must have matching quotes */ - if (speclen < NAM$C_MAXRSS) { - if (decc_posix_compliant_pathnames && (out[0] == '\"')) { - if ((speclen > 1) && (out[speclen-1] != '\"')) { - out[speclen] = '\"'; - speclen++; - } - } - } - - out[speclen] = '\0'; - if (haslower && !decc_efs_case_preserve) __mystrtolower(out); - - /* Have we been working with an expanded, but not resultant, spec? */ - /* Also, convert back to Unix syntax if necessary. */ - if ((opts & PERL_RMSEXPAND_M_VMS) != 0) - isunix = 0; - - if (!mynam.nam$b_rsl) { - if (isunix) { - if (do_tounixspec(esa,outbuf,0) == NULL) return NULL; - } - else strcpy(outbuf,esa); - } - else if (isunix) { - if (do_tounixspec(outbuf,tmpfspec,0) == NULL) return NULL; - strcpy(outbuf,tmpfspec); - } - mynam.nam$b_nop |= NAM$M_SYNCHK; mynam.nam$l_rlf = NULL; - mynam.nam$l_rsa = NULL; - mynam.nam$b_rss = 0; - myfab.fab$b_dns = 0; sts = sys$parse(&myfab,0,0); /* Free search context */ - return outbuf; -} -#else -/* ODS-5 supporting routine */ -static char * -mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *defspec, unsigned opts) -{ - static char __rmsexpand_retbuf[NAML$C_MAXRSS+1]; - char * vmsfspec, *tmpfspec; - char * esa, *cp, *out = NULL; - char * tbuf; - char * esal; - char * outbufl; - struct FAB myfab = cc$rms_fab; - rms_setup_nam(mynam); - STRLEN speclen; - unsigned long int retsts, trimver, trimtype, haslower = 0, isunix = 0; - int sts; - - if (!filespec || !*filespec) { - set_vaxc_errno(LIB$_INVARG); set_errno(EINVAL); - return NULL; - } - if (!outbuf) { - if (ts) out = Newx(outbuf,VMS_MAXRSS,char); - else outbuf = __rmsexpand_retbuf; - } - - vmsfspec = NULL; - tmpfspec = NULL; - outbufl = NULL; - isunix = is_unix_filespec(filespec); - if (isunix) { - vmsfspec = PerlMem_malloc(VMS_MAXRSS); - if (vmsfspec == NULL) _ckvmssts(SS$_INSFMEM); - if (do_tovmsspec(filespec,vmsfspec,0) == NULL) { - PerlMem_free(vmsfspec); - if (out) - Safefree(out); - return NULL; - } - filespec = vmsfspec; - - /* Unless we are forcing to VMS format, a UNIX input means - * UNIX output, and that requires long names to be used - */ - if ((opts & PERL_RMSEXPAND_M_VMS) == 0) + /* Unless we are forcing to VMS format, a UNIX input means + * UNIX output, and that requires long names to be used + */ + if ((opts & PERL_RMSEXPAND_M_VMS) == 0) opts |= PERL_RMSEXPAND_M_LONG; - else { + else { isunix = 0; + } } } @@ -4384,7 +4854,7 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de if (t_isunix) { tmpfspec = PerlMem_malloc(VMS_MAXRSS); if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM); - if (do_tovmsspec(defspec,tmpfspec,0) == NULL) { + if (do_tovmsspec(defspec,tmpfspec,0,dfs_utf8) == NULL) { PerlMem_free(tmpfspec); if (vmsfspec != NULL) PerlMem_free(vmsfspec); @@ -4400,10 +4870,10 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de esa = PerlMem_malloc(NAM$C_MAXRSS + 1); if (esa == NULL) _ckvmssts(SS$_INSFMEM); #if !defined(__VAX) && defined(NAML$C_MAXRSS) - esal = PerlMem_malloc(NAML$C_MAXRSS + 1); + esal = PerlMem_malloc(VMS_MAXRSS); if (esal == NULL) _ckvmssts(SS$_INSFMEM); #endif - rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, NAML$C_MAXRSS); + rms_set_esal(mynam, esa, NAM$C_MAXRSS, esal, VMS_MAXRSS-1); if ((opts & PERL_RMSEXPAND_M_LONG) != 0) { rms_set_rsa(mynam, outbuf, (VMS_MAXRSS - 1)); @@ -4445,7 +4915,8 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de if (outbufl != NULL) PerlMem_free(outbufl); PerlMem_free(esa); - PerlMem_free(esal); + if (esal != NULL) + PerlMem_free(esal); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); else if (retsts == RMS$_DEV) set_errno(ENODEV); @@ -4464,7 +4935,8 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de if (outbufl != NULL) PerlMem_free(outbufl); PerlMem_free(esa); - PerlMem_free(esal); + if (esal != NULL) + PerlMem_free(esal); set_vaxc_errno(retsts); if (retsts == RMS$_PRV) set_errno(EACCES); else set_errno(EVMSERR); @@ -4519,7 +4991,7 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de if (trimver || trimtype) { if (defspec && *defspec) { char *defesal = NULL; - defesal = PerlMem_malloc(NAML$C_MAXRSS + 1); + defesal = PerlMem_malloc(VMS_MAXRSS + 1); if (defesal != NULL) { struct FAB deffab = cc$rms_fab; rms_setup_nam(defnam); @@ -4619,9 +5091,10 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de if (!rms_nam_rsll(mynam)) { if (isunix) { - if (do_tounixspec(esa,outbuf,0) == NULL) { + if (do_tounixspec(esa,outbuf,0,fs_utf8) == NULL) { if (out) Safefree(out); - PerlMem_free(esal); + if (esal != NULL) + PerlMem_free(esal); PerlMem_free(esa); if (outbufl != NULL) PerlMem_free(outbufl); @@ -4633,10 +5106,11 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de else if (isunix) { tmpfspec = PerlMem_malloc(VMS_MAXRSS); if (tmpfspec == NULL) _ckvmssts(SS$_INSFMEM); - if (do_tounixspec(outbuf,tmpfspec,0) == NULL) { + if (do_tounixspec(outbuf,tmpfspec,0,fs_utf8) == NULL) { if (out) Safefree(out); PerlMem_free(esa); - PerlMem_free(esal); + if (esal != NULL) + PerlMem_free(esal); PerlMem_free(tmpfspec); if (outbufl != NULL) PerlMem_free(outbufl); @@ -4649,18 +5123,26 @@ mp_do_rmsexpand(pTHX_ const char *filespec, char *outbuf, int ts, const char *de rms_set_rsal(mynam, NULL, 0, NULL, 0); sts = rms_free_search_context(&myfab); /* Free search context */ PerlMem_free(esa); - PerlMem_free(esal); + if (esal != NULL) + PerlMem_free(esal); if (outbufl != NULL) PerlMem_free(outbufl); return outbuf; } -#endif /*}}}*/ /* External entry points */ char *Perl_rmsexpand(pTHX_ const char *spec, char *buf, const char *def, unsigned opt) -{ return do_rmsexpand(spec,buf,0,def,opt); } +{ return do_rmsexpand(spec,buf,0,def,opt,NULL,NULL); } char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsigned opt) -{ return do_rmsexpand(spec,buf,1,def,opt); } +{ return do_rmsexpand(spec,buf,1,def,opt,NULL,NULL); } +char *Perl_rmsexpand_utf8 + (pTHX_ const char *spec, char *buf, const char *def, + unsigned opt, int * fs_utf8, int * dfs_utf8) +{ return do_rmsexpand(spec,buf,0,def,opt, fs_utf8, dfs_utf8); } +char *Perl_rmsexpand_utf8_ts + (pTHX_ const char *spec, char *buf, const char *def, + unsigned opt, int * fs_utf8, int * dfs_utf8) +{ return do_rmsexpand(spec,buf,1,def,opt, fs_utf8, dfs_utf8); } /* @@ -4689,6 +5171,7 @@ char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsi ** tovmspath() - convert a directory spec into a VMS-style path. ** tounixspec() - convert any file spec into a Unix-style file spec. ** tovmsspec() - convert any file spec into a VMS-style spec. +** xxxxx_utf8() - Variants that support UTF8 encoding of Unix-Style file spec. ** ** Copyright 1996 by Charles Bailey ** Permission is given to distribute this code as part of the Perl @@ -4697,8 +5180,8 @@ char *Perl_rmsexpand_ts(pTHX_ const char *spec, char *buf, const char *def, unsi ** found in the Perl standard distribution. */ -/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf)*/ -static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) +/*{{{ char *fileify_dirspec[_ts](char *dir, char *buf, int * utf8_fl)*/ +static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts, int *utf8_fl) { static char __fileify_retbuf[VMS_MAXRSS]; unsigned long int dirlen, retlen, addmfd = 0, hasfilename = 0; @@ -4706,6 +5189,8 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) char *trndir, *vmsdir; unsigned short int trnlnm_iter_count; int sts; + if (utf8_fl != NULL) + *utf8_fl = 0; if (!dir || !*dir) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; @@ -4730,7 +5215,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) (!decc_posix_compliant_pathnames && decc_disable_posix_root)) { strcpy(trndir,*dir == '/' ? dir + 1: dir); trnlnm_iter_count = 0; - while (!strpbrk(trndir,"/]>:>") && my_trnlnm(trndir,trndir,0)) { + while (!strpbrk(trndir,"/]>:") && my_trnlnm(trndir,trndir,0)) { trnlnm_iter_count++; if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break; } @@ -4788,13 +5273,13 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) if (trndir[1] == '\0' || (trndir[1] == '/' && trndir[2] == '\0')) { PerlMem_free(trndir); PerlMem_free(vmsdir); - return do_fileify_dirspec("[]",buf,ts); + return do_fileify_dirspec("[]",buf,ts,NULL); } else if (trndir[1] == '.' && (trndir[2] == '\0' || (trndir[2] == '/' && trndir[3] == '\0'))) { PerlMem_free(trndir); PerlMem_free(vmsdir); - return do_fileify_dirspec("[-]",buf,ts); + return do_fileify_dirspec("[-]",buf,ts,NULL); } } if (dirlen && trndir[dirlen-1] == '/') { /* path ends with '/'; just add .dir;1 */ @@ -4809,7 +5294,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) if (*(cp1+2) == '.') cp1++; if (*(cp1+2) == '/' || *(cp1+2) == '\0') { char * ret_chr; - if (do_tovmsspec(trndir,vmsdir,0) == NULL) { + if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) { PerlMem_free(trndir); PerlMem_free(vmsdir); return NULL; @@ -4825,12 +5310,12 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) set_errno(EINVAL); set_vaxc_errno(RMS$_SYN); return NULL; } - if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) { + if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) { PerlMem_free(trndir); PerlMem_free(vmsdir); return NULL; } - ret_chr = do_tounixspec(trndir,buf,ts); + ret_chr = do_tounixspec(trndir,buf,ts,NULL); PerlMem_free(trndir); PerlMem_free(vmsdir); return ret_chr; @@ -4851,17 +5336,17 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) */ trndir[dirlen] = '/'; trndir[dirlen+1] = '\0'; - if (do_tovmsspec(trndir,vmsdir,0) == NULL) { + if (do_tovmsspec(trndir,vmsdir,0,NULL) == NULL) { PerlMem_free(trndir); PerlMem_free(vmsdir); return NULL; } - if (do_fileify_dirspec(vmsdir,trndir,0) == NULL) { + if (do_fileify_dirspec(vmsdir,trndir,0,NULL) == NULL) { PerlMem_free(trndir); PerlMem_free(vmsdir); return NULL; } - ret_chr = do_tounixspec(trndir,buf,ts); + ret_chr = do_tounixspec(trndir,buf,ts,NULL); PerlMem_free(trndir); PerlMem_free(vmsdir); return ret_chr; @@ -4985,6 +5470,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) } } } + esa[rms_nam_esll(dirnam)] = '\0'; if (!rms_is_nam_fnb(dirnam, (NAM$M_EXP_DEV | NAM$M_EXP_DIR))) { cp1 = strchr(esa,']'); if (!cp1) cp1 = strchr(esa,'>'); @@ -5007,7 +5493,7 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) return NULL; } } - esa[rms_nam_esll(dirnam)] = '\0'; + if (rms_is_nam_fnb(dirnam, NAM$M_EXP_NAME)) { /* They provided at least the name; we added the type, if necessary, */ if (buf) retspec = buf; /* in sys$parse() */ @@ -5153,12 +5639,16 @@ static char *mp_do_fileify_dirspec(pTHX_ const char *dir,char *buf,int ts) /*}}}*/ /* External entry points */ char *Perl_fileify_dirspec(pTHX_ const char *dir, char *buf) -{ return do_fileify_dirspec(dir,buf,0); } +{ return do_fileify_dirspec(dir,buf,0,NULL); } char *Perl_fileify_dirspec_ts(pTHX_ const char *dir, char *buf) -{ return do_fileify_dirspec(dir,buf,1); } +{ return do_fileify_dirspec(dir,buf,1,NULL); } +char *Perl_fileify_dirspec_utf8(pTHX_ const char *dir, char *buf, int * utf8_fl) +{ return do_fileify_dirspec(dir,buf,0,utf8_fl); } +char *Perl_fileify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int * utf8_fl) +{ return do_fileify_dirspec(dir,buf,1,utf8_fl); } /*{{{ char *pathify_dirspec[_ts](char *path, char *buf)*/ -static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) +static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts, int * utf8_fl) { static char __pathify_retbuf[VMS_MAXRSS]; unsigned long int retlen; @@ -5166,6 +5656,8 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) unsigned short int trnlnm_iter_count; STRLEN trnlen; int sts; + if (utf8_fl != NULL) + *utf8_fl = 0; if (!dir || !*dir) { set_errno(EINVAL); set_vaxc_errno(SS$_BADPARAM); return NULL; @@ -5404,12 +5896,16 @@ static char *mp_do_pathify_dirspec(pTHX_ const char *dir,char *buf, int ts) /*}}}*/ /* External entry points */ char *Perl_pathify_dirspec(pTHX_ const char *dir, char *buf) -{ return do_pathify_dirspec(dir,buf,0); } +{ return do_pathify_dirspec(dir,buf,0,NULL); } char *Perl_pathify_dirspec_ts(pTHX_ const char *dir, char *buf) -{ return do_pathify_dirspec(dir,buf,1); } +{ return do_pathify_dirspec(dir,buf,1,NULL); } +char *Perl_pathify_dirspec_utf8(pTHX_ const char *dir, char *buf, int *utf8_fl) +{ return do_pathify_dirspec(dir,buf,0,utf8_fl); } +char *Perl_pathify_dirspec_utf8_ts(pTHX_ const char *dir, char *buf, int *utf8_fl) +{ return do_pathify_dirspec(dir,buf,1,utf8_fl); } -/*{{{ char *tounixspec[_ts](char *spec, char *buf)*/ -static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) +/*{{{ char *tounixspec[_ts](char *spec, char *buf, int *)*/ +static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts, int * utf8_fl) { static char __tounixspec_retbuf[VMS_MAXRSS]; char *dirend, *rslt, *cp1, *cp3, *tmp; @@ -5418,6 +5914,8 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) int expand = 1; /* guarantee room for leading and trailing slashes */ unsigned short int trnlnm_iter_count; int cmp_rslt; + if (utf8_fl != NULL) + *utf8_fl = 0; if (spec == NULL) return NULL; if (strlen(spec) > (VMS_MAXRSS-1)) return NULL; @@ -5612,7 +6110,7 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) } if ((*cp2 == '^')) { /* EFS file escape, pass the next character as is */ - /* Fix me: HEX encoding for UNICODE not implemented */ + /* Fix me: HEX encoding for Unicode not implemented */ cp2++; } else if ( *cp2 == '.') { @@ -5627,9 +6125,10 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) for (; cp2 <= dirend; cp2++) { if ((*cp2 == '^')) { /* EFS file escape, pass the next character as is */ - /* Fix me: HEX encoding for UNICODE not implemented */ - cp2++; - *(cp1++) = *cp2; + /* Fix me: HEX encoding for Unicode not implemented */ + *(cp1++) = *(++cp2); + /* An escaped dot stays as is -- don't convert to slash */ + if (*cp2 == '.') cp2++; } if (*cp2 == ':') { *(cp1++) = '/'; @@ -5667,7 +6166,10 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) } else *(cp1++) = *cp2; } - while (*cp2) *(cp1++) = *(cp2++); + while (*cp2) { + if ((*cp2 == '^') && (*(cp2+1) == '.')) cp2++; /* '^.' --> '.' */ + *(cp1++) = *(cp2++); + } *cp1 = '\0'; /* This still leaves /000000/ when working with a @@ -5697,13 +6199,36 @@ static char *mp_do_tounixspec(pTHX_ const char *spec, char *buf, int ts) } /* end of do_tounixspec() */ /*}}}*/ /* External entry points */ -char *Perl_tounixspec(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,0); } -char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) { return do_tounixspec(spec,buf,1); } +char *Perl_tounixspec(pTHX_ const char *spec, char *buf) + { return do_tounixspec(spec,buf,0, NULL); } +char *Perl_tounixspec_ts(pTHX_ const char *spec, char *buf) + { return do_tounixspec(spec,buf,1, NULL); } +char *Perl_tounixspec_utf8(pTHX_ const char *spec, char *buf, int * utf8_fl) + { return do_tounixspec(spec,buf,0, utf8_fl); } +char *Perl_tounixspec_utf8_ts(pTHX_ const char *spec, char *buf, int * utf8_fl) + { return do_tounixspec(spec,buf,1, utf8_fl); } -#if __CRTL_VER >= 80200000 && !defined(__VAX) +#if __CRTL_VER >= 70200000 && !defined(__VAX) + +/* + This procedure is used to identify if a path is based in either + the old SYS$POSIX_ROOT: or the new 8.3 RMS based POSIX root, and + it returns the OpenVMS format directory for it. + + It is expecting specifications of only '/' or '/xxxx/' + + If a posix root does not exist, or 'xxxx' is not a directory + in the posix root, it returns a failure. + + FIX-ME: xxxx could be in UTF-8 and needs to be returned in VTF-7. -static int posix_to_vmsspec - (char *vmspath, int vmspath_len, const char *unixpath) { + It is used only internally by posix_to_vmsspec_hardway(). + */ + +static int posix_root_to_vms + (char *vmspath, int vmspath_len, + const char *unixpath, + const int * utf8_fl) { int sts; struct FAB myfab = cc$rms_fab; struct NAML mynam = cc$rms_naml; @@ -5714,20 +6239,73 @@ char *vms_delim; int dir_flag; int unixlen; + dir_flag = 0; + unixlen = strlen(unixpath); + if (unixlen == 0) { + vmspath[0] = '\0'; + return RMS$_FNF; + } + +#if __CRTL_VER >= 80200000 /* If not a posix spec already, convert it */ - dir_flag = 0; - unixlen = strlen(unixpath); - if (unixlen == 0) { - vmspath[0] = '\0'; - return SS$_NORMAL; - } - if (strncmp(unixpath,"\"^UP^",5) != 0) { - sprintf(vmspath,"\"^UP^%s\"",unixpath); + if (decc_posix_compliant_pathnames) { + if (strncmp(unixpath,"\"^UP^",5) != 0) { + sprintf(vmspath,"\"^UP^%s\"",unixpath); + } + else { + /* This is already a VMS specification, no conversion */ + unixlen--; + strncpy(vmspath,unixpath, vmspath_len); + } } - else { - /* This is already a VMS specification, no conversion */ - unixlen--; - strncpy(vmspath,unixpath, vmspath_len); + else +#endif + { + int path_len; + int i,j; + + /* Check to see if this is under the POSIX root */ + if (decc_disable_posix_root) { + return RMS$_FNF; + } + + /* Skip leading / */ + if (unixpath[0] == '/') { + unixpath++; + unixlen--; + } + + + strcpy(vmspath,"SYS$POSIX_ROOT:"); + + /* If this is only the / , or blank, then... */ + if (unixpath[0] == '\0') { + /* by definition, this is the answer */ + return SS$_NORMAL; + } + + /* Need to look up a directory */ + vmspath[15] = '['; + vmspath[16] = '\0'; + + /* Copy and add '^' escape characters as needed */ + j = 16; + i = 0; + while (unixpath[i] != 0) { + int k; + + j += copy_expand_unix_filename_escape + (&vmspath[j], &unixpath[i], &k, utf8_fl); + i += k; + } + + path_len = strlen(vmspath); + if (vmspath[path_len - 1] == '/') + path_len--; + vmspath[path_len] = ']'; + path_len++; + vmspath[path_len] = '\0'; + } vmspath[vmspath_len] = 0; if (unixpath[unixlen - 1] == '/') @@ -5745,7 +6323,9 @@ int unixlen; mynam.naml$b_rss = 0; if (decc_efs_case_preserve) mynam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE; +#ifdef NAML$M_OPEN_SPECIAL mynam.naml$l_input_flags |= NAML$M_OPEN_SPECIAL; +#endif /* Set up the remaining naml fields */ sts = sys$parse(&myfab); @@ -5838,12 +6418,56 @@ int unixlen; return sts; } -/* Can not use LIB$FID_TO_NAME, so doing a manual conversion */ +/* /dev/mumble needs to be handled special. + /dev/null becomes NLA0:, And there is the potential for other stuff + like /dev/tty which may need to be mapped to something. +*/ + +static int +slash_dev_special_to_vms + (const char * unixptr, + char * vmspath, + int vmspath_len) +{ +char * nextslash; +int len; +int cmp; +int islnm; + + unixptr += 4; + nextslash = strchr(unixptr, '/'); + len = strlen(unixptr); + if (nextslash != NULL) + len = nextslash - unixptr; + cmp = strncmp("null", unixptr, 5); + if (cmp == 0) { + if (vmspath_len >= 6) { + strcpy(vmspath, "_NLA0:"); + return SS$_NORMAL; + } + } +} + + +/* The built in routines do not understand perl's special needs, so + doing a manual conversion from UNIX to VMS + + If the utf8_fl is not null and points to a non-zero value, then + treat 8 bit characters as UTF-8. + + The sequence starting with '$(' and ending with ')' will be passed + through with out interpretation instead of being escaped. + + */ static int posix_to_vmsspec_hardway - (char *vmspath, int vmspath_len, const char *unixpath) { + (char *vmspath, int vmspath_len, + const char *unixpath, + int dir_flag, + int * utf8_fl) { char *esa; const char *unixptr; +const char *unixend; char *vmsptr; const char *lastslash; const char *lastdot; @@ -5852,7 +6476,11 @@ int vmslen; int dir_start; int dir_dot; int quoted; +char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec; +int sts, v_len, r_len, d_len, n_len, e_len, vs_len; + if (utf8_fl != NULL) + *utf8_fl = 0; unixptr = unixpath; dir_dot = 0; @@ -5869,9 +6497,20 @@ int quoted; return SS$_NORMAL; } + quoted = 0; + /* This could have a "^UP^ on the front */ + if (strncmp(unixptr,"\"^UP^",5) == 0) { + quoted = 1; + unixptr+= 5; + unixlen-= 5; + } + lastslash = strrchr(unixptr,'/'); lastdot = strrchr(unixptr,'.'); - + unixend = strrchr(unixptr,'\"'); + if (!quoted || !((unixend != NULL) && (unixend[1] == '\0'))) { + unixend = unixptr + unixlen; + } /* last dot is last dot or past end of string */ if (lastdot == NULL) @@ -5900,20 +6539,169 @@ int quoted; /* if (unixptr < lastslash) then we are in a directory */ dir_start = 0; - quoted = 0; vmsptr = vmspath; vmslen = 0; - /* This could have a "^UP^ on the front */ - if (strncmp(unixptr,"\"^UP^",5) == 0) { - quoted = 1; - unixptr+= 5; - } - /* Start with the UNIX path */ if (*unixptr != '/') { /* relative paths */ + + /* If allowing logical names on relative pathnames, then handle here */ + if ((unixptr[0] != '.') && !decc_disable_to_vms_logname_translation && + !decc_posix_compliant_pathnames) { + char * nextslash; + int seg_len; + char * trn; + int islnm; + + /* Find the next slash */ + nextslash = strchr(unixptr,'/'); + + esa = PerlMem_malloc(vmspath_len); + if (esa == NULL) _ckvmssts_noperl(SS$_INSFMEM); + + trn = PerlMem_malloc(VMS_MAXRSS); + if (trn == NULL) _ckvmssts_noperl(SS$_INSFMEM); + + if (nextslash != NULL) { + + seg_len = nextslash - unixptr; + strncpy(esa, unixptr, seg_len); + esa[seg_len] = 0; + } + else { + strcpy(esa, unixptr); + seg_len = strlen(unixptr); + } + /* trnlnm(section) */ + islnm = vmstrnenv(esa, trn, 0, fildev, 0); + + if (islnm) { + /* Now fix up the directory */ + + /* Split up the path to find the components */ + sts = vms_split_path + (trn, + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); + + while (sts == 0) { + char * strt; + int cmp; + + /* A logical name must be a directory or the full + specification. It is only a full specification if + it is the only component */ + if ((unixptr[seg_len] == '\0') || + (unixptr[seg_len+1] == '\0')) { + + /* Is a directory being required? */ + if (((n_len + e_len) != 0) && (dir_flag !=0)) { + /* Not a logical name */ + break; + } + + + if ((unixptr[seg_len] == '/') || (dir_flag != 0)) { + /* This must be a directory */ + if (((n_len + e_len) == 0)&&(seg_len <= vmspath_len)) { + strcpy(vmsptr, esa); + vmslen=strlen(vmsptr); + vmsptr[vmslen] = ':'; + vmslen++; + vmsptr[vmslen] = '\0'; + return SS$_NORMAL; + } + } + + } + + + /* must be dev/directory - ignore version */ + if ((n_len + e_len) != 0) + break; + + /* transfer the volume */ + if (v_len > 0 && ((v_len + vmslen) < vmspath_len)) { + strncpy(vmsptr, v_spec, v_len); + vmsptr += v_len; + vmsptr[0] = '\0'; + vmslen += v_len; + } + + /* unroot the rooted directory */ + if ((r_len > 0) && ((r_len + d_len + vmslen) < vmspath_len)) { + r_spec[0] = '['; + r_spec[r_len - 1] = ']'; + + /* This should not be there, but nothing is perfect */ + if (r_len > 9) { + cmp = strcmp(&r_spec[1], "000000."); + if (cmp == 0) { + r_spec += 7; + r_spec[7] = '['; + r_len -= 7; + if (r_len == 2) + r_len = 0; + } + } + if (r_len > 0) { + strncpy(vmsptr, r_spec, r_len); + vmsptr += r_len; + vmslen += r_len; + vmsptr[0] = '\0'; + } + } + /* Bring over the directory. */ + if ((d_len > 0) && + ((d_len + vmslen) < vmspath_len)) { + d_spec[0] = '['; + d_spec[d_len - 1] = ']'; + if (d_len > 9) { + cmp = strcmp(&d_spec[1], "000000."); + if (cmp == 0) { + d_spec += 7; + d_spec[7] = '['; + d_len -= 7; + if (d_len == 2) + d_len = 0; + } + } + + if (r_len > 0) { + /* Remove the redundant root */ + if (r_len > 0) { + /* remove the ][ */ + vmsptr--; + vmslen--; + d_spec++; + d_len--; + } + strncpy(vmsptr, d_spec, d_len); + vmsptr += d_len; + vmslen += d_len; + vmsptr[0] = '\0'; + } + } + break; + } + } + + PerlMem_free(esa); + PerlMem_free(trn); + } + if (lastslash > unixptr) { int dotdir_seen; @@ -5933,11 +6721,11 @@ int quoted; /* if not backing up, then it is relative forward. */ if (!((*unixptr == '.') && (unixptr[1] == '.') && - ((unixptr[2] == '/') || (unixptr[2] == '\0')))) { + ((unixptr[2] == '/') || (&unixptr[2] == unixend)))) { *vmsptr++ = '.'; vmslen++; dir_dot = 1; - } + } } else { if (dotdir_seen) { @@ -5953,14 +6741,14 @@ int quoted; else { /* Handle two special files . and .. */ if (unixptr[0] == '.') { - if (unixptr[1] == '\0') { + if (&unixptr[1] == unixend) { *vmsptr++ = '['; *vmsptr++ = ']'; vmslen += 2; *vmsptr++ = '\0'; return SS$_NORMAL; } - if ((unixptr[1] == '.') && (unixptr[2] == '\0')) { + if ((unixptr[1] == '.') && (&unixptr[2] == unixend)) { *vmsptr++ = '['; *vmsptr++ = '-'; *vmsptr++ = ']'; @@ -5990,37 +6778,63 @@ int quoted; nextslash = strchr(&unixptr[1],'/'); seg_len = 0; if (nextslash != NULL) { + int cmp; seg_len = nextslash - &unixptr[1]; strncpy(vmspath, unixptr, seg_len + 1); vmspath[seg_len+1] = 0; - sts = posix_to_vmsspec(esa, vmspath_len, vmspath); + cmp = 1; + if (seg_len == 3) { + cmp = strncmp(vmspath, "dev", 4); + if (cmp == 0) { + sts = slash_dev_special_to_vms(unixptr, vmspath, vmspath_len); + if (sts = SS$_NORMAL) + return SS$_NORMAL; + } + } + sts = posix_root_to_vms(esa, vmspath_len, vmspath, utf8_fl); } - if (sts & 1) { + if ($VMS_STATUS_SUCCESS(sts)) { /* This is verified to be a real path */ - sts = posix_to_vmsspec(esa, vmspath_len, "/"); - strcpy(vmspath, esa); - vmslen = strlen(vmspath); - vmsptr = vmspath + vmslen; - unixptr++; - if (unixptr < lastslash) { - char * rptr; - vmsptr--; - *vmsptr++ = '.'; - dir_start = 1; - dir_dot = 1; - if (vmslen > 7) { - int cmp; - rptr = vmsptr - 7; - cmp = strcmp(rptr,"000000."); - if (cmp == 0) { - vmslen -= 7; - vmsptr -= 7; - vmsptr[1] = '\0'; - } /* removing 6 zeros */ - } /* vmslen < 7, no 6 zeros possible */ - } /* Not in a directory */ + sts = posix_root_to_vms(esa, vmspath_len, "/", NULL); + if ($VMS_STATUS_SUCCESS(sts)) { + strcpy(vmspath, esa); + vmslen = strlen(vmspath); + vmsptr = vmspath + vmslen; + unixptr++; + if (unixptr < lastslash) { + char * rptr; + vmsptr--; + *vmsptr++ = '.'; + dir_start = 1; + dir_dot = 1; + if (vmslen > 7) { + int cmp; + rptr = vmsptr - 7; + cmp = strcmp(rptr,"000000."); + if (cmp == 0) { + vmslen -= 7; + vmsptr -= 7; + vmsptr[1] = '\0'; + } /* removing 6 zeros */ + } /* vmslen < 7, no 6 zeros possible */ + } /* Not in a directory */ + } /* Posix root found */ + else { + /* No posix root, fall back to default directory */ + strcpy(vmspath, "SYS$DISK:["); + vmsptr = &vmspath[10]; + vmslen = 10; + if (unixptr > lastslash) { + *vmsptr = ']'; + vmsptr++; + vmslen++; + } + else { + dir_start = 1; + } + } } /* end of verified real path handling */ else { int add_6zero; @@ -6045,9 +6859,27 @@ int quoted; } else { int trnend; + int cmp; /* now we have foo:bar or foo:[000000]bar to decide from */ islnm = vmstrnenv(vmspath, esa, 0, fildev, 0); + + if (!islnm && !decc_posix_compliant_pathnames) { + + cmp = strncmp("bin", vmspath, 4); + if (cmp == 0) { + /* bin => SYS$SYSTEM: */ + islnm = vmstrnenv("SYS$SYSTEM:", esa, 0, fildev, 0); + } + else { + /* tmp => SYS$SCRATCH: */ + cmp = strncmp("tmp", vmspath, 4); + if (cmp == 0) { + islnm = vmstrnenv("SYS$SCRATCH:", esa, 0, fildev, 0); + } + } + } + trnend = islnm ? islnm - 1 : 0; /* if this was a logical name, ']' or '>' must be present */ @@ -6063,9 +6895,13 @@ int quoted; * * As it is, perl is occasionally looking for dev:[000000]tty. * which looks a little strange. + * + * Not that easy to detect as "/dev" may be file structured with + * special device files. */ - if ((add_6zero == 0) && (*nextslash == '/') && (nextslash[1] == '\0')) { + if ((add_6zero == 0) && (*nextslash == '/') && + (&nextslash[1] == unixend)) { /* No real directory present */ add_6zero = 1; } @@ -6101,8 +6937,10 @@ int quoted; PerlMem_free(esa); } /* End of relative/absolute path handling */ - while ((*unixptr) && (vmslen < vmspath_len)){ + while ((unixptr <= unixend) && (vmslen < vmspath_len)){ int dash_flag; + int in_cnt; + int out_cnt; dash_flag = 0; @@ -6111,7 +6949,8 @@ int quoted; /* First characters in a directory are handled special */ while ((*unixptr == '/') || ((*unixptr == '.') && - ((unixptr[1]=='.') || (unixptr[1]=='/') || (unixptr[1]=='\0')))) { + ((unixptr[1]=='.') || (unixptr[1]=='/') || + (&unixptr[1]==unixend)))) { int loop_flag; loop_flag = 0; @@ -6128,7 +6967,7 @@ int quoted; /* Skip redundant ./ characters */ while ((*unixptr == '.') && - ((unixptr[1] == '/')||(unixptr[1] == '\0'))) { + ((unixptr[1] == '/')||(&unixptr[1] == unixend))) { loop_flag = 1; unixptr++; if (unixptr == lastslash) @@ -6141,7 +6980,7 @@ int quoted; /* Skip redundant ../ characters */ while ((*unixptr == '.') && (unixptr[1] == '.') && - ((unixptr[2] == '/') || (unixptr[2] == '\0'))) { + ((unixptr[2] == '/') || (&unixptr[2] == unixend))) { /* Set the backing up flag */ loop_flag = 1; dir_dot = 0; @@ -6216,7 +7055,7 @@ int quoted; } /* All done? */ - if (*unixptr == '\0') + if (unixptr >= unixend) break; /* Normal characters - More EFS work probably needed */ @@ -6247,56 +7086,50 @@ int quoted; } dash_flag = 0; - if (*unixptr != '\0') + if (unixptr != unixend) unixptr++; vmslen++; break; - case '?': - *vmsptr++ = '%'; - vmslen++; - unixptr++; - break; - case ' ': - *vmsptr++ = '^'; - *vmsptr++ = '_'; - vmslen += 2; - unixptr++; - break; case '.': - if ((unixptr < lastdot) || (unixptr[1] == '\0')) { + if ((unixptr < lastdot) || (unixptr < lastslash) || + (&unixptr[1] == unixend)) { *vmsptr++ = '^'; *vmsptr++ = '.'; vmslen += 2; unixptr++; /* trailing dot ==> '^..' on VMS */ - if (*unixptr == '\0') { + if (unixptr == unixend) { *vmsptr++ = '.'; vmslen++; + unixptr++; } - *vmsptr++ = *unixptr++; - vmslen ++; - } - if (quoted && (unixptr[1] == '\0')) { - unixptr++; break; } - *vmsptr++ = '^'; + *vmsptr++ = *unixptr++; - vmslen += 2; + vmslen ++; break; - case '~': - case ';': - case '\\': - *vmsptr++ = '^'; - *vmsptr++ = *unixptr++; - vmslen += 2; + case '"': + if (quoted && (&unixptr[1] == unixend)) { + unixptr++; + break; + } + in_cnt = copy_expand_unix_filename_escape + (vmsptr, unixptr, &out_cnt, utf8_fl); + vmsptr += out_cnt; + unixptr += in_cnt; break; + case '~': + case ';': + case '\\': + case '?': + case ' ': default: - if (*unixptr != '\0') { - *vmsptr++ = *unixptr++; - vmslen++; - } + in_cnt = copy_expand_unix_filename_escape + (vmsptr, unixptr, &out_cnt, utf8_fl); + vmsptr += out_cnt; + unixptr += in_cnt; break; } } @@ -6325,8 +7158,9 @@ int quoted; char *vmsptr2; /* Add a trailing dot if a file with no extension */ vmsptr2 = vmsptr - 1; - if ((*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') && - (*lastdot != '.')) { + if ((vmslen > 1) && + (*vmsptr2 != ']') && (*vmsptr2 != '*') && (*vmsptr2 != '%') && + (*vmsptr2 != ')') && (*lastdot != '.')) { *vmsptr++ = '.'; vmslen++; } @@ -6337,8 +7171,35 @@ int quoted; } #endif -/*{{{ char *tovmsspec[_ts](char *path, char *buf)*/ -static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { + /* Eventual routine to convert a UTF-8 specification to VTF-7. */ +static char * utf8_to_vtf7(char * rslt, const char * path, int *utf8_fl) +{ +char * result; +int utf8_flag; + + /* If a UTF8 flag is being passed, honor it */ + utf8_flag = 0; + if (utf8_fl != NULL) { + utf8_flag = *utf8_fl; + *utf8_fl = 0; + } + + if (utf8_flag) { + /* If there is a possibility of UTF8, then if any UTF8 characters + are present, then they must be converted to VTF-7 + */ + result = strcpy(rslt, path); /* FIX-ME */ + } + else + result = strcpy(rslt, path); + + return result; +} + + +/*{{{ char *tovmsspec[_ts](char *path, char *buf, int * utf8_flag)*/ +static char *mp_do_tovmsspec + (pTHX_ const char *path, char *buf, int ts, int dir_flag, int * utf8_flag) { static char __tovmsspec_retbuf[VMS_MAXRSS]; char *rslt, *dirend; char *lastdot; @@ -6348,21 +7209,31 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { unsigned long int infront = 0, hasdir = 1; int rslt_len; int no_type_seen; + char * v_spec, * r_spec, * d_spec, * n_spec, * e_spec, * vs_spec; + int sts, v_len, r_len, d_len, n_len, e_len, vs_len; if (path == NULL) return NULL; rslt_len = VMS_MAXRSS-1; if (buf) rslt = buf; else if (ts) Newx(rslt, VMS_MAXRSS, char); else rslt = __tovmsspec_retbuf; - if (strpbrk(path,"]:>") || - (dirend = strrchr(path,'/')) == NULL) { - if (path[0] == '.') { - if (path[1] == '\0') strcpy(rslt,"[]"); - else if (path[1] == '.' && path[2] == '\0') strcpy(rslt,"[-]"); - else strcpy(rslt,path); /* probably garbage */ - } - else strcpy(rslt,path); - return rslt; + + /* '.' and '..' are "[]" and "[-]" for a quick check */ + if (path[0] == '.') { + if (path[1] == '\0') { + strcpy(rslt,"[]"); + if (utf8_flag != NULL) + *utf8_flag = 0; + return rslt; + } + else { + if (path[1] == '.' && path[2] == '\0') { + strcpy(rslt,"[-]"); + if (utf8_flag != NULL) + *utf8_flag = 0; + return rslt; + } + } } /* Posix specifications are now a native VMS format */ @@ -6370,61 +7241,83 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { #if __CRTL_VER >= 80200000 && !defined(__VAX) if (decc_posix_compliant_pathnames) { if (strncmp(path,"\"^UP^",5) == 0) { - posix_to_vmsspec_hardway(rslt, rslt_len, path); + posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag); return rslt; } } #endif - vms_delim = strpbrk(path,"]:>"); + /* This is really the only way to see if this is already in VMS format */ + sts = vms_split_path + (path, + &v_spec, + &v_len, + &r_spec, + &r_len, + &d_spec, + &d_len, + &n_spec, + &n_len, + &e_spec, + &e_len, + &vs_spec, + &vs_len); + if (sts == 0) { + /* FIX-ME - If dir_flag is non-zero, then this is a mp_do_vmspath() + replacement, because the above parse just took care of most of + what is needed to do vmspath when the specification is already + in VMS format. + + And if it is not already, it is easier to do the conversion as + part of this routine than to call this routine and then work on + the result. + */ - if ((vms_delim != NULL) || - ((dirend = strrchr(path,'/')) == NULL)) { + /* If VMS punctuation was found, it is already VMS format */ + if ((v_len != 0) || (r_len != 0) || (d_len != 0) || (vs_len != 0)) { + if (utf8_flag != NULL) + *utf8_flag = 0; + strcpy(rslt, path); + return rslt; + } + /* Now, what to do with trailing "." cases where there is no + extension? If this is a UNIX specification, and EFS characters + are enabled, then the trailing "." should be converted to a "^.". + But if this was already a VMS specification, then it should be + left alone. - /* VMS special characters found! */ + So in the case of ambiguity, leave the specification alone. + */ - if (path[0] == '.') { - if (path[1] == '\0') strcpy(rslt,"[]"); - else if (path[1] == '.' && path[2] == '\0') - strcpy(rslt,"[-]"); - /* Dot preceeding a device or directory ? */ - else { - /* If not in POSIX mode, pass it through and hope it works */ -#if __CRTL_VER >= 80200000 && !defined(__VAX) - if (!decc_posix_compliant_pathnames) - strcpy(rslt,path); /* probably garbage */ - else - posix_to_vmsspec_hardway(rslt, rslt_len, path); -#else - strcpy(rslt,path); /* probably garbage */ -#endif - } - } - else { - - /* If no VMS characters and in POSIX mode, convert it! - * This is the easiest way to get directory specifications - * handled correctly in POSIX mode - */ -#if __CRTL_VER >= 80200000 && !defined(__VAX) - if ((vms_delim == NULL) && decc_posix_compliant_pathnames) - posix_to_vmsspec_hardway(rslt, rslt_len, path); - else { - /* No unix path separators - presume VMS already */ - strcpy(rslt,path); - } -#else - strcpy(rslt,path); /* probably garbage */ -#endif - } + /* If there is a possibility of UTF8, then if any UTF8 characters + are present, then they must be converted to VTF-7 + */ + if (utf8_flag != NULL) + *utf8_flag = 0; + strcpy(rslt, path); return rslt; } + dirend = strrchr(path,'/'); + + if (dirend == NULL) { + /* If we get here with no UNIX directory delimiters, then this is + not a complete file specification, either garbage a UNIX glob + specification that can not be converted to a VMS wildcard, or + it a UNIX shell macro. MakeMaker wants these passed through AS-IS, + so apparently other programs expect this also. + + utf8 flag setting needs to be preserved. + */ + strcpy(rslt, path); + return rslt; + } + /* If POSIX mode active, handle the conversion */ #if __CRTL_VER >= 80200000 && !defined(__VAX) - if (decc_posix_compliant_pathnames) { - posix_to_vmsspec_hardway(rslt, rslt_len, path); + if (decc_efs_charset) { + posix_to_vmsspec_hardway(rslt, rslt_len, path, dir_flag, utf8_flag); return rslt; } #endif @@ -6432,7 +7325,9 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { if (*(dirend+1) == '.') { /* do we have trailing "/." or "/.." or "/..."? */ if (!*(dirend+2)) dirend +=2; if (*(dirend+2) == '.' && !*(dirend+3)) dirend += 3; - if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4; + if (decc_efs_charset == 0) { + if (*(dirend+2) == '.' && *(dirend+3) == '.' && !*(dirend+4)) dirend += 4; + } } cp1 = rslt; @@ -6451,6 +7346,8 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { else { strcpy(rslt,"sys$posix_root:[000000]"); } + if (utf8_flag != NULL) + *utf8_flag = 0; return rslt; } while (*(++cp2) != '/' && *cp2) *(cp1++) = *cp2; @@ -6614,7 +7511,10 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { while (*cp2) { switch(*cp2) { case '?': - *(cp1++) = '%'; + if (decc_efs_charset == 0) + *(cp1++) = '%'; + else + *(cp1++) = '?'; cp2++; case ' ': *(cp1)++ = '^'; @@ -6639,6 +7539,38 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { no_type_seen = 0; } break; + case '$': + /* This could be a macro to be passed through */ + *(cp1++) = *(cp2++); + if (*cp2 == '(') { + const char * save_cp2; + char * save_cp1; + int is_macro; + + /* paranoid check */ + save_cp2 = cp2; + save_cp1 = cp1; + is_macro = 0; + + /* Test through */ + *(cp1++) = *(cp2++); + if (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) { + *(cp1++) = *(cp2++); + while (isalnum(*cp2) || (*cp2 == '.') || (*cp2 == '_')) { + *(cp1++) = *(cp2++); + } + if (*cp2 == ')') { + *(cp1++) = *(cp2++); + is_macro = 1; + } + } + if (is_macro == 0) { + /* Not really a macro - never mind */ + cp2 = save_cp2; + cp1 = save_cp1; + } + } + break; case '\"': case '~': case '`': @@ -6646,6 +7578,14 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { case '#': case '%': case '^': + /* Don't escape again if following character is + * already something we escape. + */ + if (strchr("\"~`!#%^&()=+\'@[]{}:\\|<>_.", *(cp2+1))) { + *(cp1++) = *(cp2++); + break; + } + /* But otherwise fall through and escape it. */ case '&': case '(': case ')': @@ -6694,16 +7634,24 @@ static char *mp_do_tovmsspec(pTHX_ const char *path, char *buf, int ts) { } *cp1 = '\0'; + if (utf8_flag != NULL) + *utf8_flag = 0; return rslt; } /* end of do_tovmsspec() */ /*}}}*/ /* External entry points */ -char *Perl_tovmsspec(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,0); } -char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) { return do_tovmsspec(path,buf,1); } - -/*{{{ char *tovmspath[_ts](char *path, char *buf)*/ -static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) { +char *Perl_tovmsspec(pTHX_ const char *path, char *buf) + { return do_tovmsspec(path,buf,0,NULL); } +char *Perl_tovmsspec_ts(pTHX_ const char *path, char *buf) + { return do_tovmsspec(path,buf,1,NULL); } +char *Perl_tovmsspec_utf8(pTHX_ const char *path, char *buf, int * utf8_fl) + { return do_tovmsspec(path,buf,0,utf8_fl); } +char *Perl_tovmsspec_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl) + { return do_tovmsspec(path,buf,1,utf8_fl); } + +/*{{{ char *tovmspath[_ts](char *path, char *buf, const int *)*/ +static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) { static char __tovmspath_retbuf[VMS_MAXRSS]; int vmslen; char *pathified, *vmsified, *cp; @@ -6711,7 +7659,7 @@ static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) { if (path == NULL) return NULL; pathified = PerlMem_malloc(VMS_MAXRSS); if (pathified == NULL) _ckvmssts(SS$_INSFMEM); - if (do_pathify_dirspec(path,pathified,0) == NULL) { + if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) { PerlMem_free(pathified); return NULL; } @@ -6719,7 +7667,7 @@ static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) { vmsified = NULL; if (buf == NULL) Newx(vmsified, VMS_MAXRSS, char); - if (do_tovmsspec(pathified, buf ? buf : vmsified, 0) == NULL) { + if (do_tovmsspec(pathified, buf ? buf : vmsified, 0, NULL) == NULL) { PerlMem_free(pathified); if (vmsified) Safefree(vmsified); return NULL; @@ -6745,12 +7693,18 @@ static char *mp_do_tovmspath(pTHX_ const char *path, char *buf, int ts) { } /* end of do_tovmspath() */ /*}}}*/ /* External entry points */ -char *Perl_tovmspath(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,0); } -char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) { return do_tovmspath(path,buf,1); } - - -/*{{{ char *tounixpath[_ts](char *path, char *buf)*/ -static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) { +char *Perl_tovmspath(pTHX_ const char *path, char *buf) + { return do_tovmspath(path,buf,0, NULL); } +char *Perl_tovmspath_ts(pTHX_ const char *path, char *buf) + { return do_tovmspath(path,buf,1, NULL); } +char *Perl_tovmspath_utf8(pTHX_ const char *path, char *buf, int *utf8_fl) + { return do_tovmspath(path,buf,0,utf8_fl); } +char *Perl_tovmspath_utf8_ts(pTHX_ const char *path, char *buf, int *utf8_fl) + { return do_tovmspath(path,buf,1,utf8_fl); } + + +/*{{{ char *tounixpath[_ts](char *path, char *buf, int * utf8_fl)*/ +static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts, int * utf8_fl) { static char __tounixpath_retbuf[VMS_MAXRSS]; int unixlen; char *pathified, *unixified, *cp; @@ -6758,7 +7712,7 @@ static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) { if (path == NULL) return NULL; pathified = PerlMem_malloc(VMS_MAXRSS); if (pathified == NULL) _ckvmssts(SS$_INSFMEM); - if (do_pathify_dirspec(path,pathified,0) == NULL) { + if (do_pathify_dirspec(path,pathified,0,NULL) == NULL) { PerlMem_free(pathified); return NULL; } @@ -6767,7 +7721,7 @@ static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) { if (buf == NULL) { Newx(unixified, VMS_MAXRSS, char); } - if (do_tounixspec(pathified,buf ? buf : unixified,0) == NULL) { + if (do_tounixspec(pathified,buf ? buf : unixified,0,NULL) == NULL) { PerlMem_free(pathified); if (unixified) Safefree(unixified); return NULL; @@ -6793,24 +7747,30 @@ static char *mp_do_tounixpath(pTHX_ const char *path, char *buf, int ts) { } /* end of do_tounixpath() */ /*}}}*/ /* External entry points */ -char *Perl_tounixpath(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,0); } -char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpath(path,buf,1); } +char *Perl_tounixpath(pTHX_ const char *path, char *buf) + { return do_tounixpath(path,buf,0,NULL); } +char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) + { return do_tounixpath(path,buf,1,NULL); } +char *Perl_tounixpath_utf8(pTHX_ const char *path, char *buf, int * utf8_fl) + { return do_tounixpath(path,buf,0,utf8_fl); } +char *Perl_tounixpath_utf8_ts(pTHX_ const char *path, char *buf, int * utf8_fl) + { return do_tounixpath(path,buf,1,utf8_fl); } /* - * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark@infocomm.com) + * @(#)argproc.c 2.2 94/08/16 Mark Pizzolato (mark AT infocomm DOT com) * ***************************************************************************** * * - * Copyright (C) 1989-1994 by * + * Copyright (C) 1989-1994, 2007 by * * Mark Pizzolato - INFO COMM, Danville, California (510) 837-5600 * * * - * Permission is hereby granted for the reproduction of this software, * - * on condition that this copyright notice is included in the reproduction, * - * and that such reproduction is not for purposes of profit or material * - * gain. * + * Permission is hereby granted for the reproduction of this software * + * on condition that this copyright notice is included in source * + * distributions of the software. The code may be modified and * + * distributed under the same terms as Perl itself. * * * * 27-Aug-1994 Modified for inclusion in perl5 * - * by Charles Bailey bailey@newman.upenn.edu * + * by Charles Bailey (bailey AT newman DOT upenn DOT edu) * ***************************************************************************** */ @@ -6826,7 +7786,7 @@ char *Perl_tounixpath_ts(pTHX_ const char *path, char *buf) { return do_tounixpa * of program. With suitable modification, it may useful for other * portability problems as well. * - * Author: Mark Pizzolato mark@infocomm.com + * Author: Mark Pizzolato (mark AT infocomm DOT com) */ struct list_item { @@ -7161,7 +8121,7 @@ int rms_sts; vmsspec = PerlMem_malloc(VMS_MAXRSS); if (vmsspec == NULL) _ckvmssts_noperl(SS$_INSFMEM); if ((isunix = (int) strchr(item,'/')) != (int) NULL) - filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0); + filespec.dsc$a_pointer = do_tovmsspec(item,vmsspec,0,NULL); if (!isunix || !filespec.dsc$a_pointer) filespec.dsc$a_pointer = item; filespec.dsc$w_length = strlen(filespec.dsc$a_pointer); @@ -7574,7 +8534,7 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) if (!wildspec || !fspec) return 0; template = unixwild; if (strpbrk(wildspec,"]>:") != NULL) { - if (do_tounixspec(wildspec,unixwild,0) == NULL) { + if (do_tounixspec(wildspec,unixwild,0,NULL) == NULL) { PerlMem_free(unixwild); return 0; } @@ -7586,7 +8546,7 @@ Perl_trim_unixpath(pTHX_ char *fspec, const char *wildspec, int opts) unixified = PerlMem_malloc(VMS_MAXRSS); if (unixified == NULL) _ckvmssts(SS$_INSFMEM); if (strpbrk(fspec,"]>:") != NULL) { - if (do_tounixspec(fspec,unixified,0) == NULL) { + if (do_tounixspec(fspec,unixified,0,NULL) == NULL) { PerlMem_free(unixwild); PerlMem_free(unixified); return 0; @@ -7826,22 +8786,16 @@ Perl_opendir(pTHX_ const char *name) DIR *dd; char *dir; Stat_t sb; - int unix_flag; - - unix_flag = 0; - if (decc_efs_charset) { - unix_flag = is_unix_filespec(name); - } Newx(dir, VMS_MAXRSS, char); - if (do_tovmspath(name,dir,0) == NULL) { + if (do_tovmspath(name,dir,0,NULL) == NULL) { Safefree(dir); return NULL; } /* Check access before stat; otherwise stat does not * accurately report whether it's a directory. */ - if (!cando_by_name(S_IRUSR,0,dir)) { + if (!cando_by_name_int(S_IRUSR,0,dir,PERL_RMSEXPAND_M_VMS_IN)) { /* cando_by_name has already set errno */ Safefree(dir); return NULL; @@ -7862,8 +8816,12 @@ Perl_opendir(pTHX_ const char *name) dd->context = 0; dd->count = 0; dd->flags = 0; - if (unix_flag) - dd->flags = PERL_VMSDIR_M_UNIXSPECS; + /* By saying we always want the result of readdir() in unix format, we + * are really saying we want all the escapes removed. Otherwise the caller, + * having no way to know whether it's already in VMS format, might send it + * through tovmsspec again, thus double escaping. + */ + dd->flags = PERL_VMSDIR_M_UNIXSPECS; dd->pat.dsc$a_pointer = dd->pattern; dd->pat.dsc$w_length = strlen(dd->pattern); dd->pat.dsc$b_dtype = DSC$K_DTYPE_T; @@ -8034,7 +8992,7 @@ Perl_readdir(pTHX_ DIR *dd) /* Skip any directory component and just copy the name. */ sts = vms_split_path - (aTHX_ buff, + (buff, &v_spec, &v_len, &r_spec, @@ -8063,25 +9021,25 @@ Perl_readdir(pTHX_ DIR *dd) if (dd->flags & PERL_VMSDIR_M_UNIXSPECS) { /* Translate the encoded characters. */ - /* Fixme: unicode handling could result in embedded 0 characters */ + /* Fixme: Unicode handling could result in embedded 0 characters */ if (strchr(dd->entry.d_name, '^') != NULL) { char new_name[256]; char * q; - int cnt; p = dd->entry.d_name; q = new_name; while (*p != 0) { - int x, y; - x = copy_expand_vms_filename_escape(q, p, &y); - p += x; - q += y; + int inchars_read, outchars_added; + inchars_read = copy_expand_vms_filename_escape(q, p, &outchars_added); + p += inchars_read; + q += outchars_added; /* fix-me */ - /* if y > 1, then this is a wide file specification */ + /* if outchars_added > 1, then this is a wide file specification */ /* Wide file specifications need to be passed in Perl */ - /* counted strings apparently with a unicode flag */ + /* counted strings apparently with a Unicode flag */ } *q = 0; strcpy(dd->entry.d_name, new_name); + dd->entry.d_namlen = strlen(dd->entry.d_name); } } @@ -8309,7 +9267,7 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, *rest && !isspace(*rest) && cp2 - resspec < sizeof resspec; rest++, cp2++) *cp2 = *rest; *cp2 = '\0'; - if (do_tovmsspec(resspec,cp,0)) { + if (do_tovmsspec(resspec,cp,0,NULL)) { s = vmsspec; if (*rest) { for (cp2 = vmsspec + strlen(vmsspec); @@ -8429,9 +9387,11 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, /* Try to find the exact program requested to be run */ /*---------------------------------------------------*/ iname = do_rmsexpand - (tmpspec, image_name, 0, ".exe", PERL_RMSEXPAND_M_VMS); + (tmpspec, image_name, 0, ".exe", + PERL_RMSEXPAND_M_VMS, NULL, NULL); if (iname != NULL) { - if (cando_by_name(S_IXUSR,0,image_name)) { + if (cando_by_name_int + (S_IXUSR,0,image_name,PERL_RMSEXPAND_M_VMS_IN)) { /* MCR prefix needed */ isdcl = 0; } @@ -8439,9 +9399,11 @@ setup_cmddsc(pTHX_ const char *incmd, int check_img, int *suggest_quote, /* Try again with a null type */ /*----------------------------*/ iname = do_rmsexpand - (tmpspec, image_name, 0, ".", PERL_RMSEXPAND_M_VMS); + (tmpspec, image_name, 0, ".", + PERL_RMSEXPAND_M_VMS, NULL, NULL); if (iname != NULL) { - if (cando_by_name(S_IXUSR,0,image_name)) { + if (cando_by_name_int + (S_IXUSR,0,image_name, PERL_RMSEXPAND_M_VMS_IN)) { /* MCR prefix needed */ isdcl = 0; } @@ -8946,7 +9908,7 @@ static int fillpasswd (pTHX_ const char *name, struct passwd *pwd) pwd->pw_passwd= pw_passwd; pwd->pw_gecos= owner.pw_gecos; pwd->pw_dir= defdev.pw_dir; - pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1); + pwd->pw_unixdir= do_tounixpath(defdev.pw_dir, defdir.unixdir,1,NULL); pwd->pw_shell= defcli.pw_shell; if (pwd->pw_unixdir && pwd->pw_unixdir[0]) { int ldir; @@ -9668,15 +10630,23 @@ Perl_my_localtime(pTHX_ const time_t *timep) #define time(t) my_time(t) -/* my_utime - update modification time of a file - * calling sequence is identical to POSIX utime(), but under - * VMS only the modification time is changed; ODS-2 does not - * maintain access times. Restrictions differ from the POSIX +/* my_utime - update modification/access time of a file + * + * VMS 7.3 and later implementation + * Only the UTC translation is home-grown. The rest is handled by the + * CRTL utime(), which will take into account the relevant feature + * logicals and ODS-5 volume characteristics for true access times. + * + * pre VMS 7.3 implementation: + * The calling sequence is identical to POSIX utime(), but under + * VMS with ODS-2, only the modification time is changed; ODS-2 does + * not maintain access times. Restrictions differ from the POSIX * definition in that the time can be changed as long as the * caller has permission to execute the necessary IO$_MODIFY $QIO; * no separate checks are made to insure that the caller is the * owner of the file or has special privs enabled. * Code here is based on Joe Meadows' FILE utility. + * */ /* Adjustment from Unix epoch (01-JAN-1970 00:00:00.00) @@ -9688,6 +10658,29 @@ static const long int utime_baseadjust[2] = { 0x4beb4000, 0x7c9567 }; /*{{{int my_utime(const char *path, const struct utimbuf *utimes)*/ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) { +#if __CRTL_VER >= 70300000 + struct utimbuf utc_utimes, *utc_utimesp; + + if (utimes != NULL) { + utc_utimes.actime = utimes->actime; + utc_utimes.modtime = utimes->modtime; +# ifdef VMSISH_TIME + /* If input was local; convert to UTC for sys svc */ + if (VMSISH_TIME) { + utc_utimes.actime = _toutc(utimes->actime); + utc_utimes.modtime = _toutc(utimes->modtime); + } +# endif + utc_utimesp = &utc_utimes; + } + else { + utc_utimesp = NULL; + } + + return utime(file, utc_utimesp); + +#else /* __CRTL_VER < 70300000 */ + register int i; int sts; long int bintime[2], len = 2, lowbit, unixtime, @@ -9715,33 +10708,17 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) struct dsc$descriptor fibdsc = {sizeof(myfib), DSC$K_DTYPE_Z, DSC$K_CLASS_S,(char *) &myfib}, devdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}, fnmdsc = {0,DSC$K_DTYPE_T, DSC$K_CLASS_S,0}; - - if (decc_efs_charset != 0) { - struct utimbuf utc_utimes; - - utc_utimes.actime = utimes->actime; - utc_utimes.modtime = utimes->modtime; -# ifdef VMSISH_TIME - /* If input was local; convert to UTC for sys svc */ - if (VMSISH_TIME) { - utc_utimes.actime = _toutc(utimes->actime); - utc_utimes.modtime = _toutc(utimes->modtime); - } -# endif - sts = utime(file, &utc_utimes); - return sts; - } if (file == NULL || *file == '\0') { - set_errno(ENOENT); - set_vaxc_errno(LIB$_INVARG); + SETERRNO(ENOENT, LIB$_INVARG); return -1; } /* Convert to VMS format ensuring that it will fit in 255 characters */ - if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS) == NULL) - return -1; - + if (do_rmsexpand(file, vmsspec, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL) == NULL) { + SETERRNO(ENOENT, LIB$_INVARG); + return -1; + } if (utimes != NULL) { /* Convert Unix time (seconds since 01-JAN-1970 00:00:00.00) * to VMS quadword time (100 nsec intervals since 01-JAN-1858 00:00:00.00). @@ -9758,14 +10735,12 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) unixtime >>= 1; secscale <<= 1; retsts = lib$emul(&secscale, &unixtime, &lowbit, bintime); if (!(retsts & 1)) { - set_errno(EVMSERR); - set_vaxc_errno(retsts); + SETERRNO(EVMSERR, retsts); return -1; } retsts = lib$addx(bintime,utime_baseadjust,bintime,&len); if (!(retsts & 1)) { - set_errno(EVMSERR); - set_vaxc_errno(retsts); + SETERRNO(EVMSERR, retsts); return -1; } } @@ -9773,8 +10748,7 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) /* Just get the current time in VMS format directly */ retsts = sys$gettim(bintime); if (!(retsts & 1)) { - set_errno(EVMSERR); - set_vaxc_errno(retsts); + SETERRNO(EVMSERR, retsts); return -1; } } @@ -9856,6 +10830,9 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) } return 0; + +#endif /* #if __CRTL_VER >= 70300000 */ + } /* end of my_utime() */ /*}}}*/ @@ -9890,7 +10867,7 @@ int Perl_my_utime(pTHX_ const char *file, const struct utimbuf *utimes) * * A better method might be to use sys$device_scan on the first call, and to * search for the device, returning an index into the cached array. - * The number returned would be more intelligable. + * The number returned would be more intelligible. * This is probably not worth it, and anyway would take quite a bit longer * on the first call. */ @@ -9908,7 +10885,7 @@ static mydev_t encode_dev (pTHX_ const char *dev) #if LOCKID_MASK { struct dsc$descriptor_s dev_desc; - unsigned long int status, lockid, item = DVI$_LOCKID; + unsigned long int status, lockid = 0, item = DVI$_LOCKID; /* For cluster-mounted disks, the disk lock identifier is unique, so we can try that first. */ @@ -9916,7 +10893,16 @@ static mydev_t encode_dev (pTHX_ const char *dev) dev_desc.dsc$b_dtype = DSC$K_DTYPE_T; dev_desc.dsc$b_class = DSC$K_CLASS_S; dev_desc.dsc$a_pointer = (char *) dev; /* Read only parameter */ - _ckvmssts(lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0)); + status = lib$getdvi(&item, 0, &dev_desc, &lockid, 0, 0); + if (!$VMS_STATUS_SUCCESS(status)) { + switch (status) { + case SS$_NOSUCHDEV: + SETERRNO(ENODEV, status); + return 0; + default: + _ckvmssts(status); + } + } if (lockid) return (lockid & ~LOCKID_MASK); } #endif @@ -9942,6 +10928,11 @@ static mydev_t encode_dev (pTHX_ const char *dev) return (enc | LOCKID_MASK); /* May have already overflowed into bit 31 */ } /* end of encode_dev() */ +#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \ + device_no = encode_dev(aTHX_ devname) +#else +#define VMS_DEVICE_ENCODE(device_no, devname, new_dev_no) \ + device_no = new_dev_no #endif static int @@ -9966,76 +10957,107 @@ is_null_device(name) return (*name++ == ':') && (*name != ':'); } -/* Do the permissions allow some operation? Assumes PL_statcache already set. */ -/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a - * subset of the applicable information. - */ -bool -Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp) -{ - return cando_by_name(bit,effective, statbufp->st_devnam); -} /* end of cando() */ -/*}}}*/ - -/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/ -I32 -Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname) +static I32 +Perl_cando_by_name_int + (pTHX_ I32 bit, bool effective, const char *fname, int opts) { - static char usrname[L_cuserid]; - static struct dsc$descriptor_s usrdsc = + char usrname[L_cuserid]; + struct dsc$descriptor_s usrdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, usrname}; - char vmsname[NAM$C_MAXRSS+1]; - char *fileified; - unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2]; + char *vmsname = NULL, *fileified = NULL; + unsigned long int objtyp = ACL$C_FILE, access, retsts, privused, iosb[2], flags; unsigned short int retlen, trnlnm_iter_count; struct dsc$descriptor_s namdsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; union prvdef curprv; - struct itmlst_3 armlst[3] = {{sizeof access, CHP$_ACCESS, &access, &retlen}, - {sizeof privused, CHP$_PRIVUSED, &privused, &retlen},{0,0,0,0}}; + struct itmlst_3 armlst[4] = {{sizeof access, CHP$_ACCESS, &access, &retlen}, + {sizeof privused, CHP$_PRIVUSED, &privused, &retlen}, + {sizeof flags, CHP$_FLAGS, &flags, &retlen},{0,0,0,0}}; struct itmlst_3 jpilst[3] = {{sizeof curprv, JPI$_CURPRIV, &curprv, &retlen}, {sizeof usrname, JPI$_USERNAME, &usrname, &usrdsc.dsc$w_length}, {0,0,0,0}}; struct itmlst_3 usrprolst[2] = {{sizeof curprv, CHP$_PRIV, &curprv, &retlen}, {0,0,0,0}}; struct dsc$descriptor_s usrprodsc = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0}; + Stat_t st; + static int profile_context = -1; if (!fname || !*fname) return FALSE; + /* Make sure we expand logical names, since sys$check_access doesn't */ fileified = PerlMem_malloc(VMS_MAXRSS); + if (fileified == NULL) _ckvmssts(SS$_INSFMEM); if (!strpbrk(fname,"/]>:")) { - strcpy(fileified,fname); - trnlnm_iter_count = 0; - while (!strpbrk(fileified,"/]>:>") && my_trnlnm(fileified,fileified,0)) { + strcpy(fileified,fname); + trnlnm_iter_count = 0; + while (!strpbrk(fileified,"/]>:") && my_trnlnm(fileified,fileified,0)) { trnlnm_iter_count++; if (trnlnm_iter_count >= PERL_LNM_MAX_ITER) break; + } + fname = fileified; + } + + vmsname = PerlMem_malloc(VMS_MAXRSS); + if (vmsname == NULL) _ckvmssts(SS$_INSFMEM); + if ( !(opts & PERL_RMSEXPAND_M_VMS_IN) ) { + /* Don't know if already in VMS format, so make sure */ + if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL)) { + PerlMem_free(fileified); + PerlMem_free(vmsname); + return FALSE; } - fname = fileified; } - if (!do_rmsexpand(fname, vmsname, 0, NULL, PERL_RMSEXPAND_M_VMS)) { - PerlMem_free(fileified); - return FALSE; + else { + strcpy(vmsname,fname); } + + /* sys$check_access needs a file spec, not a directory spec. + * Don't use flex_stat here, as that depends on thread context + * having been initialized, and we may get here during startup. + */ + retlen = namdsc.dsc$w_length = strlen(vmsname); - namdsc.dsc$a_pointer = vmsname; - if (vmsname[retlen-1] == ']' || vmsname[retlen-1] == '>' || - vmsname[retlen-1] == ':') { - if (!do_fileify_dirspec(vmsname,fileified,1)) return FALSE; - namdsc.dsc$w_length = strlen(fileified); - namdsc.dsc$a_pointer = fileified; + if (vmsname[retlen-1] == ']' + || vmsname[retlen-1] == '>' + || vmsname[retlen-1] == ':' + || (!stat(vmsname, (stat_t *)&st) && S_ISDIR(st.st_mode))) { + + if (!do_fileify_dirspec(vmsname,fileified,1,NULL)) { + PerlMem_free(fileified); + PerlMem_free(vmsname); + return FALSE; + } + fname = fileified; + } + else { + fname = vmsname; } + retlen = namdsc.dsc$w_length = strlen(fname); + namdsc.dsc$a_pointer = (char *)fname; + switch (bit) { case S_IXUSR: case S_IXGRP: case S_IXOTH: - access = ARM$M_EXECUTE; break; + access = ARM$M_EXECUTE; + flags = CHP$M_READ; + break; case S_IRUSR: case S_IRGRP: case S_IROTH: - access = ARM$M_READ; break; + access = ARM$M_READ; + flags = CHP$M_READ | CHP$M_USEREADALL; + break; case S_IWUSR: case S_IWGRP: case S_IWOTH: - access = ARM$M_WRITE; break; + access = ARM$M_WRITE; + flags = CHP$M_READ | CHP$M_WRITE; + break; case S_IDUSR: case S_IDGRP: case S_IDOTH: - access = ARM$M_DELETE; break; + access = ARM$M_DELETE; + flags = CHP$M_READ | CHP$M_WRITE; + break; default: - PerlMem_free(fileified); + if (fileified != NULL) + PerlMem_free(fileified); + if (vmsname != NULL) + PerlMem_free(vmsname); return FALSE; } @@ -10054,16 +11076,16 @@ Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname) /* find out the space required for the profile */ _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,0, - &usrprodsc.dsc$w_length,0)); + &usrprodsc.dsc$w_length,&profile_context)); /* allocate space for the profile and get it filled in */ usrprodsc.dsc$a_pointer = PerlMem_malloc(usrprodsc.dsc$w_length); if (usrprodsc.dsc$a_pointer == NULL) _ckvmssts(SS$_INSFMEM); _ckvmssts(sys$create_user_profile(&usrdsc,&usrprolst,0,usrprodsc.dsc$a_pointer, - &usrprodsc.dsc$w_length,0)); + &usrprodsc.dsc$w_length,&profile_context)); /* use the profile to check access to the file; free profile & analyze results */ - retsts = sys$check_access(&objtyp,&namdsc,0,armlst,0,0,0,&usrprodsc); + retsts = sys$check_access(&objtyp,&namdsc,0,armlst,&profile_context,0,0,&usrprodsc); PerlMem_free(usrprodsc.dsc$a_pointer); if (retsts == SS$_NOCALLPRIV) retsts = SS$_NOPRIV; /* not really 3rd party */ @@ -10080,18 +11102,48 @@ Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname) if (retsts == SS$_NOPRIV) set_errno(EACCES); else if (retsts == SS$_INVFILFOROP) set_errno(EINVAL); else set_errno(ENOENT); - PerlMem_free(fileified); + if (fileified != NULL) + PerlMem_free(fileified); + if (vmsname != NULL) + PerlMem_free(vmsname); return FALSE; } if (retsts == SS$_NORMAL || retsts == SS$_ACCONFLICT) { - PerlMem_free(fileified); + if (fileified != NULL) + PerlMem_free(fileified); + if (vmsname != NULL) + PerlMem_free(vmsname); return TRUE; } _ckvmssts(retsts); - PerlMem_free(fileified); + if (fileified != NULL) + PerlMem_free(fileified); + if (vmsname != NULL) + PerlMem_free(vmsname); return FALSE; /* Should never get here */ +} + +/* Do the permissions allow some operation? Assumes PL_statcache already set. */ +/* Do this via $Check_Access on VMS, since the CRTL stat() returns only a + * subset of the applicable information. + */ +bool +Perl_cando(pTHX_ Mode_t bit, bool effective, const Stat_t *statbufp) +{ + return cando_by_name_int + (bit, effective, statbufp->st_devnam, PERL_RMSEXPAND_M_VMS_IN); +} /* end of cando() */ +/*}}}*/ + + +/*{{{I32 cando_by_name(I32 bit, bool effective, char *fname)*/ +I32 +Perl_cando_by_name(pTHX_ I32 bit, bool effective, const char *fname) +{ + return cando_by_name_int(bit, effective, fname, 0); + } /* end of cando_by_name() */ /*}}}*/ @@ -10120,16 +11172,17 @@ Perl_flex_fstat(pTHX_ int fd, Stat_t *statbufp) statbufp->st_devnam, 0, NULL, - PERL_RMSEXPAND_M_VMS); + PERL_RMSEXPAND_M_VMS | PERL_RMSEXPAND_M_VMS_IN, + NULL, + NULL); if (cptr == NULL) statbufp->st_devnam[0] = 0; } PerlMem_free(vms_filename); VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino); -#ifndef _USE_STD_STAT - statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); -#endif + VMS_DEVICE_ENCODE + (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev); # ifdef RTL_USES_UTC # ifdef VMSISH_TIME @@ -10186,7 +11239,7 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) if (decc_bug_devnull != 0) { if (is_null_device(temp_fspec)) { /* Fake a stat() for the null device */ memset(statbufp,0,sizeof *statbufp); - statbufp->st_dev = encode_dev(aTHX_ "_NLA0:"); + VMS_DEVICE_ENCODE(statbufp->st_dev, "_NLA0:", 0); statbufp->st_mode = S_IFBLK | S_IREAD | S_IWRITE | S_IEXEC; statbufp->st_uid = 0x00010001; statbufp->st_gid = 0x0001; @@ -10206,10 +11259,20 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) * * If we are in Posix filespec mode, accept the filename as is. */ + + +#if __CRTL_VER >= 70300000 && !defined(__VAX) + /* The CRTL stat() falls down hard on multi-dot filenames in unix format unless + * DECC$EFS_CHARSET is in effect, so temporarily enable it if it isn't already. + */ + if (!decc_efs_charset) + decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,1); +#endif + #if __CRTL_VER >= 80200000 && !defined(__VAX) if (decc_posix_compliant_pathnames == 0) { #endif - if (do_fileify_dirspec(temp_fspec,fileified,0) != NULL) { + if (do_fileify_dirspec(temp_fspec,fileified,0,NULL) != NULL) { if (lstat_flag == 0) retval = stat(fileified,(stat_t *) statbufp); else @@ -10232,17 +11295,23 @@ Perl_flex_stat_int(pTHX_ const char *fspec, Stat_t *statbufp, int lstat_flag) save_spec = temp_fspec; } #endif + +#if __CRTL_VER >= 70300000 && !defined(__VAX) + /* As you were... */ + if (!decc_efs_charset) + decc$feature_set_value(decc$feature_get_index("DECC$EFS_CHARSET"),1,0); +#endif + if (!retval) { char * cptr; cptr = do_rmsexpand - (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS); + (save_spec, statbufp->st_devnam, 0, NULL, PERL_RMSEXPAND_M_VMS, NULL, NULL); if (cptr == NULL) statbufp->st_devnam[0] = 0; VMS_INO_T_COPY(statbufp->st_ino, statbufp->crtl_stat.st_ino); -#ifndef _USE_STD_STAT - statbufp->st_dev = encode_dev(aTHX_ statbufp->st_devnam); -#endif + VMS_DEVICE_ENCODE + (statbufp->st_dev, statbufp->st_devnam, statbufp->crtl_stat.st_dev); # ifdef RTL_USES_UTC # ifdef VMSISH_TIME if (VMSISH_TIME) { @@ -10323,185 +11392,17 @@ my_getlogin(void) * of each may be found in the Perl standard distribution. */ /* FIXME */ /*{{{int rmscopy(char *src, char *dst, int preserve_dates)*/ -#if defined(__VAX) || !defined(NAML$C_MAXRSS) -int -Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates) -{ - char vmsin[NAM$C_MAXRSS+1], vmsout[NAM$C_MAXRSS+1], esa[NAM$C_MAXRSS], - rsa[NAM$C_MAXRSS], ubf[32256]; - unsigned long int i, sts, sts2; - struct FAB fab_in, fab_out; - struct RAB rab_in, rab_out; - struct NAM nam; - struct XABDAT xabdat; - struct XABFHC xabfhc; - struct XABRDT xabrdt; - struct XABSUM xabsum; - - if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) || - !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) { - set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); - return 0; - } - - fab_in = cc$rms_fab; - fab_in.fab$l_fna = vmsin; - fab_in.fab$b_fns = strlen(vmsin); - fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI; - fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET; - fab_in.fab$l_fop = FAB$M_SQO; - fab_in.fab$l_nam = &nam; - fab_in.fab$l_xab = (void *) &xabdat; - - nam = cc$rms_nam; - nam.nam$l_rsa = rsa; - nam.nam$b_rss = sizeof(rsa); - nam.nam$l_esa = esa; - nam.nam$b_ess = sizeof (esa); - nam.nam$b_esl = nam.nam$b_rsl = 0; -#ifdef NAM$M_NO_SHORT_UPCASE - if (decc_efs_case_preserve) - nam.nam$b_nop |= NAM$M_NO_SHORT_UPCASE; -#endif - - xabdat = cc$rms_xabdat; /* To get creation date */ - xabdat.xab$l_nxt = (void *) &xabfhc; - - xabfhc = cc$rms_xabfhc; /* To get record length */ - xabfhc.xab$l_nxt = (void *) &xabsum; - - xabsum = cc$rms_xabsum; /* To get key and area information */ - - if (!((sts = sys$open(&fab_in)) & 1)) { - set_vaxc_errno(sts); - switch (sts) { - case RMS$_FNF: case RMS$_DNF: - set_errno(ENOENT); break; - case RMS$_DIR: - set_errno(ENOTDIR); break; - case RMS$_DEV: - set_errno(ENODEV); break; - case RMS$_SYN: - set_errno(EINVAL); break; - case RMS$_PRV: - set_errno(EACCES); break; - default: - set_errno(EVMSERR); - } - return 0; - } - - fab_out = fab_in; - fab_out.fab$w_ifi = 0; - fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT; - fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI; - fab_out.fab$l_fop = FAB$M_SQO; - fab_out.fab$l_fna = vmsout; - fab_out.fab$b_fns = strlen(vmsout); - fab_out.fab$l_dna = nam.nam$l_name; - fab_out.fab$b_dns = nam.nam$l_name ? nam.nam$b_name + nam.nam$b_type : 0; - - if (preserve_dates == 0) { /* Act like DCL COPY */ - nam.nam$b_nop |= NAM$M_SYNCHK; - fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */ - if (!((sts = sys$parse(&fab_out)) & 1)) { - set_errno(sts == RMS$_SYN ? EINVAL : EVMSERR); - set_vaxc_errno(sts); - return 0; - } - fab_out.fab$l_xab = (void *) &xabdat; - if (nam.nam$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1; - } - fab_out.fab$l_nam = (void *) 0; /* Done with NAM block */ - if (preserve_dates < 0) /* Clear all bits; we'll use it as a */ - preserve_dates =0; /* bitmask from this point forward */ - - if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc; - if (!((sts = sys$create(&fab_out)) & 1)) { - set_vaxc_errno(sts); - switch (sts) { - case RMS$_DNF: - set_errno(ENOENT); break; - case RMS$_DIR: - set_errno(ENOTDIR); break; - case RMS$_DEV: - set_errno(ENODEV); break; - case RMS$_SYN: - set_errno(EINVAL); break; - case RMS$_PRV: - set_errno(EACCES); break; - default: - set_errno(EVMSERR); - } - return 0; - } - fab_out.fab$l_fop |= FAB$M_DLT; /* in case we have to bail out */ - if (preserve_dates & 2) { - /* sys$close() will process xabrdt, not xabdat */ - xabrdt = cc$rms_xabrdt; -#ifndef __GNUC__ - xabrdt.xab$q_rdt = xabdat.xab$q_rdt; -#else - /* gcc doesn't like the assignment, since its prototype for xab$q_rdt - * is unsigned long[2], while DECC & VAXC use a struct */ - memcpy(xabrdt.xab$q_rdt,xabdat.xab$q_rdt,sizeof xabrdt.xab$q_rdt); -#endif - fab_out.fab$l_xab = (void *) &xabrdt; - } - - rab_in = cc$rms_rab; - rab_in.rab$l_fab = &fab_in; - rab_in.rab$l_rop = RAB$M_BIO; - rab_in.rab$l_ubf = ubf; - rab_in.rab$w_usz = sizeof ubf; - if (!((sts = sys$connect(&rab_in)) & 1)) { - sys$close(&fab_in); sys$close(&fab_out); - set_errno(EVMSERR); set_vaxc_errno(sts); - return 0; - } - - rab_out = cc$rms_rab; - rab_out.rab$l_fab = &fab_out; - rab_out.rab$l_rbf = ubf; - if (!((sts = sys$connect(&rab_out)) & 1)) { - sys$close(&fab_in); sys$close(&fab_out); - set_errno(EVMSERR); set_vaxc_errno(sts); - return 0; - } - - while ((sts = sys$read(&rab_in))) { /* always true */ - if (sts == RMS$_EOF) break; - rab_out.rab$w_rsz = rab_in.rab$w_rsz; - if (!(sts & 1) || !((sts = sys$write(&rab_out)) & 1)) { - sys$close(&fab_in); sys$close(&fab_out); - set_errno(EVMSERR); set_vaxc_errno(sts); - return 0; - } - } - - fab_out.fab$l_fop &= ~FAB$M_DLT; /* We got this far; keep the output */ - sys$close(&fab_in); sys$close(&fab_out); - sts = (fab_in.fab$l_sts & 1) ? fab_out.fab$l_sts : fab_in.fab$l_sts; - if (!(sts & 1)) { - set_errno(EVMSERR); set_vaxc_errno(sts); - return 0; - } - - return 1; - -} /* end of rmscopy() */ -#else -/* ODS-5 support version */ int Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates) { char *vmsin, * vmsout, *esa, *esa_out, *rsa, *ubf; unsigned long int i, sts, sts2; + int dna_len; struct FAB fab_in, fab_out; struct RAB rab_in, rab_out; - struct NAML nam; - struct NAML nam_out; + rms_setup_nam(nam); + rms_setup_nam(nam_out); struct XABDAT xabdat; struct XABFHC xabfhc; struct XABRDT xabrdt; @@ -10511,8 +11412,8 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates if (vmsin == NULL) _ckvmssts(SS$_INSFMEM); vmsout = PerlMem_malloc(VMS_MAXRSS); if (vmsout == NULL) _ckvmssts(SS$_INSFMEM); - if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1) || - !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1)) { + if (!spec_in || !*spec_in || !do_tovmsspec(spec_in,vmsin,1,NULL) || + !spec_out || !*spec_out || !do_tovmsspec(spec_out,vmsout,1,NULL)) { PerlMem_free(vmsin); PerlMem_free(vmsout); set_errno(EINVAL); set_vaxc_errno(LIB$_INVARG); @@ -10521,34 +11422,25 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates esa = PerlMem_malloc(VMS_MAXRSS); if (esa == NULL) _ckvmssts(SS$_INSFMEM); - nam = cc$rms_naml; fab_in = cc$rms_fab; - fab_in.fab$l_fna = (char *) -1; - fab_in.fab$b_fns = 0; - nam.naml$l_long_filename = vmsin; - nam.naml$l_long_filename_size = strlen(vmsin); + rms_set_fna(fab_in, nam, vmsin, strlen(vmsin)); fab_in.fab$b_shr = FAB$M_SHRPUT | FAB$M_UPI; fab_in.fab$b_fac = FAB$M_BIO | FAB$M_GET; fab_in.fab$l_fop = FAB$M_SQO; - fab_in.fab$l_naml = &nam; + rms_bind_fab_nam(fab_in, nam); fab_in.fab$l_xab = (void *) &xabdat; rsa = PerlMem_malloc(VMS_MAXRSS); if (rsa == NULL) _ckvmssts(SS$_INSFMEM); - nam.naml$l_rsa = NULL; - nam.naml$b_rss = 0; - nam.naml$l_long_result = rsa; - nam.naml$l_long_result_alloc = VMS_MAXRSS - 1; - nam.naml$l_esa = NULL; - nam.naml$b_ess = 0; - nam.naml$l_long_expand = esa; - nam.naml$l_long_expand_alloc = VMS_MAXRSS - 1; - nam.naml$b_esl = nam.naml$b_rsl = 0; - nam.naml$l_long_expand_size = 0; - nam.naml$l_long_result_size = 0; + rms_set_rsa(nam, rsa, (VMS_MAXRSS-1)); + rms_set_esa(fab_in, nam, esa, (VMS_MAXRSS-1)); + rms_nam_esl(nam) = 0; + rms_nam_rsl(nam) = 0; + rms_nam_esll(nam) = 0; + rms_nam_rsll(nam) = 0; #ifdef NAM$M_NO_SHORT_UPCASE if (decc_efs_case_preserve) - nam.naml$b_nop |= NAM$M_NO_SHORT_UPCASE; + rms_set_nam_nop(nam, NAM$M_NO_SHORT_UPCASE); #endif xabdat = cc$rms_xabdat; /* To get creation date */ @@ -10588,33 +11480,19 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates fab_out.fab$b_fac = FAB$M_BIO | FAB$M_PUT; fab_out.fab$b_shr = FAB$M_SHRGET | FAB$M_UPI; fab_out.fab$l_fop = FAB$M_SQO; - fab_out.fab$l_naml = &nam_out; - fab_out.fab$l_fna = (char *) -1; - fab_out.fab$b_fns = 0; - nam_out.naml$l_long_filename = vmsout; - nam_out.naml$l_long_filename_size = strlen(vmsout); - fab_out.fab$l_dna = (char *) -1; - fab_out.fab$b_dns = 0; - nam_out.naml$l_long_defname = nam.naml$l_long_name; - nam_out.naml$l_long_defname_size = - nam.naml$l_long_name ? - nam.naml$l_long_name_size + nam.naml$l_long_type_size : 0; - + rms_bind_fab_nam(fab_out, nam_out); + rms_set_fna(fab_out, nam_out, vmsout, strlen(vmsout)); + dna_len = rms_nam_namel(nam) ? rms_nam_name_type_l_size(nam) : 0; + rms_set_dna(fab_out, nam_out, rms_nam_namel(nam), dna_len); esa_out = PerlMem_malloc(VMS_MAXRSS); if (esa_out == NULL) _ckvmssts(SS$_INSFMEM); - nam_out.naml$l_rsa = NULL; - nam_out.naml$b_rss = 0; - nam_out.naml$l_long_result = NULL; - nam_out.naml$l_long_result_alloc = 0; - nam_out.naml$l_esa = NULL; - nam_out.naml$b_ess = 0; - nam_out.naml$l_long_expand = esa_out; - nam_out.naml$l_long_expand_alloc = VMS_MAXRSS - 1; + rms_set_rsa(nam_out, NULL, 0); + rms_set_esa(fab_out, nam_out, esa_out, (VMS_MAXRSS - 1)); if (preserve_dates == 0) { /* Act like DCL COPY */ - nam_out.naml$b_nop |= NAM$M_SYNCHK; + rms_set_nam_nop(nam_out, NAM$M_SYNCHK); fab_out.fab$l_xab = NULL; /* Don't disturb data from input file */ - if (!((sts = sys$parse(&fab_out)) & 1)) { + if (!((sts = sys$parse(&fab_out)) & STS$K_SUCCESS)) { PerlMem_free(vmsin); PerlMem_free(vmsout); PerlMem_free(esa); @@ -10625,13 +11503,14 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates return 0; } fab_out.fab$l_xab = (void *) &xabdat; - if (nam.naml$l_fnb & (NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) preserve_dates = 1; + if (rms_is_nam_fnb(nam, NAM$M_EXP_NAME | NAM$M_EXP_TYPE)) + preserve_dates = 1; } if (preserve_dates < 0) /* Clear all bits; we'll use it as a */ preserve_dates =0; /* bitmask from this point forward */ if (!(preserve_dates & 1)) fab_out.fab$l_xab = (void *) &xabfhc; - if (!((sts = sys$create(&fab_out)) & 1)) { + if (!((sts = sys$create(&fab_out)) & STS$K_SUCCESS)) { PerlMem_free(vmsin); PerlMem_free(vmsout); PerlMem_free(esa); @@ -10742,7 +11621,6 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates return 1; } /* end of rmscopy() */ -#endif /*}}}*/ @@ -10761,16 +11639,27 @@ rmsexpand_fromperl(pTHX_ CV *cv) dXSARGS; char *fspec, *defspec = NULL, *rslt; STRLEN n_a; + int fs_utf8, dfs_utf8; + fs_utf8 = 0; + dfs_utf8 = 0; if (!items || items > 2) Perl_croak(aTHX_ "Usage: VMS::Filespec::rmsexpand(spec[,defspec])"); fspec = SvPV(ST(0),n_a); + fs_utf8 = SvUTF8(ST(0)); if (!fspec || !*fspec) XSRETURN_UNDEF; - if (items == 2) defspec = SvPV(ST(1),n_a); - - rslt = do_rmsexpand(fspec,NULL,1,defspec,0); + if (items == 2) { + defspec = SvPV(ST(1),n_a); + dfs_utf8 = SvUTF8(ST(1)); + } + rslt = do_rmsexpand(fspec,NULL,1,defspec,0,&fs_utf8,&dfs_utf8); ST(0) = sv_newmortal(); - if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt)); + if (rslt != NULL) { + sv_usepvn(ST(0),rslt,strlen(rslt)); + if (fs_utf8) { + SvUTF8_on(ST(0)); + } + } XSRETURN(1); } @@ -10780,11 +11669,18 @@ vmsify_fromperl(pTHX_ CV *cv) dXSARGS; char *vmsified; STRLEN n_a; + int utf8_fl; if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmsify(spec)"); - vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1); + utf8_fl = SvUTF8(ST(0)); + vmsified = do_tovmsspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl); ST(0) = sv_newmortal(); - if (vmsified != NULL) sv_usepvn(ST(0),vmsified,strlen(vmsified)); + if (vmsified != NULL) { + sv_usepvn(ST(0),vmsified,strlen(vmsified)); + if (utf8_fl) { + SvUTF8_on(ST(0)); + } + } XSRETURN(1); } @@ -10794,11 +11690,18 @@ unixify_fromperl(pTHX_ CV *cv) dXSARGS; char *unixified; STRLEN n_a; + int utf8_fl; if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixify(spec)"); - unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1); + utf8_fl = SvUTF8(ST(0)); + unixified = do_tounixspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl); ST(0) = sv_newmortal(); - if (unixified != NULL) sv_usepvn(ST(0),unixified,strlen(unixified)); + if (unixified != NULL) { + sv_usepvn(ST(0),unixified,strlen(unixified)); + if (utf8_fl) { + SvUTF8_on(ST(0)); + } + } XSRETURN(1); } @@ -10808,11 +11711,18 @@ fileify_fromperl(pTHX_ CV *cv) dXSARGS; char *fileified; STRLEN n_a; + int utf8_fl; if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::fileify(spec)"); - fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1); + utf8_fl = SvUTF8(ST(0)); + fileified = do_fileify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl); ST(0) = sv_newmortal(); - if (fileified != NULL) sv_usepvn(ST(0),fileified,strlen(fileified)); + if (fileified != NULL) { + sv_usepvn(ST(0),fileified,strlen(fileified)); + if (utf8_fl) { + SvUTF8_on(ST(0)); + } + } XSRETURN(1); } @@ -10822,11 +11732,18 @@ pathify_fromperl(pTHX_ CV *cv) dXSARGS; char *pathified; STRLEN n_a; + int utf8_fl; if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::pathify(spec)"); - pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1); + utf8_fl = SvUTF8(ST(0)); + pathified = do_pathify_dirspec(SvPV(ST(0),n_a),NULL,1,&utf8_fl); ST(0) = sv_newmortal(); - if (pathified != NULL) sv_usepvn(ST(0),pathified,strlen(pathified)); + if (pathified != NULL) { + sv_usepvn(ST(0),pathified,strlen(pathified)); + if (utf8_fl) { + SvUTF8_on(ST(0)); + } + } XSRETURN(1); } @@ -10836,11 +11753,18 @@ vmspath_fromperl(pTHX_ CV *cv) dXSARGS; char *vmspath; STRLEN n_a; + int utf8_fl; if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::vmspath(spec)"); - vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1); + utf8_fl = SvUTF8(ST(0)); + vmspath = do_tovmspath(SvPV(ST(0),n_a),NULL,1,&utf8_fl); ST(0) = sv_newmortal(); - if (vmspath != NULL) sv_usepvn(ST(0),vmspath,strlen(vmspath)); + if (vmspath != NULL) { + sv_usepvn(ST(0),vmspath,strlen(vmspath)); + if (utf8_fl) { + SvUTF8_on(ST(0)); + } + } XSRETURN(1); } @@ -10850,11 +11774,18 @@ unixpath_fromperl(pTHX_ CV *cv) dXSARGS; char *unixpath; STRLEN n_a; + int utf8_fl; if (items != 1) Perl_croak(aTHX_ "Usage: VMS::Filespec::unixpath(spec)"); - unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1); + utf8_fl = SvUTF8(ST(0)); + unixpath = do_tounixpath(SvPV(ST(0),n_a),NULL,1,&utf8_fl); ST(0) = sv_newmortal(); - if (unixpath != NULL) sv_usepvn(ST(0),unixpath,strlen(unixpath)); + if (unixpath != NULL) { + sv_usepvn(ST(0),unixpath,strlen(unixpath)); + if (utf8_fl) { + SvUTF8_on(ST(0)); + } + } XSRETURN(1); } @@ -11115,15 +12046,18 @@ Perl_vms_start_glob } } if ((tmpfp = PerlIO_tmpfile()) != NULL) { + int found = 0; Stat_t st; int stat_sts; stat_sts = PerlLIO_stat(SvPVX_const(tmpglob),&st); if (!stat_sts && S_ISDIR(st.st_mode)) { - wilddsc.dsc$a_pointer = tovmspath(SvPVX(tmpglob),vmsspec); + wilddsc.dsc$a_pointer = tovmspath_utf8(SvPVX(tmpglob),vmsspec,NULL); ok = (wilddsc.dsc$a_pointer != NULL); + /* maybe passed 'foo' rather than '[.foo]', thus not detected above */ + hasdir = 1; } else { - wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec); + wilddsc.dsc$a_pointer = tovmsspec_utf8(SvPVX(tmpglob),vmsspec,NULL); ok = (wilddsc.dsc$a_pointer != NULL); } if (ok) @@ -11145,12 +12079,14 @@ Perl_vms_start_glob if (!$VMS_STATUS_SUCCESS(sts)) break; + found++; + /* with varying string, 1st word of buffer contains result length */ rstr[rslt->length] = '\0'; /* Find where all the components are */ v_sts = vms_split_path - (aTHX_ rstr, + (rstr, &v_spec, &v_len, &r_spec, @@ -11192,6 +12128,14 @@ Perl_vms_start_glob ok = (PerlIO_puts(tmpfp,begin) != EOF); } if (cxt) (void)lib$find_file_end(&cxt); + + if (!found) { + /* Be POSIXish: return the input pattern when no matches */ + begin = SvPVX(tmpglob); + strcat(begin,"\n"); + ok = (PerlIO_puts(tmpfp,begin) != EOF); + } + if (ok && sts != RMS$_NMF && sts != RMS$_DNF && sts != RMS_FNF) ok = 0; if (!ok) { @@ -11213,9 +12157,11 @@ Perl_vms_start_glob return fp; } + #ifdef HAS_SYMLINK static char * -mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec); +mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, + const int *utf8_fl); void vms_realpath_fromperl(pTHX_ CV *cv) @@ -11231,7 +12177,7 @@ vms_realpath_fromperl(pTHX_ CV *cv) if (!fspec || !*fspec) XSRETURN_UNDEF; Newx(rslt_spec, VMS_MAXRSS + 1, char); - rslt = do_vms_realpath(fspec, rslt_spec); + rslt = do_vms_realpath(fspec, rslt_spec, NULL); ST(0) = sv_newmortal(); if (rslt != NULL) sv_usepvn(ST(0),rslt,strlen(rslt)); @@ -11328,17 +12274,18 @@ char *realpath(const char *file_name, char * resolved_name, ...); * on OpenVMS. */ static char * -mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf) +mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, + const int *utf8_fl) { return realpath(filespec, outbuf); } /*}}}*/ /* External entry points */ -char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf) -{ return do_vms_realpath(filespec, outbuf); } +char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl) +{ return do_vms_realpath(filespec, outbuf, utf8_fl); } #else -char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf) +char *Perl_vms_realpath(pTHX_ const char *filespec, char *outbuf, int *utf8_fl) { return NULL; } #endif @@ -11434,7 +12381,6 @@ static int sys_crelnm return ret_val; } - /* C RTL Feature settings */ static int set_features @@ -11464,6 +12410,34 @@ static int set_features vms_debug_on_exception = 0; } + /* Create VTF-7 filenames from Unicode instead of UTF-8 */ + vms_vtf7_filenames = 0; + status = sys_trnlnm("PERL_VMS_VTF7_FILENAMES", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) + vms_vtf7_filenames = 1; + else + vms_vtf7_filenames = 0; + } + + /* Dectect running under GNV Bash or other UNIX like shell */ +#if __CRTL_VER >= 70300000 && !defined(__VAX) + gnv_unix_shell = 0; + status = sys_trnlnm("GNV$UNIX_SHELL", val_str, sizeof(val_str)); + if ($VMS_STATUS_SUCCESS(status)) { + if ((val_str[0] == 'E') || (val_str[0] == '1') || (val_str[0] == 'T')) { + gnv_unix_shell = 1; + set_feature_default("DECC$EFS_CASE_PRESERVE", 1); + set_feature_default("DECC$EFS_CHARSET", 1); + set_feature_default("DECC$FILENAME_UNIX_NO_VERSION", 1); + set_feature_default("DECC$FILENAME_UNIX_REPORT", 1); + set_feature_default("DECC$READDIR_DROPDOTNOTYPE", 1); + set_feature_default("DECC$DISABLE_POSIX_ROOT", 0); + } + else + gnv_unix_shell = 0; + } +#endif /* hacks to see if known bugs are still present for testing */ @@ -11669,25 +12643,19 @@ static int set_features } #ifdef __DECC -/* DECC dependent attributes */ -#if __DECC_VER < 60560002 -#define relative -#define not_executable -#else -#define relative ,rel -#define not_executable ,noexe -#endif #pragma nostandard #pragma extern_model save #pragma extern_model strict_refdef "LIB$INITIALIZ" nowrt -#endif const __align (LONGWORD) int spare[8] = {0}; -/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, */ -/* NOWRT, LONG */ -#ifdef __DECC -#pragma extern_model strict_refdef "LIB$INITIALIZE" con, gbl,noshr, \ - nowrt,noshr relative not_executable + +/* .psect LIB$INITIALIZE, NOPIC, USR, CON, REL, GBL, NOSHR, NOEXE, RD, NOWRT, LONG */ +#if __DECC_VER >= 60560002 +#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, rel, gbl, noshr, noexe, nowrt, long +#else +#pragma extern_model strict_refdef "LIB$INITIALIZE" nopic, con, gbl, noshr, nowrt, long #endif +#endif /* __DECC */ + const long vms_cc_features = (const long)set_features; /*