From b1a8dcd70a1b7c58d934599729e8fb3ac06cf406 Mon Sep 17 00:00:00 2001 From: "John E. Malmberg" Date: Sat, 17 Nov 2007 20:15:22 -0600 Subject: [PATCH] [patch@32376] VMS symbolic links part 4 of 4 - Final part From: "John E. Malmberg" Message-id: <473FF49A.5000302@qsl.net> [.vms...] parts with revisions to compile on older systems and some POD clean-up. p4raw-id: //depot/perl@32474 --- vms/ext/Filespec.pm | 116 +++++++++++++++++++++++++++++++++++++++++++++++++--- vms/vms.c | 111 ++++++++++++++++++++++++++++++++++++++++--------- vms/vmsish.h | 1 + 3 files changed, 202 insertions(+), 26 deletions(-) diff --git a/vms/ext/Filespec.pm b/vms/ext/Filespec.pm index e0a179b..842e778 100644 --- a/vms/ext/Filespec.pm +++ b/vms/ext/Filespec.pm @@ -3,7 +3,7 @@ # # Version: see $VERSION below # Author: Charles Bailey bailey@newman.upenn.edu -# Revised: 08-Mar-1995 +# Revised: 30-Oct-2007 =head1 NAME @@ -20,6 +20,9 @@ $dirfile = fileify('my:[VMS.or.Unix.directory.specification]'); $vmsdir = vmspath('my/VMS/or/Unix/directory/specification.dir'); $unixdir = unixpath('my:[VMS.or.Unix.directory]specification.dir'); candelete('my:[VMS.or.Unix]file.specification'); +$case_tolerant = vms_case_tolerant; +$unixspec = vms_realpath('file_specification'); +$vmsspec = vms_realname('file_specification'); =head1 DESCRIPTION @@ -72,13 +75,81 @@ file specification or the default specification passed to C. as possible.) If an error occurs, returns C and sets C<$!> and C<$^E>. +C on success will produce a name that fits in a 255 byte buffer, +which is required for parameters passed to the DCL interpreter. + =head2 vmsify -Converts a file specification to VMS syntax. +Converts a file specification to VMS syntax. If the file specification +cannot be converted to or is already in VMS syntax, it will be +passed through unchanged. + +The file specifications of C<.> and C<..> will be converted to +C<[]> and C<[-]>. + +If the file specification is already in a valid VMS syntax, it will +be passed through unchanged, except that the UTF-8 flag will be cleared +since VMS format file specifications are never in UTF-8. + +When Perl is running on an OpenVMS system, if the C +feature is not enabled, extra dots in the file specification will +be converted to underscore characters, and the C character will +be converted to a C<%> character, if a conversion is done. + +When Perl is running on an OpenVMS system, if the C +feature is enabled, this implies that the UNIX pathname can not have +a version, and that a path consisting of three dots, C<./.../>, will be +converted to C<[.^.^.^.]>. + +UNIX style shell macros like C<$(abcd)> are passed through instead +of being converted to C<$^(abcd^)> independent of the C +feature setting. UNIX style shell macros should not use characters +that are not in the ASCII character set, as the resulting specification +may or may not be still in UTF8 format. + +The feature logical name C controls if UNICODE +characters in UNIX filenames are encoded in VTF-7 notation in the resulting +OpenVMS file specification. [Currently under development] + +C on the resulting file specification may not result in the +original UNIX file specification, so programs should not plan to convert +a file specification from UNIX to VMS and then back to UNIX again after +modification of the components. =head2 unixify -Converts a file specification to Unix syntax. +Converts a file specification to Unix syntax. If the file specification +cannot be converted to or is already in UNIX syntax, it will be passed +through unchanged. + +When Perl is running on an OpenVMS system, the following C feature +settings will control how the filename is converted: + + C default = C + C default = C + C default = C + C default = C + C default = C + +When Perl is being run under a UNIX shell on OpenVMS, the defaults at +a future time may be more appropriate for it. + +When Perl is running on an OpenVMS system with C enabled, +a wild card directory name of C<[...]> can not be translated to a valid +UNIX file specification when a conversion is done. + +When Perl is running on an OpenVMS system with C enabled, +directory file specifications will have their implied ".dir;1" removed, +and a trailing C<.> character indicating a null extension will be removed. + +Note that C requires C because +the conversion routine can not differentiate whether the last C<.> of a UNIX +specification is delimiting a version, or is just part of a file specification. + +C on the resulting file specification may not result in the +original VMS file specification, so programs should not plan to convert +a file specification from VMS to UNIX and then back to VMS again after +modification. =head2 pathify @@ -119,16 +190,45 @@ it's a list operator, so you need to be careful about parentheses. Both of these restrictions may be removed in the future if the functionality of C becomes part of the Perl core. +=head2 vms_case_tolerant + +This reports whether the VMS process has been set to a case tolerant state. +It is intended for use by the File::Spec::VMS->case_tolerant method only, and +it is recommended that you only use File::Spec->case_tolerant. + +=head2 vms_realpath + +This exposes the VMS C library C function where available. +It will always return a UNIX format specification. + +If the C function is not available, or is unable to return the +real path of the file, C will use the C +function and convert the output to a UNIX format specification. + +This function is intended for use by Cwd.pm for the implementation of +the abs_path function with support for symbolic links. It is not available +on non-VMS systems. + +head2 vms_realname + +This uses the VMS LIB$FID_TO_NAME function to find the name of the primary +link to a file, and returns the filename in VMS format. + +This function is intended for use by Cwd.pm for the implementation of +the abs_path function with support for symbolic links. It is not available +on non-VMS systems. + + =head1 REVISION -This document was last revised 22-Feb-1996, for Perl 5.002. +This document was last revised 15-Nov-2007, for Perl 5.10.0 =cut package VMS::Filespec; require 5.002; -our $VERSION = '1.11'; +our $VERSION = '1.12'; # If you want to use this package on a non-VMS system, # uncomment the following line. @@ -137,7 +237,7 @@ require Exporter; @ISA = qw( Exporter ); @EXPORT = qw( &vmsify &unixify &pathify &fileify - &vmspath &unixpath &candelete &rmsexpand ); + &vmspath &unixpath &candelete &rmsexpand &vms_case_tolerant ); 1; @@ -349,3 +449,7 @@ sub candelete ($) { } else { return (-w '[-]'); } } + +sub vms_case_tolerant ($) { + return 0; +} diff --git a/vms/vms.c b/vms/vms.c index 3a83b8e..a45dee5 100644 --- a/vms/vms.c +++ b/vms/vms.c @@ -272,6 +272,7 @@ struct vs_str_st { #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_vms_realname(a,b,c) mp_do_vms_realname(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) @@ -5343,13 +5344,14 @@ mp_do_rmsexpand /* Unless we are forcing to VMS format, a UNIX input means * UNIX output, and that requires long names to be used */ +#if !defined(__VAX) && defined(NAML$C_MAXRSS) if ((opts & PERL_RMSEXPAND_M_VMS) == 0) opts |= PERL_RMSEXPAND_M_LONG; - else { + else +#endif isunix = 0; } } - } rms_set_fna(myfab, mynam, (char *)filespec, strlen(filespec)); /* cast ok */ rms_bind_fab_nam(myfab, mynam); @@ -12091,7 +12093,7 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates return 0; } - esa = PerlMem_malloc(NAM$C_MAXRSS + 1); + esa = PerlMem_malloc(VMS_MAXRSS); if (esa == NULL) _ckvmssts(SS$_INSFMEM); esal = NULL; #if !defined(__VAX) && defined(NAML$C_MAXRSS) @@ -12106,7 +12108,7 @@ Perl_rmscopy(pTHX_ const char *spec_in, const char *spec_out, int preserve_dates rms_bind_fab_nam(fab_in, nam); fab_in.fab$l_xab = (void *) &xabdat; - rsa = PerlMem_malloc(NAML$C_MAXRSS); + rsa = PerlMem_malloc(VMS_MAXRSS); if (rsa == NULL) _ckvmssts(SS$_INSFMEM); rsal = NULL; #if !defined(__VAX) && defined(NAML$C_MAXRSS) @@ -12903,7 +12905,6 @@ Perl_vms_start_glob } -#ifdef HAS_SYMLINK static char * mp_do_vms_realpath(pTHX_ const char *filespec, char * rslt_spec, int *utf8_fl); @@ -12932,6 +12933,35 @@ vms_realpath_fromperl(pTHX_ CV *cv) XSRETURN(1); } +static char * +mp_do_vms_realname(pTHX_ const char *filespec, char * rslt_spec, + int *utf8_fl); + +void +vms_realname_fromperl(pTHX_ CV *cv) +{ + dXSARGS; + char *fspec, *rslt_spec, *rslt; + STRLEN n_a; + + if (!items || items != 1) + Perl_croak(aTHX_ "Usage: VMS::Filespec::vms_realname(spec)"); + + fspec = SvPV(ST(0),n_a); + if (!fspec || !*fspec) XSRETURN_UNDEF; + + Newx(rslt_spec, VMS_MAXRSS + 1, char); + rslt = do_vms_realname(fspec, rslt_spec, NULL); + + ST(0) = sv_newmortal(); + if (rslt != NULL) + sv_usepvn(ST(0),rslt,strlen(rslt)); + else + Safefree(rslt_spec); + XSRETURN(1); +} + +#ifdef HAS_SYMLINK /* * A thin wrapper around decc$symlink to make sure we follow the * standard and do not create a symlink with a zero-length name. @@ -12948,7 +12978,6 @@ int my_symlink(const char *path1, const char *path2) { #endif /* HAS_SYMLINK */ -#if __CRTL_VER >= 70301000 && !defined(__VAX) int do_vms_case_tolerant(void); void @@ -12958,7 +12987,6 @@ vms_case_tolerant_fromperl(pTHX_ CV *cv) ST(0) = boolSV(do_vms_case_tolerant()); XSRETURN(1); } -#endif void Perl_sys_intern_dup(pTHX_ struct interp_intern *src, @@ -13010,21 +13038,16 @@ init_os_extras(void) newXSproto("DynaLoader::mod2fname", mod2fname, file, "$"); newXS("File::Copy::rmscopy",rmscopy_fromperl,file); newXSproto("vmsish::hushed",hushexit_fromperl,file,";$"); -#ifdef HAS_SYMLINK newXSproto("VMS::Filespec::vms_realpath",vms_realpath_fromperl,file,"$;$"); -#endif -#if __CRTL_VER >= 70301000 && !defined(__VAX) + newXSproto("VMS::Filespec::vms_realname",vms_realname_fromperl,file,"$;$"); newXSproto("VMS::Filepec::vms_case_tolerant", vms_case_tolerant_fromperl, file, "$"); -#endif store_pipelocs(aTHX); /* will redo any earlier attempts */ return; } -#ifdef HAS_SYMLINK - #if __CRTL_VER == 80200000 /* This missed getting in to the DECC SDK for 8.2 */ char *realpath(const char *file_name, char * resolved_name, ...); @@ -13052,7 +13075,7 @@ int vms_fid_to_name(char * outname, int outlen, const char * name) { struct statbuf_t { char * st_dev; - __ino16_t st_ino[3]; + unsigned short st_ino[3]; unsigned short padw; unsigned long padl[30]; /* plenty of room */ } statbuf; @@ -13087,8 +13110,15 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, { char * rslt = NULL; - if (decc_posix_compliant_pathnames) +#ifdef HAS_SYMLINK + if (decc_posix_compliant_pathnames > 0 ) { + /* realpath currently only works if posix compliant pathnames are + * enabled. It may start working when they are not, but in that + * case we still want the fallback behavior for backwards compatibility + */ rslt = realpath(filespec, outbuf); + } +#endif if (rslt == NULL) { char * vms_spec; @@ -13138,17 +13168,57 @@ mp_do_vms_realpath(pTHX_ const char *filespec, char *outbuf, return rslt; } +static char * +mp_do_vms_realname(pTHX_ const char *filespec, char *outbuf, + int *utf8_fl) +{ + 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; + int file_len; + + /* Fall back to fid_to_name */ + + sts = vms_fid_to_name(outbuf, VMS_MAXRSS + 1, filespec); + if (sts == 0) { + + + /* Now need to trim the version off */ + sts = vms_split_path + (outbuf, + &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) { + int file_len; + + /* Trim off the version */ + file_len = v_len + r_len + d_len + n_len + e_len; + outbuf[file_len] = 0; + } + } + return outbuf; +} + + /*}}}*/ /* External entry points */ 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, int *utf8_fl) -{ return NULL; } -#endif +char *Perl_vms_realname(pTHX_ const char *filespec, char *outbuf, int *utf8_fl) +{ return do_vms_realname(filespec, outbuf, utf8_fl); } -#if __CRTL_VER >= 70301000 && !defined(__VAX) /* case_tolerant */ /*{{{int do_vms_case_tolerant(void)*/ @@ -13161,6 +13231,7 @@ int do_vms_case_tolerant(void) } /*}}}*/ /* External entry points */ +#if __CRTL_VER >= 70301000 && !defined(__VAX) int Perl_vms_case_tolerant(void) { return do_vms_case_tolerant(); } #else diff --git a/vms/vmsish.h b/vms/vmsish.h index f5622ba..90311a0 100644 --- a/vms/vmsish.h +++ b/vms/vmsish.h @@ -280,6 +280,7 @@ #endif #define init_os_extras Perl_init_os_extras #define vms_realpath(a, b, c) Perl_vms_realpath(aTHX_ a,b,c) +#define vms_realname(a, b, c) Perl_vms_realname(aTHX_ a,b,c) #define vms_case_tolerant(a) Perl_vms_case_tolerant(a) /* Delete if at all possible, changing protections if necessary. */ -- 2.7.4