From: Jarkko Hietaniemi Date: Wed, 26 Sep 2001 12:53:16 +0000 (+0000) Subject: Integrate macperl changes from Chris Nandor: X-Git-Tag: accepted/trunk/20130322.191538~30098 X-Git-Url: http://review.tizen.org/git/?a=commitdiff_plain;h=be708cc0141c68546a70e3d19f68ad41bef15add;p=platform%2Fupstream%2Fperl.git Integrate macperl changes from Chris Nandor: 12192 11817 11815 11813 11778 11775 Update CPAN.pm to work with new Mac::BuildTools instead of ExtUtils::MM_MacOS "orphan" functions Fix test Make syntax check report in MPW style, fix tests to use Mac::err=unix to get normal-style error messages. More module and test ports from Thomas Wegner et al Fix open of /dev/null for Mac OS Allow for platforms to override formatting of errors on output from Matthias Neeracher (core files) p4raw-id: //depot/perl@12235 p4raw-edited: from //depot/maint-5.6/macperl@12234 'edit in' lib/File/DosGlob.pm t/op/magic.t (@11007..) p4raw-integrated: from //depot/maint-5.6/macperl@12234 'copy in' lib/File/Spec/Mac.pm lib/File/Temp.pm (@11007..) 'merge in' ext/File/Glob/Glob.pm lib/CPAN.pm (@11007..) ext/File/Glob/bsd_glob.c t/base/term.t (@11185..) t/op/runlevel.t (@11198..) t/pod/testp2pt.pl (@11500..) p4raw-integrated: from //depot/maint-5.6/macperl@11815 'merge in' perl.c (@11806..) p4raw-integrated: from //depot/maint-5.6/macperl@11775 'merge in' perl.h pp_ctl.c util.c (@11007..) --- diff --git a/ext/B/Deparse.t b/ext/B/Deparse.t index 0aff882..b8e29a6 100644 --- a/ext/B/Deparse.t +++ b/ext/B/Deparse.t @@ -95,10 +95,11 @@ my $Is_VMS = $^O eq 'VMS'; my $Is_MacOS = $^O eq 'MacOS'; my $path = join " ", map { qq["-I$_"] } @INC; +$path .= " -MMac::err=unix" if $Is_MacOS; my $redir = $Is_MacOS ? "" : "2>&1"; $a = `$^X $path "-MO=Deparse" -anle 1 $redir`; -$a =~ s/-e syntax OK\n//g; +$a =~ s/(?:# )?-e syntax OK\n//g; # "# " for Mac OS $a =~ s{\\340\\242}{\\s} if (ord("\\") == 224); # EBCDIC, cp 1047 or 037 $a =~ s{\\274\\242}{\\s} if (ord("\\") == 188); # $^O eq 'posix-bc' $b = <<'EOF'; diff --git a/ext/File/Glob/Glob.pm b/ext/File/Glob/Glob.pm index cad8131..a704b56 100644 --- a/ext/File/Glob/Glob.pm +++ b/ext/File/Glob/Glob.pm @@ -384,7 +384,7 @@ the standard Perl distribution. Mac OS (Classic) users should note a few differences. Since Mac OS is not Unix, when the glob code encounters a tilde glob (e.g. -~user/foo) and the C flag is used, it simply returns that +~user) and the C flag is used, it simply returns that pattern without doing any expansion. Glob on Mac OS is case-insensitive by default (if you don't use any @@ -397,6 +397,29 @@ always begins with a volume name, a relative pathname should always begin with a ':'. If specifying a volume name only, a trailing ':' is required. +The specification of pathnames in glob patterns adheres to the usual Mac +OS conventions: The path separator is a colon ':', not a slash '/'. A +full path always begins with a volume name. A relative pathname on Mac +OS must always begin with a ':', except when specifying a file or +directory name in the current working directory, where the leading colon +is optional. If specifying a volume name only, a trailing ':' is +required. Due to these rules, a glob like E*:E will find all +mounted volumes, while a glob like E*E or E:*E will find +all files and directories in the current directory. + +Note that updirs in the glob pattern are resolved before the matching begins, +i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also, +that a single trailing ':' in the pattern is ignored (unless it's a volume +name pattern like "*HD:"), i.e. a glob like E:*:E will find both +directories I files (and not, as one might expect, only directories). +You can, however, use the C flag to distinguish (without a file +test) directory names from file names. + +If the C flag is set, all directory paths will have a ':' appended. +Since a directory like 'lib:' is I a valid I path on Mac OS, +both a leading and a trailing colon will be added, when the directory name in +question doesn't contain any colons (e.g. 'lib' becomes ':lib:'). + =back =head1 AUTHOR diff --git a/ext/File/Glob/bsd_glob.c b/ext/File/Glob/bsd_glob.c index fa601fc..d0d4a91 100644 --- a/ext/File/Glob/bsd_glob.c +++ b/ext/File/Glob/bsd_glob.c @@ -206,6 +206,23 @@ my_readdir(DIR *d) #define my_readdir readdir #endif +#ifdef MACOS_TRADITIONAL +#include +#include +#include + +#define NO_UPDIR_ERR 1 /* updir resolving failed */ + +static Boolean g_matchVol; /* global variable */ +static short updir(char *path); +static short resolve_updirs(char *new_pattern); +static void remove_trColon(char *path); +static short glob_mark_Mac(Char *pathbuf, Char *pathend, Char *pathend_last); +static OSErr GetVolInfo(short volume, Boolean indexed, FSSpec *spec); +static void name_f_FSSpec(StrFileName volname, FSSpec *spec); + +#endif + int bsd_glob(const char *pattern, int flags, int (*errfunc)(const char *, int), glob_t *pglob) @@ -214,7 +231,15 @@ bsd_glob(const char *pattern, int flags, int c; Char *bufnext, *bufend, patbuf[MAXPATHLEN]; +#ifdef MACOS_TRADITIONAL + char *new_pat, *p, *np; + int err; + size_t len; +#endif + +#ifndef MACOS_TRADITIONAL patnext = (U8 *) pattern; +#endif if (!(flags & GLOB_APPEND)) { pglob->gl_pathc = 0; pglob->gl_pathv = NULL; @@ -246,6 +271,62 @@ bsd_glob(const char *pattern, int flags, patnext += 2; } #endif + +#ifdef MACOS_TRADITIONAL + /* Check if we need to match a volume name (e.g. '*HD:*') */ + g_matchVol = false; + p = (char *) pattern; + if (*p != BG_SEP) { + p++; + while (*p != BG_EOS) { + if (*p == BG_SEP) { + g_matchVol = true; + break; + } + p++; + } + } + + /* Transform the pattern: + * (a) Resolve updirs, e.g. + * '*:t*p::' -> '*:' + * ':a*:tmp::::' -> '::' + * ':base::t*p:::' -> '::' + * '*HD::' -> return 0 (error, quit silently) + * + * (b) Remove a single trailing ':', unless it's a "match volume only" + * pattern like '*HD:'; e.g. + * '*:tmp:' -> '*:tmp' but + * '*HD:' -> '*HD:' + * (If we don't do that, even filenames will have a trailing ':' in + * the result.) + */ + + /* We operate on a copy of the pattern */ + len = strlen(pattern); + New(0, new_pat, len + 1, char); + if (new_pat == NULL) + return (GLOB_NOSPACE); + + p = (char *) pattern; + np = new_pat; + while (*np++ = *p++) ; + + /* Resolve updirs ... */ + err = resolve_updirs(new_pat); + if (err) { + Safefree(new_pat); + /* The pattern is incorrect: tried to move + up above the volume root, see above. + We quit silently. */ + return 0; + } + /* remove trailing colon ... */ + remove_trColon(new_pat); + patnext = (U8 *) new_pat; + +#endif /* MACOS_TRADITIONAL */ + if (flags & GLOB_QUOTE) { /* Protect the quoted characters. */ while (bufnext < bufend && (c = *patnext++) != BG_EOS) @@ -273,10 +354,19 @@ bsd_glob(const char *pattern, int flags, *bufnext++ = c; *bufnext = BG_EOS; +#ifdef MACOS_TRADITIONAL + if (flags & GLOB_BRACE) + err = globexp1(patbuf, pglob); + else + err = glob0(patbuf, pglob); + Safefree(new_pat); + return err; +#else if (flags & GLOB_BRACE) return globexp1(patbuf, pglob); else return glob0(patbuf, pglob); +#endif } /* @@ -582,7 +672,7 @@ glob0(const Char *pattern, glob_t *pglob) } else if (!(pglob->gl_flags & GLOB_NOSORT)) qsort(pglob->gl_pathv + pglob->gl_offs + oldpathc, - pglob->gl_pathc - oldpathc, sizeof(char *), + pglob->gl_pathc - oldpathc, sizeof(char *), (pglob->gl_flags & (GLOB_ALPHASORT|GLOB_NOCASE)) ? ci_compare : compare); pglob->gl_flags = oldflags; @@ -658,10 +748,17 @@ glob2(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, (S_ISLNK(sb.st_mode) && (g_stat(pathbuf, &sb, pglob) == 0) && S_ISDIR(sb.st_mode)))) { +#ifdef MACOS_TRADITIONAL + short err; + err = glob_mark_Mac(pathbuf, pathend, pathend_last); + if (err) + return (err); +#else if (pathend+1 > pathend_last) return (1); *pathend++ = BG_SEP; *pathend = BG_EOS; +#endif } ++pglob->gl_matchc; #ifdef GLOB_DEBUG @@ -746,6 +843,50 @@ glob3(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, } } #endif + +#ifdef MACOS_TRADITIONAL + if ((!*pathbuf) && (g_matchVol)) { + FSSpec spec; + short index; + StrFileName vol_name; /* unsigned char[64] on MacOS */ + + err = 0; + nocase = ((pglob->gl_flags & GLOB_NOCASE) != 0); + + /* Get and match a list of volume names */ + for (index = 0; !GetVolInfo(index+1, true, &spec); ++index) { + register U8 *sc; + register Char *dc; + + name_f_FSSpec(vol_name, &spec); + + /* Initial BG_DOT must be matched literally. */ + if (*vol_name == BG_DOT && *pattern != BG_DOT) + continue; + dc = pathend; + sc = (U8 *) vol_name; + while (dc < pathend_last && (*dc++ = *sc++) != BG_EOS) + ; + if (dc >= pathend_last) { + *dc = BG_EOS; + err = 1; + break; + } + + if (!match(pathend, pattern, restpattern, nocase)) { + *pathend = BG_EOS; + continue; + } + err = glob2(pathbuf, pathbuf_last, --dc, pathend_last, + restpattern, restpattern_last, pglob, limitp); + if (err) + break; + } + return(err); + + } else { /* open dir */ +#endif /* MACOS_TRADITIONAL */ + if ((dirp = g_opendir(pathbuf, pglob)) == NULL) { /* TODO: don't call for ENOENT or ENOTDIR? */ if (pglob->gl_errfunc) { @@ -798,6 +939,10 @@ glob3(Char *pathbuf, Char *pathbuf_last, Char *pathend, Char *pathend_last, else PerlDir_close(dirp); return(err); + +#ifdef MACOS_TRADITIONAL + } +#endif } @@ -1038,3 +1183,209 @@ qprintf(const char *str, register Char *s) (void)printf("\n"); } #endif /* GLOB_DEBUG */ + + +#ifdef MACOS_TRADITIONAL + +/* Replace the last occurence of the pattern ":[^:]+::", e.g. ":lib::", + with a single ':', if possible. It is not an error, if the pattern + doesn't match (we return -1), but if there are two consecutive colons + '::', there must be a preceding ':[^:]+'. Hence, a volume path like + "HD::" is considered to be an error (we return 1), that is, it can't + be resolved. We return 0 on success. +*/ + +static short +updir(char *path) +{ + char *pb, *pe, *lastchar; + char *bgn_mark, *end_mark; + char *f, *m, *b; /* front, middle, back */ + size_t len; + + len = strlen(path); + lastchar = path + (len-1); + b = lastchar; + m = lastchar-1; + f = lastchar-2; + + /* find a '[^:]::' (e.g. b::) pattern ... */ + while ( !( (*f != BG_SEP) && (*m == BG_SEP) && (*b == BG_SEP) ) + && (f >= path)) { + f--; + m--; + b--; + } + + if (f < path) { /* no (more) match */ + return -1; + } + + end_mark = b; + + /* ... and now find its preceding colon ':' */ + while ((*f != BG_SEP) && (f >= path)) { + f--; + } + if (f < path) { + /* No preceding colon found, must be a + volume path. We can't move up the + tree and that's an error */ + return 1; + } + bgn_mark = f; + + /* Shrink path, i.e. exclude all characters between + bgn_mark and end_mark */ + + pb = bgn_mark; + pe = end_mark; + while (*pb++ = *pe++) ; + return 0; +} + + +/* Resolve all updirs in pattern. */ + +static short +resolve_updirs(char *new_pattern) +{ + short err; + + do { + err = updir(new_pattern); + } while (!err); + if (err == 1) { + return NO_UPDIR_ERR; + } + return 0; +} + + +/* Remove a trailing colon from the path, but only if it's + not a volume path (e.g. HD:) and not a path consisting + solely of colons. */ + +static void +remove_trColon(char *path) +{ + char *lastchar, *lc; + + /* if path matches the pattern /:[^:]+:$/, we can + remove the trailing ':' */ + + lc = lastchar = path + (strlen(path) - 1); + if (*lastchar == BG_SEP) { + /* there's a trailing ':', there must be at least + one preceding char != ':' and a preceding ':' */ + lc--; + if ((*lc != BG_SEP) && (lc >= path)) { + lc--; + } else { + return; + } + while ((*lc != BG_SEP) && (lc >= path)) { + lc--; + } + if (lc >= path) { + /* ... there's a preceding ':', we remove + the trailing colon */ + *lastchar = BG_EOS; + } + } +} + + +/* With the GLOB_MARK flag on, we append a colon, if pathbuf + is a directory. If the directory name contains no colons, + e.g. 'lib', we can't simply append a ':', since this (e.g. + 'lib:') is not a valid (relative) path on Mac OS. Instead, + we add a leading _and_ trailing ':'. */ + +static short +glob_mark_Mac(Char *pathbuf, Char *pathend, Char *pathend_last) +{ + Char *p, *pe; + Boolean is_file = true; + + /* check if pathbuf contains a ':', + i.e. is not a file name */ + p = pathbuf; + while (*p != BG_EOS) { + if (*p == BG_SEP) { + is_file = false; + break; + } + p++; + } + + if (is_file) { + if (pathend+2 > pathend_last) { + return (1); + } + /* right shift one char */ + pe = p = pathend; + p--; + pathend++; + while (p >= pathbuf) { + *pe-- = *p--; + } + /* first char becomes a colon */ + *pathbuf = BG_SEP; + /* append a colon */ + *pathend++ = BG_SEP; + *pathend = BG_EOS; + + } else { + if (pathend+1 > pathend_last) { + return (1); + } + *pathend++ = BG_SEP; + *pathend = BG_EOS; + } + return 0; +} + + +/* Return a FSSpec record for the specified volume + (borrowed from MacPerl.xs). */ + +static OSErr +GetVolInfo(short volume, Boolean indexed, FSSpec* spec) +{ + OSErr err; /* OSErr: 16-bit integer */ + HParamBlockRec pb; + + pb.volumeParam.ioNamePtr = spec->name; + pb.volumeParam.ioVRefNum = indexed ? 0 : volume; + pb.volumeParam.ioVolIndex = indexed ? volume : 0; + + if (err = PBHGetVInfoSync(&pb)) + return err; + + spec->vRefNum = pb.volumeParam.ioVRefNum; + spec->parID = 1; + + return noErr; /* 0 */ +} + +/* Extract a C name from a FSSpec. Note that there are + no leading or trailing colons. */ + +static void +name_f_FSSpec(StrFileName name, FSSpec *spec) +{ + unsigned char *nc; + const short len = spec->name[0]; + short i; + + /* FSSpec.name is a Pascal string, + convert it to C ... */ + nc = name; + for (i=1; i<=len; i++) { + *nc++ = spec->name[i]; + } + *nc = BG_EOS; +} + +#endif /* MACOS_TRADITIONAL */ diff --git a/lib/CPAN.pm b/lib/CPAN.pm index db24a06..de1158d 100644 --- a/lib/CPAN.pm +++ b/lib/CPAN.pm @@ -25,6 +25,8 @@ use File::Spec; no lib "."; # we need to run chdir all over and we would get at wrong # libraries there +require Mac::BuildTools if $^O eq 'MacOS'; + END { $End++; &cleanup; } %CPAN::DEBUG = qw[ @@ -3964,7 +3966,7 @@ sub look { my($self) = @_; if ($^O eq 'MacOS') { - $self->ExtUtils::MM_MacOS::look; + $self->Mac::BuildTools::look; return; } @@ -4055,7 +4057,7 @@ sub readme { or $CPAN::Frontend->mydie(qq{No $sans.readme found});; if ($^O eq 'MacOS') { - ExtUtils::MM_MacOS::launch_file($local_file); + Mac::BuildTools::launch_file($local_file); return; } @@ -4357,7 +4359,7 @@ or $self->debug("Changed directory to $builddir") if $CPAN::DEBUG; if ($^O eq 'MacOS') { - ExtUtils::MM_MacOS::make($self); + Mac::BuildTools::make($self); return; } @@ -4603,7 +4605,7 @@ sub test { if $CPAN::DEBUG; if ($^O eq 'MacOS') { - ExtUtils::MM_MacOS::make_test($self); + Mac::BuildTools::make_test($self); return; } @@ -4634,7 +4636,7 @@ sub clean { $self->debug("Changed directory to $self->{'build_dir'}") if $CPAN::DEBUG; if ($^O eq 'MacOS') { - ExtUtils::MM_MacOS::make_clean($self); + Mac::BuildTools::make_clean($self); return; } @@ -4709,7 +4711,7 @@ sub install { if $CPAN::DEBUG; if ($^O eq 'MacOS') { - ExtUtils::MM_MacOS::make_install($self); + Mac::BuildTools::make_install($self); return; } @@ -4875,7 +4877,7 @@ sub find_bundle_file { my $what2 = $what; if ($^O eq 'MacOS') { $what =~ s/^://; - $what2 =~ tr|:|/|; + $what =~ tr|:|/|; $what2 =~ s/:Bundle://; $what2 =~ tr|:|/|; } else { @@ -5722,7 +5724,7 @@ is available. Can\'t continue. $tar->extract(@af); } - ExtUtils::MM_MacOS::convert_files([$tar->list_files], 1) + Mac::BuildTools::convert_files([$tar->list_files], 1) if ($^O eq 'MacOS'); return 1; diff --git a/lib/File/DosGlob.pm b/lib/File/DosGlob.pm index aa9beb9..a1c27d5 100644 --- a/lib/File/DosGlob.pm +++ b/lib/File/DosGlob.pm @@ -94,6 +94,207 @@ sub doglob { return @retval; } + +# +# Do DOS-like globbing on Mac OS +# +sub doglob_Mac { + my $cond = shift; + my @retval = (); + + #print "doglob_Mac: ", join('|', @_), "\n"; + OUTER: + for my $arg (@_) { + local $_ = $arg; + my @matched = (); + my @globdirs = (); + my $head = ':'; + my $not_esc_head = $head; + my $sepchr = ':'; + next OUTER unless defined $_ and $_ ne ''; + # if arg is within quotes strip em and do no globbing + if (/^"(.*)"\z/s) { + $_ = $1; + # $_ may contain escaped metachars '\*', '\?' and '\' + my $not_esc_arg = $_; + $not_esc_arg =~ s/\\([*?\\])/$1/g; + if ($cond eq 'd') { push(@retval, $not_esc_arg) if -d $not_esc_arg } + else { push(@retval, $not_esc_arg) if -e $not_esc_arg } + next OUTER; + } + + if (m|^(.*?)(:+)([^:]*)\z|s) { # note: $1 is not greedy + my $tail; + ($head, $sepchr, $tail) = ($1,$2,$3); + #print "div: |$head|$sepchr|$tail|\n"; + push (@retval, $_), next OUTER if $tail eq ''; + # + # $head may contain escaped metachars '\*' and '\?' + + my $tmp_head = $head; + # if a '*' or '?' is preceded by an odd count of '\', temporary delete + # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as + # wildcards + $tmp_head =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; + + if ($tmp_head =~ /[*?]/) { # if there are wildcards ... + @globdirs = doglob_Mac('d', $head); + push(@retval, doglob_Mac($cond, map {"$_$sepchr$tail"} @globdirs)), + next OUTER if @globdirs; + } + + $head .= $sepchr; + $not_esc_head = $head; + # unescape $head for file operations + $not_esc_head =~ s/\\([*?\\])/$1/g; + $_ = $tail; + } + # + # If file component has no wildcards, we can avoid opendir + + my $tmp_tail = $_; + # if a '*' or '?' is preceded by an odd count of '\', temporary delete + # it (and its preceding backslashes), i.e. don't treat '\*' and '\?' as + # wildcards + $tmp_tail =~ s/(\\*)([*?])/$2 x ((length($1) + 1) % 2)/eg; + + unless ($tmp_tail =~ /[*?]/) { # if there are wildcards ... + $not_esc_head = $head = '' if $head eq ':'; + my $not_esc_tail = $_; + # unescape $head and $tail for file operations + $not_esc_tail =~ s/\\([*?\\])/$1/g; + $head .= $_; + $not_esc_head .= $not_esc_tail; + if ($cond eq 'd') { push(@retval,$head) if -d $not_esc_head } + else { push(@retval,$head) if -e $not_esc_head } + next OUTER; + } + #print "opendir($not_esc_head)\n"; + opendir(D, $not_esc_head) or next OUTER; + my @leaves = readdir D; + closedir D; + + # escape regex metachars but not '\' and glob chars '*', '?' + $_ =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex, + # but only if they are not escaped + $_ =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; + + #print "regex: '$_', head: '$head', unescaped head: '$not_esc_head'\n"; + my $matchsub = eval 'sub { $_[0] =~ m|^' . $_ . '\\z|ios }'; + warn($@), next OUTER if $@; + INNER: + for my $e (@leaves) { + next INNER if $e eq '.' or $e eq '..'; + next INNER if $cond eq 'd' and ! -d "$not_esc_head$e"; + + if (&$matchsub($e)) { + my $leave = (($not_esc_head eq ':') && (-f "$not_esc_head$e")) ? + "$e" : "$not_esc_head$e"; + # + # On Mac OS, the two glob metachars '*' and '?' and the escape + # char '\' are valid characters for file and directory names. + # We have to escape and treat them specially. + $leave =~ s|([*?\\])|\\$1|g; + push(@matched, $leave); + next INNER; + } + } + push @retval, @matched if @matched; + } + return @retval; +} + +# +# _expand_volume() will only be used on Mac OS (Classic): +# Takes an array of original patterns as argument and returns an array of +# possibly modified patterns. Each original pattern is processed like +# that: +# + If there's a volume name in the pattern, we push a separate pattern +# for each mounted volume that matches (with '*', '?' and '\' escaped). +# + If there's no volume name in the original pattern, it is pushed +# unchanged. +# Note that the returned array of patterns may be empty. +# +sub _expand_volume { + + require MacPerl; # to be verbose + + my @pat = @_; + my @new_pat = (); + my @FSSpec_Vols = MacPerl::Volumes(); + my @mounted_volumes = (); + + foreach my $spec_vol (@FSSpec_Vols) { + # push all mounted volumes into array + push @mounted_volumes, MacPerl::MakePath($spec_vol); + } + #print "mounted volumes: |@mounted_volumes|\n"; + + while (@pat) { + my $pat = shift @pat; + if ($pat =~ /^([^:]+:)(.*)\z/) { # match a volume name? + my $vol_pat = $1; + my $tail = $2; + # + # escape regex metachars but not '\' and glob chars '*', '?' + $vol_pat =~ s:([].+^\-\${}[|]):\\$1:g; + # and convert DOS-style wildcards to regex, + # but only if they are not escaped + $vol_pat =~ s/(\\*)([*?])/$1 . ('.' x ((length($1) + 1) % 2)) . $2/eg; + #print "volume regex: '$vol_pat' \n"; + + foreach my $volume (@mounted_volumes) { + if ($volume =~ m|^$vol_pat\z|ios) { + # + # On Mac OS, the two glob metachars '*' and '?' and the + # escape char '\' are valid characters for volume names. + # We have to escape and treat them specially. + $volume =~ s|([*?\\])|\\$1|g; + push @new_pat, $volume . $tail; + } + } + } else { # no volume name in pattern, push original pattern + push @new_pat, $pat; + } + } + return @new_pat; +} + + +# +# _preprocess_pattern() will only be used on Mac OS (Classic): +# Resolves any updirs in the pattern. Removes a single trailing colon +# from the pattern, unless it's a volume name pattern like "*HD:" +# +sub _preprocess_pattern { + my @pat = @_; + + foreach my $p (@pat) { + my $proceed; + # resolve any updirs, e.g. "*HD:t?p::a*" -> "*HD:a*" + do { + $proceed = ($p =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + # remove a single trailing colon, e.g. ":*:" -> ":*" + $p =~ s/:([^:]+):\z/:$1/; + } + return @pat; +} + + +# +# _un_escape() will only be used on Mac OS (Classic): +# Unescapes a list of arguments which may contain escaped +# metachars '*', '?' and '\'. +# +sub _un_escape { + foreach (@_) { + s/\\([*?\\])/$1/g; + } + return @_; +} + # # this can be used to override CORE::glob in a specific # package by saying C in that @@ -172,8 +373,16 @@ sub glob { # if we're just beginning, do it all first if ($iter{$cxix} == 0) { - $entries{$cxix} = [doglob(1,@pat)]; + if ($^O eq 'MacOS') { + # first, take care of updirs and trailing colons + @pat = _preprocess_pattern(@pat); + # expand volume names + @pat = _expand_volume(@pat); + $entries{$cxix} = (@pat) ? [_un_escape( doglob_Mac(1,@pat) )] : [()]; + } else { + $entries{$cxix} = [doglob(1,@pat)]; } + } # chuck it all out, quick or slow if (wantarray) { @@ -253,6 +462,61 @@ of the quoting rules used. Extending it to csh patterns is left as an exercise to the reader. +=head1 NOTES + +=over 4 + +=item * + +Mac OS (Classic) users should note a few differences. The specification +of pathnames in glob patterns adheres to the usual Mac OS conventions: +The path separator is a colon ':', not a slash '/' or backslash '\'. A +full path always begins with a volume name. A relative pathname on Mac +OS must always begin with a ':', except when specifying a file or +directory name in the current working directory, where the leading colon +is optional. If specifying a volume name only, a trailing ':' is +required. Due to these rules, a glob like E*:E will find all +mounted volumes, while a glob like E*E or E:*E will find +all files and directories in the current directory. + +Note that updirs in the glob pattern are resolved before the matching begins, +i.e. a pattern like "*HD:t?p::a*" will be matched as "*HD:a*". Note also, +that a single trailing ':' in the pattern is ignored (unless it's a volume +name pattern like "*HD:"), i.e. a glob like <:*:> will find both directories +I files (and not, as one might expect, only directories). + +The metachars '*', '?' and the escape char '\' are valid characters in +volume, directory and file names on Mac OS. Hence, if you want to match +a '*', '?' or '\' literally, you have to escape these characters. Due to +perl's quoting rules, things may get a bit complicated, when you want to +match a string like '\*' literally, or when you want to match '\' literally, +but treat the immediately following character '*' as metachar. So, here's a +rule of thumb (applies to both single- and double-quoted strings): escape +each '*' or '?' or '\' with a backslash, if you want to treat them literally, +and then double each backslash and your are done. E.g. + +- Match '\*' literally + + escape both '\' and '*' : '\\\*' + double the backslashes : '\\\\\\*' + +(Internally, the glob routine sees a '\\\*', which means that both '\' and +'*' are escaped.) + + +- Match '\' literally, treat '*' as metachar + + escape '\' but not '*' : '\\*' + double the backslashes : '\\\\*' + +(Internally, the glob routine sees a '\\*', which means that '\' is escaped and +'*' is not.) + +Note that you also have to quote literal spaces in the glob pattern, as described +above. + +=back + =head1 EXPORTS (by request only) glob() diff --git a/lib/File/DosGlob.t b/lib/File/DosGlob.t index 31e36e2..d55c00e 100755 --- a/lib/File/DosGlob.t +++ b/lib/File/DosGlob.t @@ -15,23 +15,33 @@ print "1..10\n"; use File::DosGlob 'glob'; # test if $_ takes as the default +my $expected; +if ($^O eq 'MacOS') { + $expected = $_ = ":lib:a*.t"; +} else { + $expected = $_ = "lib/a*.t"; +} $_ = "op/a*.t"; my @r = glob; -print "not " if $_ ne 'op/a*.t'; +print "not " if $_ ne $expected; print "ok 1\n"; print "# |@r|\nnot " if @r < 9; print "ok 2\n"; # check if <*/*> works -@r = <*/a*.t>; +if ($^O eq 'MacOS') { + @r = <:*:a*.t>; +} else { + @r = <*/a*.t>; +} # atleast {argv,abbrev,anydbm,autoloader,append,arith,array,assignwarn,auto}.t -print "not " if @r < 9; +print "# |@r|\nnot " if @r < 9; print "ok 3\n"; my $r = scalar @r; # check if scalar context works @r = (); -while (defined($_ = <*/a*.t>)) { +while (defined($_ = ($^O eq 'MacOS') ? <:*:a*.t> : <*/a*.t>)) { print "# $_\n"; push @r, $_; } @@ -40,25 +50,40 @@ print "ok 4\n"; # check if list context works @r = (); -for (<*/a*.t>) { - print "# $_\n"; - push @r, $_; +if ($^O eq 'MacOS') { + for (<:*:a*.t>) { + print "# $_\n"; + push @r, $_; + } +} else { + for (<*/a*.t>) { + print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 5\n"; # test if implicit assign to $_ in while() works @r = (); -while (<*/a*.t>) { - print "# $_\n"; - push @r, $_; +if ($^O eq 'MacOS') { + while (<:*:a*.t>) { + print "# $_\n"; + push @r, $_; + } +} else { + while (<*/a*.t>) { + print "# $_\n"; + push @r, $_; + } } print "not " if @r != $r; print "ok 6\n"; # test if explicit glob() gets assign magic too my @s = (); -while (glob '*/a*.t') { +my $pat = ($^O eq 'MacOS') ? ':*:a*.t': '*/a*.t'; +while (glob ($pat)) { print "# $_\n"; push @s, $_; } diff --git a/lib/File/Spec.t b/lib/File/Spec.t index b6adc77..a7b0470 100755 --- a/lib/File/Spec.t +++ b/lib/File/Spec.t @@ -253,27 +253,152 @@ BEGIN { [ "OS2->catdir('A:/d1','B:/d2','d3','')", 'A:/d1/B:/d2/d3' ], [ "OS2->catfile('a','b','c')", 'a/b/c' ], -[ "Mac->splitpath('file')", ',,file' ], -[ "Mac->splitpath(':file')", ',:,file' ], -[ "Mac->splitpath(':d1',1)", ',:d1:,' ], -[ "Mac->splitpath('d1',1)", 'd1:,,' ], -[ "Mac->splitpath('d1:d2:d3:')", 'd1:,d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], -[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], -[ "Mac->splitpath('d1:d2:d3:file')", 'd1:,d2:d3:,file' ], -[ "Mac->splitpath('d1:d2:d3',1)", 'd1:,d2:d3:,' ], - -[ "Mac->catdir('')", ':' ], -[ "Mac->catdir('d1','d2','d3')", 'd1:d2:d3:' ], -[ "Mac->catdir('d1','d2/','d3')", 'd1:d2/:d3:' ], + +[ "Mac->catpath('','','')", '' ], +[ "Mac->catpath('',':','')", ':' ], +[ "Mac->catpath('','::','')", '::' ], + +[ "Mac->catpath('hd','','')", 'hd:' ], +[ "Mac->catpath('hd:','','')", 'hd:' ], +[ "Mac->catpath('hd:',':','')", 'hd:' ], +[ "Mac->catpath('hd:','::','')", 'hd::' ], + +[ "Mac->catpath('hd','','file')", 'hd:file' ], +[ "Mac->catpath('hd',':','file')", 'hd:file' ], +[ "Mac->catpath('hd','::','file')", 'hd::file' ], +[ "Mac->catpath('hd',':::','file')", 'hd:::file' ], + +[ "Mac->catpath('hd:','',':file')", 'hd:file' ], +[ "Mac->catpath('hd:',':',':file')", 'hd:file' ], +[ "Mac->catpath('hd:','::',':file')", 'hd::file' ], +[ "Mac->catpath('hd:',':::',':file')", 'hd:::file' ], + +[ "Mac->catpath('hd:','d1','file')", 'hd:d1:file' ], +[ "Mac->catpath('hd:',':d1:',':file')", 'hd:d1:file' ], + +[ "Mac->catpath('','d1','')", ':d1:' ], +[ "Mac->catpath('',':d1','')", ':d1:' ], +[ "Mac->catpath('',':d1:','')", ':d1:' ], + +[ "Mac->catpath('','d1','file')", ':d1:file' ], +[ "Mac->catpath('',':d1:',':file')", ':d1:file' ], + +[ "Mac->catpath('','','file')", 'file' ], +[ "Mac->catpath('','',':file')", 'file' ], # ! +[ "Mac->catpath('',':',':file')", ':file' ], # ! + + +[ "Mac->splitpath(':')", ',:,' ], +[ "Mac->splitpath('::')", ',::,' ], +[ "Mac->splitpath(':::')", ',:::,' ], + +[ "Mac->splitpath('file')", ',,file' ], +[ "Mac->splitpath(':file')", ',:,file' ], + +[ "Mac->splitpath('d1',1)", ',:d1:,' ], # dir, not volume +[ "Mac->splitpath(':d1',1)", ',:d1:,' ], +[ "Mac->splitpath(':d1:',1)", ',:d1:,' ], +[ "Mac->splitpath(':d1:')", ',:d1:,' ], +[ "Mac->splitpath(':d1:d2:d3:')", ',:d1:d2:d3:,' ], +[ "Mac->splitpath(':d1:d2:d3:',1)", ',:d1:d2:d3:,' ], +[ "Mac->splitpath(':d1:file')", ',:d1:,file' ], +[ "Mac->splitpath('::d1:file')", ',::d1:,file' ], + +[ "Mac->splitpath('hd:', 1)", 'hd:,,' ], +[ "Mac->splitpath('hd:')", 'hd:,,' ], +[ "Mac->splitpath('hd:d1:d2:')", 'hd:,:d1:d2:,' ], +[ "Mac->splitpath('hd:d1:d2',1)", 'hd:,:d1:d2:,' ], +[ "Mac->splitpath('hd:d1:d2:file')", 'hd:,:d1:d2:,file' ], +[ "Mac->splitpath('hd:d1:d2::file')", 'hd:,:d1:d2::,file' ], +[ "Mac->splitpath('hd::d1:d2:file')", 'hd:,::d1:d2:,file' ], # invalid path +[ "Mac->splitpath('hd:file')", 'hd:,,file' ], + +[ "Mac->splitdir('')", '' ], +[ "Mac->splitdir(':')", ':' ], +[ "Mac->splitdir('::')", '::' ], +[ "Mac->splitdir(':::')", ':::' ], +[ "Mac->splitdir(':::d1:d2')", ',,,d1,d2' ], + +[ "Mac->splitdir(':d1:d2:d3::')", ',d1,d2,d3,' ], +[ "Mac->splitdir(':d1:d2:d3:')", ',d1,d2,d3' ], +[ "Mac->splitdir(':d1:d2:d3')", ',d1,d2,d3' ], + +[ "Mac->splitdir('hd:d1:d2:::')", 'hd,d1,d2,,' ], +[ "Mac->splitdir('hd:d1:d2::')", 'hd,d1,d2,' ], +[ "Mac->splitdir('hd:d1:d2:')", 'hd,d1,d2' ], +[ "Mac->splitdir('hd:d1:d2')", 'hd,d1,d2' ], +[ "Mac->splitdir('hd:d1::d2::')", 'hd,d1,,d2,' ], + +[ "Mac->catdir()", '' ], +[ "Mac->catdir('')", ':' ], +[ "Mac->catdir(':')", ':' ], + +[ "Mac->catdir('', '')", '::' ], # Hmm... ":" ? +[ "Mac->catdir('', ':')", '::' ], # Hmm... ":" ? +[ "Mac->catdir(':', ':')", '::' ], # Hmm... ":" ? +[ "Mac->catdir(':', '')", '::' ], # Hmm... ":" ? + +[ "Mac->catdir('', '::')", '::' ], +[ "Mac->catdir(':', '::')", '::' ], # but catdir('::', ':') is ':::' + +[ "Mac->catdir('::', '')", ':::' ], # Hmm... "::" ? +[ "Mac->catdir('::', ':')", ':::' ], # Hmm... "::" ? + +[ "Mac->catdir('::', '::')", ':::' ], # ok + +# +# Unix counterparts: +# + +# Unix catdir('.') = "." + +# Unix catdir('','') = "/" +# Unix catdir('','.') = "/" +# Unix catdir('.','.') = "." +# Unix catdir('.','') = "." + +# Unix catdir('','..') = "/" +# Unix catdir('.','..') = ".." + +# Unix catdir('..','') = ".." +# Unix catdir('..','.') = ".." +# Unix catdir('..','..') = "../.." + +[ "Mac->catdir(':d1','d2')", ':d1:d2:' ], [ "Mac->catdir('','d1','d2','d3')", ':d1:d2:d3:' ], [ "Mac->catdir('','','d2','d3')", '::d2:d3:' ], [ "Mac->catdir('','','','d3')", ':::d3:' ], -[ "Mac->catdir(':name')", ':name:' ], -[ "Mac->catdir(':name',':name')", ':name:name:' ], +[ "Mac->catdir(':d1')", ':d1:' ], +[ "Mac->catdir(':d1',':d2')", ':d1:d2:' ], +[ "Mac->catdir('', ':d1',':d2')", ':d1:d2:' ], +[ "Mac->catdir('','',':d1',':d2')", '::d1:d2:' ], + +[ "Mac->catdir('hd')", 'hd:' ], +[ "Mac->catdir('hd','d1','d2')", 'hd:d1:d2:' ], +[ "Mac->catdir('hd','d1/','d2')", 'hd:d1/:d2:' ], +[ "Mac->catdir('hd','',':d1')", 'hd::d1:' ], +[ "Mac->catdir('hd','d1')", 'hd:d1:' ], +[ "Mac->catdir('hd','d1', '')", 'hd:d1::' ], +[ "Mac->catdir('hd','d1','','')", 'hd:d1:::' ], +[ "Mac->catdir('hd:',':d1')", 'hd:d1:' ], +[ "Mac->catdir('hd:d1:',':d2')", 'hd:d1:d2:' ], +[ "Mac->catdir('hd:','d1')", 'hd:d1:' ], +[ "Mac->catdir('hd',':d1')", 'hd:d1:' ], +[ "Mac->catdir('hd:d1:',':d2')", 'hd:d1:d2:' ], +[ "Mac->catdir('hd:d1:',':d2:')", 'hd:d1:d2:' ], + + +[ "Mac->catfile()", '' ], +[ "Mac->catfile('')", '' ], +[ "Mac->catfile(':')", ':' ], +[ "Mac->catfile(':', '')", ':' ], + +[ "Mac->catfile('hd','d1','file')", 'hd:d1:file' ], +[ "Mac->catfile('hd','d1',':file')", 'hd:d1:file' ], +[ "Mac->catfile('file')", 'file' ], +[ "Mac->catfile(':', 'file')", ':file' ], +[ "Mac->catfile('', 'file')", ':file' ], -[ "Mac->catfile('a','b','c')", 'a:b:c' ], [ "Mac->canonpath('')", '' ], [ "Mac->canonpath(':')", ':' ], @@ -281,20 +406,33 @@ BEGIN { [ "Mac->canonpath('a::')", 'a::' ], [ "Mac->canonpath(':a::')", ':a::' ], -[ "Mac->abs2rel('t1:t2:t3','t1:t2:t3')", ':' ], -[ "Mac->abs2rel('t1:t2','t1:t2:t3')", '::' ], -[ "Mac->abs2rel('t1:t4','t1:t2:t3')", ':::t4' ], -[ "Mac->abs2rel('t1:t2:t4','t1:t2:t3')", '::t4' ], -[ "Mac->abs2rel('t1:t2:t3:t4','t1:t2:t3')", ':t4' ], -[ "Mac->abs2rel('t4:t5:t6','t1:t2:t3')", '::::t4:t5:t6' ], -[ "Mac->abs2rel('t1','t1:t2:t3')", ':::' ], - -[ "Mac->rel2abs(':t4','t1:t2:t3')", 't1:t2:t3:t4' ], -[ "Mac->rel2abs(':t4:t5','t1:t2:t3')", 't1:t2:t3:t4:t5' ], -[ "Mac->rel2abs('','t1:t2:t3')", '' ], -[ "Mac->rel2abs('::','t1:t2:t3')", 't1:t2:t3::' ], -[ "Mac->rel2abs('::t4','t1:t2:t3')", 't1:t2:t3::t4' ], -[ "Mac->rel2abs('t1','t1:t2:t3')", 't1' ], +[ "Mac->abs2rel('hd:d1:d2:','hd:d1:d2:')", ':' ], +[ "Mac->abs2rel('hd:d1:d2:','hd:d1:d2:file')", ':' ], # ignore base's file portion +[ "Mac->abs2rel('hd:d1:d2:file','hd:d1:d2:')", ':file' ], +[ "Mac->abs2rel('hd:d1:','hd:d1:d2:')", '::' ], +[ "Mac->abs2rel('hd:d3:','hd:d1:d2:')", ':::d3:' ], +[ "Mac->abs2rel('hd:d3:','hd:d1:d2::')", '::d3:' ], +[ "Mac->abs2rel('hd:d1:d4:d5:','hd:d1::d2:d3::')", '::d1:d4:d5:' ], +[ "Mac->abs2rel('hd:d1:d4:d5:','hd:d1::d2:d3:')", ':::d1:d4:d5:' ], # first, resolve updirs in base +[ "Mac->abs2rel('hd:d1:d3:','hd:d1:d2:')", '::d3:' ], +[ "Mac->abs2rel('hd:d1::d3:','hd:d1:d2:')", ':::d3:' ], +[ "Mac->abs2rel('hd:d3:','hd:d1:d2:')", ':::d3:' ], # same as above +[ "Mac->abs2rel('hd:d1:d2:d3:','hd:d1:d2:')", ':d3:' ], +[ "Mac->abs2rel('hd:d1:d2:d3::','hd:d1:d2:')", ':d3::' ], +[ "Mac->abs2rel('v1:d3:d4:d5:','v2:d1:d2:')", ':::d3:d4:d5:' ], # ignore base's volume +[ "Mac->abs2rel('hd:','hd:d1:d2:')", ':::' ], + +[ "Mac->rel2abs(':d3:','hd:d1:d2:')", 'hd:d1:d2:d3:' ], +[ "Mac->rel2abs(':d3:d4:','hd:d1:d2:')", 'hd:d1:d2:d3:d4:' ], +[ "Mac->rel2abs('','hd:d1:d2:')", '' ], +[ "Mac->rel2abs('::','hd:d1:d2:')", 'hd:d1:d2::' ], +[ "Mac->rel2abs('::','hd:d1:d2:file')", 'hd:d1:d2::' ],# ignore base's file portion +[ "Mac->rel2abs(':file','hd:d1:d2:')", 'hd:d1:d2:file' ], +[ "Mac->rel2abs('::file','hd:d1:d2:')", 'hd:d1:d2::file' ], +[ "Mac->rel2abs('::d3:','hd:d1:d2:')", 'hd:d1:d2::d3:' ], +[ "Mac->rel2abs('hd:','hd:d1:d2:')", 'hd:' ], # path already absolute +[ "Mac->rel2abs('hd:d3:file','hd:d1:d2:')", 'hd:d3:file' ], +[ "Mac->rel2abs('hd:d3:','hd:d1:file')", 'hd:d3:' ], ) ; # Grab all of the plain routines from File::Spec diff --git a/lib/File/Spec/Mac.pm b/lib/File/Spec/Mac.pm index 9ef55ec..6b62747 100644 --- a/lib/File/Spec/Mac.pm +++ b/lib/File/Spec/Mac.pm @@ -8,6 +8,8 @@ $VERSION = '1.2'; @ISA = qw(File::Spec::Unix); +use Cwd; + =head1 NAME File::Spec::Mac - File::Spec for MacOS @@ -37,51 +39,87 @@ sub canonpath { =item catdir -Concatenate two or more directory names to form a complete path ending with -a directory. Put a trailing : on the end of the complete path if there -isn't one, because that's what's done in MacPerl's environment. +Concatenate two or more directory names to form a path separated by colons +(":") ending with a directory. Automatically puts a trailing ":" on the +end of the complete path, because that's what's done in MacPerl's +environment and helps to distinguish a file path from a directory path. + +The intended purpose of this routine is to concatenate I. +But because of the nature of Macintosh paths, some additional possibilities +are allowed to make using this routine give reasonable results for some +common situations. In other words, you are also allowed to concatenate +I instead of directory names (strictly speaking, a string like ":a" +is a path, but not a name, since it contains a punctuation character ":"). + +Here are the rules that are used: Each argument has its trailing ":" removed. +Each argument, except the first, has its leading ":" removed. They are then +joined together by a ":" and a trailing ":" is added to the path. + +So, beside calls like + + File::Spec->catdir("a") = "a:" + File::Spec->catdir("a","b") = "a:b:" + File::Spec->catdir("","a","b") = ":a:b:" + File::Spec->catdir("a","","b") = "a::b:" + File::Spec->catdir("") = ":" + File::Spec->catdir("a","b","") = "a:b::" (!) + File::Spec->catdir() = "" (special case) + +calls like the following -The fundamental requirement of this routine is that + File::Spec->catdir("a:",":b") = "a:b:" + File::Spec->catdir("a:b:",":c") = "a:b:c:" + File::Spec->catdir("a:","b") = "a:b:" + File::Spec->catdir("a",":b") = "a:b:" + File::Spec->catdir(":a","b") = ":a:b:" + File::Spec->catdir("","",":a",":b") = "::a:b:" + File::Spec->catdir("",":a",":b") = ":a:b:" (!) + File::Spec->catdir(":") = ":" - File::Spec->catdir(split(":",$path)) eq $path +are allowed. -But because of the nature of Macintosh paths, some additional -possibilities are allowed to make using this routine give reasonable results -for some common situations. Here are the rules that are used. Each -argument has its trailing ":" removed. Each argument, except the first, -has its leading ":" removed. They are then joined together by a ":". +To get a path beginning with a ":" (a relative path), put a "" as the first +argument. Beginning the first argument with a ":" (e.g. ":a") will also work +(see the examples). -So +Since Mac OS (Classic) uses the concept of volumes, there is an ambiguity: +Does the first argument in - File::Spec->catdir("a","b") = "a:b:" - File::Spec->catdir("a:",":b") = "a:b:" - File::Spec->catdir("a:","b") = "a:b:" - File::Spec->catdir("a",":b") = "a:b" - File::Spec->catdir("a","","b") = "a::b" + File::Spec->catdir("LWP","Protocol"); -etc. +denote a volume or a directory, i.e. should the path be relative or absolute? +There is no way of telling except by checking for the existence of "LWP:" (a +volume) or ":LWP" (a directory), but those checks aren't made here. Thus, according +to the above rules, the path "LWP:Protocol:" will be returned, which, considered +alone, is an absolute path, although the volume "LWP:" may not exist. Hence, don't +forget to put a ":" in the appropriate place in the path if you want to +distinguish unambiguously. (Remember that a valid relative path should always begin +with a ":", unless you are specifying a file or a directory that resides in the +I directory. In that case, the leading ":" is not mandatory.) -To get a relative path (one beginning with :), begin the first argument with : -or put a "" as the first argument. +With version 1.2 of File::Spec, there's a new method called C, that +takes volume, directory and file portions and returns an entire path (see below). +While C is still suitable for the concatenation of I, +you should consider using C to concatenate I and +I, because it avoids any ambiguities. E.g. -If you don't want to worry about these rules, never allow a ":" on the ends -of any of the arguments except at the beginning of the first. + $dir = File::Spec->catdir("LWP","Protocol"); + $abs_path = File::Spec->catpath("MacintoshHD:", $dir, ""); -Under MacPerl, there is an additional ambiguity. Does the user intend that +yields - File::Spec->catfile("LWP","Protocol","http.pm") + "MacintoshHD:LWP:Protocol:" . -be relative or absolute? There's no way of telling except by checking for the -existence of LWP: or :LWP, and even there he may mean a dismounted volume or -a relative path in a different directory (like in @INC). So those checks -aren't done here. This routine will treat this as absolute. =cut sub catdir { - shift; + my $self = shift; + return '' unless @_; my @args = @_; my $result = shift @args; + # To match the actual end of the string, + # not ignoring newline, you can use \Z(?!\n). $result =~ s/:\Z(?!\n)//; foreach (@args) { s/:\Z(?!\n)//; @@ -95,21 +133,24 @@ sub catdir { Concatenate one or more directory names and a filename to form a complete path ending with a filename. Since this uses catdir, the -same caveats apply. Note that the leading : is removed from the filename, -so that +same caveats apply. Note that the leading ":" is removed from the +filename, so that - File::Spec->catfile($ENV{HOME},"file"); + File::Spec->catfile("a", "b", "file"); # = "a:b:file" and - File::Spec->catfile($ENV{HOME},":file"); + File::Spec->catfile("a", "b", ":file"); # = "a:b:file" -give the same answer, as one might expect. +give the same answer, as one might expect. To concatenate I, +I and I, you should consider using C +(see below). =cut sub catfile { my $self = shift; + return '' unless @_; my $file = pop @_; return $file unless @_; my $dir = $self->catdir(@_); @@ -119,7 +160,7 @@ sub catfile { =item curdir -Returns a string representing the current directory. +Returns a string representing the current directory. On Mac OS, this is ":". =cut @@ -129,7 +170,7 @@ sub curdir { =item devnull -Returns a string representing the null device. +Returns a string representing the null device. On Mac OS, this is "Dev:Null". =cut @@ -141,7 +182,9 @@ sub devnull { Returns a string representing the root directory. Under MacPerl, returns the name of the startup volume, since that's the closest in -concept, although other volumes aren't rooted there. +concept, although other volumes aren't rooted there. The name has a +trailing ":", because that's the correct specification for a volume +name on Mac OS. =cut @@ -159,10 +202,9 @@ sub rootdir { =item tmpdir -Returns a string representation of the first existing directory -from the following list or '' if none exist: - - $ENV{TMPDIR} +Returns the contents of $ENV{TMPDIR}, if that directory exits or the current working +directory otherwise. Under MacPerl, $ENV{TMPDIR} will contain a path like +"MacintoshHD:Temporary Items:", which is a hidden directory on your startup volume. =cut @@ -170,13 +212,15 @@ my $tmpdir; sub tmpdir { return $tmpdir if defined $tmpdir; $tmpdir = $ENV{TMPDIR} if -d $ENV{TMPDIR}; - $tmpdir = '' unless defined $tmpdir; + unless (defined($tmpdir)) { + $tmpdir = cwd(); + } return $tmpdir; } =item updir -Returns a string representing the parent directory. +Returns a string representing the parent directory. On Mac OS, this is "::". =cut @@ -186,32 +230,41 @@ sub updir { =item file_name_is_absolute -Takes as argument a path and returns true, if it is an absolute path. In -the case where a name can be either relative or absolute (for example, a -folder named "HD" in the current working directory on a drive named "HD"), -relative wins. Use ":" in the appropriate place in the path if you want to -distinguish unambiguously. +Takes as argument a path and returns true, if it is an absolute path. +This does not consult the local filesystem. If +the path has a leading ":", it's a relative path. Otherwise, it's an +absolute path, unless the path doesn't contain any colons, i.e. it's a name +like "a". In this particular case, the path is considered to be relative +(i.e. it is considered to be a filename). Use ":" in the appropriate place +in the path if you want to distinguish unambiguously. As a special case, +the filename '' is always considered to be absolute. + +E.g. + + File::Spec->file_name_is_absolute("a"); # false (relative) + File::Spec->file_name_is_absolute(":a:b:"); # false (relative) + File::Spec->file_name_is_absolute("MacintoshHD:"); # true (absolute) + File::Spec->file_name_is_absolute(""); # true (absolute) -As a special case, the file name '' is always considered to be absolute. =cut sub file_name_is_absolute { my ($self,$file) = @_; if ($file =~ /:/) { - return ($file !~ m/^:/s); + return (! ($file =~ m/^:/s) ); } elsif ( $file eq '' ) { return 1 ; } else { - return (! -e ":$file"); + return 0; # i.e. a file like "a" } } =item path -Returns the null list for the MacPerl application, since the concept is -usually meaningless under MacOS. But if you're using the MacPerl tool under -MPW, it gives back $ENV{Commands} suitably split, as is done in +Returns the null list for the MacPerl application, since the concept is +usually meaningless under MacOS. But if you're using the MacPerl tool under +MPW, it gives back $ENV{Commands} suitably split, as is done in :lib:ExtUtils:MM_Mac.pm. =cut @@ -227,40 +280,107 @@ sub path { =item splitpath + ($volume,$directories,$file) = File::Spec->splitpath( $path ); + ($volume,$directories,$file) = File::Spec->splitpath( $path, $no_file ); + +Splits a path in to volume, directory, and filename portions. + +On Mac OS, assumes that the last part of the path is a filename unless +$no_file is true or a trailing separator ":" is present. + +The volume portion is always returned with a trailing ":". The directory portion +is always returned with a leading (to denote a relative path) and a trailing ":" +(to denote a directory). The file portion is always returned I a leading ":". +Empty portions are returned as "". + +The results can be passed to L to get back a path equivalent to +(usually identical to) the original path. + + =cut sub splitpath { my ($self,$path, $nofile) = @_; - - my ($volume,$directory,$file) = ('','',''); + my ($volume,$directory,$file); if ( $nofile ) { - ( $volume, $directory ) = $path =~ m@((?:[^:]+(?::|\Z(?!\n)))?)(.*)@s; + ( $volume, $directory ) = $path =~ m|^((?:[^:]+:)?)(.*)|s; } else { - $path =~ - m@^( (?: [^:]+: )? ) - ( (?: .*: )? ) - ( .* ) - @xs; + $path =~ + m|^( (?: [^:]+: )? ) + ( (?: .*: )? ) + ( .* ) + |xs; $volume = $1; $directory = $2; $file = $3; } - # Make sure non-empty volumes and directories end in ':' - $volume .= ':' if $volume =~ m@[^:]\Z(?!\n)@ ; - $directory .= ':' if $directory =~ m@[^:]\Z(?!\n)@ ; + $volume = '' unless defined($volume); + $directory = ":$directory" if ( $volume && $directory ); # take care of "HD::dir" + if ($directory) { + # Make sure non-empty directories begin and end in ':' + $directory .= ':' unless (substr($directory,-1) eq ':'); + $directory = ":$directory" unless (substr($directory,0,1) eq ':'); + } else { + $directory = ''; + } + $file = '' unless defined($file); + return ($volume,$directory,$file); } =item splitdir +The opposite of L. + + @dirs = File::Spec->splitdir( $directories ); + +$directories must be only the directory portion of the path on systems +that have the concept of a volume or that have path syntax that differentiates +files from directories. + +Unlike just splitting the directories on the separator, empty directory names +(C<"">) can be returned. Since C on Mac OS always appends a trailing +colon to distinguish a directory path from a file path, a single trailing colon +will be ignored, i.e. there's no empty directory name after it. + +Hence, on Mac OS, both + + File::Spec->splitdir( ":a:b::c:" ); and + File::Spec->splitdir( ":a:b::c" ); + +yield: + + ( "", "a", "b", "", "c") + +while + + File::Spec->splitdir( ":a:b::c::" ); + +yields: + + ( "", "a", "b", "", "c", "") + + =cut sub splitdir { my ($self,$directories) = @_ ; + + if ($directories =~ /^:*\Z(?!\n)/) { + # dir is an empty string or a colon path like ':', i.e. the + # current dir, or '::', the parent dir, etc. We return that + # dir (as is done on Unix). + return $directories; + } + + # remove a trailing colon, if any (this way, splitdir is the + # opposite of catdir, which automatically appends a ':') + $directories =~ s/:\Z(?!\n)//; + # # split() likes to forget about trailing null fields, so here we # check to be sure that there will not be any before handling the @@ -271,7 +391,7 @@ sub splitdir { } else { # - # since there was a trailing separator, add a file name to the end, + # since there was a trailing separator, add a file name to the end, # then do the split, then replace it with ''. # my( @directories )= split( m@:@, "${directories}dummy" ) ; @@ -283,42 +403,88 @@ sub splitdir { =item catpath + $path = File::Spec->catpath($volume,$directory,$file); + +Takes volume, directory and file portions and returns an entire path. On Mac OS, +$volume, $directory and $file are concatenated. A ':' is inserted if need be. You +may pass an empty string for each portion. If all portions are empty, the empty +string is returned. If $volume is empty, the result will be a relative path, +beginning with a ':'. If $volume and $directory are empty, a leading ":" (if any) +is removed form $file and the remainder is returned. If $file is empty, the +resulting path will have a trailing ':'. + + =cut sub catpath { - my $self = shift ; + my ($self,$volume,$directory,$file) = @_; - my $result = shift ; - $result =~ s@^([^/])@/$1@s ; + if ( (! $volume) && (! $directory) ) { + $file =~ s/^:// if $file; + return $file ; + } - my $segment ; - for $segment ( @_ ) { - if ( $result =~ m@[^/]\Z(?!\n)@ && $segment =~ m@^[^/]@s ) { - $result .= "/$segment" ; - } - elsif ( $result =~ m@/\Z(?!\n)@ && $segment =~ m@^/@s ) { - $result =~ s@/+\Z(?!\n)@/@; - $segment =~ s@^/+@@s; - $result .= "$segment" ; - } - else { - $result .= $segment ; - } + my $path = $volume; # may be '' + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' + + if ($directory) { + $directory =~ s/^://; # remove leading ':' if any + $path .= $directory; + $path .= ':' unless (substr($path, -1) eq ':'); # ensure trailing ':' } - return $result ; + if ($file) { + $file =~ s/^://; # remove leading ':' if any + $path .= $file; + } + + return $path; } =item abs2rel -See L for general documentation. +Takes a destination path and an optional base path and returns a relative path +from the base path to the destination path: + + $rel_path = File::Spec->abs2rel( $path ) ; + $rel_path = File::Spec->abs2rel( $path, $base ) ; + +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then the current working directory is used. +If $base is relative, then it is converted to absolute form using C. +This means that it is taken to be relative to the current working directory. + +Since Mac OS has the concept of volumes, this assumes that both paths +are on the $destination volume, and ignores the $base volume (!). + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored (!). Otherwise all path +components are assumed to be directories. + +If $path is relative, it is converted to absolute form using C. +This means that it is taken to be relative to the current working directory. + +Based on code written by Shigio Yamaguchi. -Unlike Cabs2rel()>, this function will make -checks against the local filesystem if necessary. See -L for details. =cut +# maybe this should be done in canonpath() ? +sub _resolve_updirs { + my $path = shift @_; + my $proceed; + + # resolve any updirs, e.g. "HD:tmp::file" -> "HD:file" + do { + $proceed = ($path =~ s/^(.*):[^:]+::(.*?)\z/$1:$2/); + } while ($proceed); + + return $path; +} + + sub abs2rel { my($self,$path,$base) = @_; @@ -329,62 +495,106 @@ sub abs2rel { # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = cwd() ; + $base = cwd(); } elsif ( ! $self->file_name_is_absolute( $base ) ) { $base = $self->rel2abs( $base ) ; + $base = _resolve_updirs( $base ); # resolve updirs in $base } + else { + $base = _resolve_updirs( $base ); + } + + # Split up paths + my ( $path_dirs, $path_file ) = ($self->splitpath( $path ))[1,2] ; + + # ignore $base's volume and file + my $base_dirs = ($self->splitpath( $base ))[1] ; # Now, remove all leading components that are the same - my @pathchunks = $self->splitdir( $path ); - my @basechunks = $self->splitdir( $base ); + my @pathchunks = $self->splitdir( $path_dirs ); + my @basechunks = $self->splitdir( $base_dirs ); - while (@pathchunks && @basechunks && $pathchunks[0] eq $basechunks[0]) { + while ( @pathchunks && + @basechunks && + lc( $pathchunks[0] ) eq lc( $basechunks[0] ) ) { shift @pathchunks ; shift @basechunks ; } - $path = join( ':', @pathchunks ); + # @pathchunks now has the directories to descend in to. + $path_dirs = $self->catdir( @pathchunks ); # @basechunks now contains the number of directories to climb out of. - $base = ':' x @basechunks ; + $base_dirs = (':' x @basechunks) . ':' ; - return "$base:$path" ; + return $self->catpath( '', $base_dirs . $path_dirs, $path_file ) ; } =item rel2abs -See L for general documentation. +Converts a relative path to an absolute path: + + $abs_path = File::Spec->rel2abs( $path ) ; + $abs_path = File::Spec->rel2abs( $path, $base ) ; -Unlike Crel2abs()>, this function will make -checks against the local filesystem if necessary. See -L for details. +Note that both paths are assumed to have a notation that distinguishes a +directory path (with trailing ':') from a file path (without trailing ':'). + +If $base is not present or '', then $base is set to the current working +directory. If $base is relative, then it is converted to absolute form +using C. This means that it is taken to be relative to the +current working directory. + +If $base doesn't have a trailing colon, the last element of $base is +assumed to be a filename. This filename is ignored (!). Otherwise all path +components are assumed to be directories. + +If $path is already absolute, it is returned and $base is ignored. + +Based on code written by Shigio Yamaguchi. =cut sub rel2abs { - my ($self,$path,$base ) = @_; + my ($self,$path,$base) = @_; - if ( ! $self->file_name_is_absolute( $path ) ) { + if ( ! $self->file_name_is_absolute($path) ) { + # Figure out the effective $base and clean it up. if ( !defined( $base ) || $base eq '' ) { - $base = cwd() ; + $base = cwd(); } - elsif ( ! $self->file_name_is_absolute( $base ) ) { - $base = $self->rel2abs( $base ) ; - } - else { - $base = $self->canonpath( $base ) ; + elsif ( ! $self->file_name_is_absolute($base) ) { + $base = $self->rel2abs($base) ; } - $path = $self->canonpath("$base$path") ; - } + # Split up paths + + # igonore $path's volume + my ( $path_dirs, $path_file ) = ($self->splitpath($path))[1,2] ; + + # ignore $base's file part + my ( $base_vol, $base_dirs, undef ) = $self->splitpath($base) ; + + # Glom them together + $path_dirs = ':' if ($path_dirs eq ''); + $base_dirs =~ s/:$//; # remove trailing ':', if any + $base_dirs = $base_dirs . $path_dirs; - return $path ; + $path = $self->catpath( $base_vol, $base_dirs, $path_file ); + } + return $path; } =back +=head1 AUTHORS + +See the authors list in L. Mac OS support by Paul Schinder + and Thomas Wegner . + + =head1 SEE ALSO L diff --git a/lib/File/Temp.pm b/lib/File/Temp.pm index b686682..3248a96 100644 --- a/lib/File/Temp.pm +++ b/lib/File/Temp.pm @@ -9,7 +9,8 @@ File::Temp - return name and handle of a temporary file safely =head1 PORTABILITY This module is designed to be portable across operating systems -and it currently supports Unix, VMS, DOS, OS/2 and Windows. When +and it currently supports Unix, VMS, DOS, OS/2, Windows and +Mac OS (Classic). When porting to a new OS there are generally three main issues that have to be solved: @@ -40,7 +41,7 @@ The C<_can_do_level> method should be modified accordingly. =head1 SYNOPSIS - use File::Temp qw/ tempfile tempdir /; + use File::Temp qw/ tempfile tempdir /; $dir = tempdir( CLEANUP => 1 ); ($fh, $filename) = tempfile( DIR => $dir ); @@ -91,7 +92,7 @@ Objects (NOT YET IMPLEMENTED): C can be used to create and open temporary files in a safe way. The tempfile() function can be used to return the name and the open -filehandle of a temporary file. The tempdir() function can +filehandle of a temporary file. The tempdir() function can be used to create a temporary directory. The security aspect of temporary file creation is emphasized such that @@ -164,9 +165,9 @@ use base qw/Exporter/; # add contents of these tags to @EXPORT Exporter::export_tags('POSIX','mktemp'); -# Version number +# Version number -$VERSION = '0.12'; +$VERSION = '0.13'; # This is a list of characters that can be used in random filenames @@ -197,17 +198,19 @@ use constant HIGH => 2; my $OPENFLAGS = O_CREAT | O_EXCL | O_RDWR; -for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { - my ($bit, $func) = (0, "Fcntl::O_" . $oflag); - no strict 'refs'; - $OPENFLAGS |= $bit if eval { - # Make sure that redefined die handlers do not cause problems - # eg CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; +unless ($^O eq 'MacOS') { + for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } } # On some systems the O_TEMPORARY flag can be used to tell the OS @@ -218,17 +221,19 @@ for my $oflag (qw/ FOLLOW BINARY LARGEFILE EXLOCK NOINHERIT /) { # this by using a second open flags variable my $OPENTEMPFLAGS = $OPENFLAGS; -for my $oflag (qw/ TEMPORARY /) { - my ($bit, $func) = (0, "Fcntl::O_" . $oflag); - no strict 'refs'; - $OPENTEMPFLAGS |= $bit if eval { - # Make sure that redefined die handlers do not cause problems - # eg CGI::Carp - local $SIG{__DIE__} = sub {}; - local $SIG{__WARN__} = sub {}; - $bit = &$func(); - 1; - }; +unless ($^O eq 'MacOS') { + for my $oflag (qw/ TEMPORARY /) { + my ($bit, $func) = (0, "Fcntl::O_" . $oflag); + no strict 'refs'; + $OPENTEMPFLAGS |= $bit if eval { + # Make sure that redefined die handlers do not cause problems + # eg CGI::Carp + local $SIG{__DIE__} = sub {}; + local $SIG{__WARN__} = sub {}; + $bit = &$func(); + 1; + }; + } } # INTERNAL ROUTINES - not to be used outside of package @@ -253,7 +258,7 @@ for my $oflag (qw/ TEMPORARY /) { # default is 0. # "unlink_on_close" => indicates that, if possible, the OS should remove # the file as soon as it is closed. Usually indicates -# use of the O_TEMPORARY flag to sysopen. +# use of the O_TEMPORARY flag to sysopen. # Usually irrelevant on unix # Optionally a reference to a scalar can be passed into the function @@ -361,8 +366,8 @@ sub _gettemp { # Split the directory and put it back together again my @dirs = File::Spec->splitdir($directories); - # If @dirs only has one entry that means we are in the current - # directory + # If @dirs only has one entry (i.e. the directory template) that means + # we are in the current directory if ($#dirs == 0) { $parent = File::Spec->curdir; } else { @@ -395,7 +400,7 @@ sub _gettemp { } - # Check that the parent directories exist + # Check that the parent directories exist # Do this even for the case where we are simply returning a name # not a file -- no point returning a name that includes a directory # that does not exist or is not writable @@ -447,10 +452,10 @@ sub _gettemp { local $^F = 2; # Store callers umask - my $umask = umask(); + my $umask = umask() unless ($^O eq 'MacOS'); # Set a known umask - umask(066); + umask(066) unless ($^O eq 'MacOS'); # Attempt to open the file my $open_success = undef; @@ -467,14 +472,14 @@ sub _gettemp { if ( $open_success ) { # Reset umask - umask($umask); - + umask($umask) unless ($^O eq 'MacOS'); + # Opened successfully - return file handle and name return ($fh, $path); } else { # Reset umask - umask($umask); + umask($umask) unless ($^O eq 'MacOS'); # Error opening file - abort with error # if the reason was anything but EEXIST @@ -484,27 +489,27 @@ sub _gettemp { } # Loop round for another try - + } } elsif ($options{"mkdir"}) { # Store callers umask - my $umask = umask(); + my $umask = umask() unless ($^O eq 'MacOS'); # Set a known umask - umask(066); + umask(066) unless ($^O eq 'MacOS'); # Open the temp directory if (mkdir( $path, 0700)) { # created okay # Reset umask - umask($umask); + umask($umask) unless ($^O eq 'MacOS'); return undef, $path; } else { # Reset umask - umask($umask); + umask($umask) unless ($^O eq 'MacOS'); # Abort with error if the reason for failure was anything # except EEXIST @@ -585,10 +590,10 @@ sub _randchar { } # Internal routine to replace the XXXX... with random characters -# This has to be done by _gettemp() every time it fails to +# This has to be done by _gettemp() every time it fails to # open a temp file/dir -# Arguments: $template (the template with XXX), +# Arguments: $template (the template with XXX), # $ignore (number of characters at end to ignore) # Returns: modified template @@ -684,7 +689,7 @@ sub _is_safe { } # Internal routine to check whether a directory is safe -# for temp files. Safer than _is_safe since it checks for +# for temp files. Safer than _is_safe since it checks for # the possibility of chown giveaway and if that is a possibility # checks each directory in the path to see if it is safe (with _is_safe) @@ -769,7 +774,7 @@ sub _is_verysafe { sub _can_unlink_opened_file { - if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos') { + if ($^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'VMS' || $^O eq 'dos' || $^O eq 'MacOS') { return 0; } else { return 1; @@ -793,7 +798,7 @@ sub _can_do_level { return 1 if $level == STANDARD; # Currently, the systems that can do HIGH or MEDIUM are identical - if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos') { + if ( $^O eq 'MSWin32' || $^O eq 'os2' || $^O eq 'cygwin' || $^O eq 'dos' || $^O eq 'MacOS') { return 0; } else { return 1; @@ -936,20 +941,20 @@ is specified. Return the filename and filehandle as before except that the file is automatically removed when the program exits. Default is for the file to be removed if a file handle is requested and to be kept if the -filename is requested. In a scalar context (where no filename is +filename is requested. In a scalar context (where no filename is returned) the file is always deleted either on exit or when it is closed. If the template is not specified, a template is always automatically generated. This temporary file is placed in tmpdir() -(L) unless a directory is specified explicitly with the +(L) unless a directory is specified explicitly with the DIR option. $fh = tempfile( $template, DIR => $dir ); If called in scalar context, only the filehandle is returned -and the file will automatically be deleted when closed (see +and the file will automatically be deleted when closed (see the description of tmpfile() elsewhere in this document). -This is the preferred mode of operation, as if you only +This is the preferred mode of operation, as if you only have a filehandle, you can never create a race condition by fumbling with the filename. On systems that can not unlink an open file or can not mark a file as temporary when it is opened @@ -961,7 +966,7 @@ to setting UNLINK to 1). The C flag is ignored if present. This will return the filename based on the template but will not open this file. Cannot be used in conjunction with -UNLINK set to true. Default is to always open the file +UNLINK set to true. Default is to always open the file to protect from possible race conditions. A warning is issued if warnings are turned on. Consider using the tmpnam() and mktemp() functions described elsewhere in this document @@ -1040,7 +1045,7 @@ sub tempfile { # On unix this is irrelevant and can be worked out after the file is # opened (simply by unlinking the open filehandle). On Windows or VMS # we have to indicate temporary-ness when we open the file. In general - # we only want a true temporary file if we are returning just the + # we only want a true temporary file if we are returning just the # filehandle - if the user wants the filename they probably do not # want the file to disappear as soon as they close it. # For this reason, tie unlink_on_close to the return context regardless @@ -1118,7 +1123,7 @@ prepending the supplied directory. $tempdir = tempdir ( $template, TMPDIR => 1 ); -Using the supplied template, creat the temporary directory in +Using the supplied template, create the temporary directory in a standard location for temporary files. Equivalent to doing $tempdir = tempdir ( $template, DIR => File::Spec->tmpdir); @@ -1130,7 +1135,7 @@ nor a directory are supplied. $tempdir = tempdir( $template, CLEANUP => 1); -Create a temporary directory using the supplied template, but +Create a temporary directory using the supplied template, but attempt to remove it (and all files inside it) when the program exits. Note that an attempt will be made to remove all files from the directory even if they were not created by this module (otherwise @@ -1213,6 +1218,10 @@ sub tempdir { $template =~ m/([\.\]:>]+)$/; $suffixlen = length($1); } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } my $errstr; croak "Error in tempdir() using $template: $errstr" @@ -1237,7 +1246,7 @@ sub tempdir { =head1 MKTEMP FUNCTIONS -The following functions are Perl implementations of the +The following functions are Perl implementations of the mktemp() family of temp file generation system calls. =over 4 @@ -1353,6 +1362,10 @@ sub mkdtemp { $template =~ m/([\.\]:>]+)$/; $suffixlen = length($1); } + if ( ($^O eq 'MacOS') && (substr($template, -1) eq ':') ) { + # dir name has a trailing ':' + ++$suffixlen; + } my ($junk, $tmpdir, $errstr); croak "Error creating temp directory from template $template\: $errstr" unless (($junk, $tmpdir) = _gettemp($template, @@ -1401,7 +1414,7 @@ sub mktemp { =head1 POSIX FUNCTIONS This section describes the re-implementation of the tmpnam() -and tmpfile() functions described in L +and tmpfile() functions described in L using the mkstemp() from this module. Unlike the L implementations, the directory used @@ -1493,7 +1506,7 @@ These functions are provided for backwards compatibility with common tempfile generation C library functions. They are not exported and must be addressed using the full package -name. +name. =over 4 @@ -1501,14 +1514,14 @@ name. Return the name of a temporary file in the specified directory using a prefix. The file is guaranteed not to exist at the time -the function was called, but such guarantees are good for one +the function was called, but such guarantees are good for one clock tick only. Always use the proper form of C with C if you must open such a filename. $filename = File::Temp::tempnam( $dir, $prefix ); Equivalent to running mktemp() with $dir/$prefixXXXXXXXX -(using unix file convention as an example) +(using unix file convention as an example) Because this function uses mktemp(), it can suffer from race conditions. @@ -1700,11 +1713,11 @@ for sticky bit. In addition to the MEDIUM security checks, also check for the possibility of ``chown() giveaway'' using the L sysconf() function. If this is a possibility, each directory in the -path is checked in turn for safeness, recursively walking back to the +path is checked in turn for safeness, recursively walking back to the root directory. For platforms that do not support the L -C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is +C<_PC_CHOWN_RESTRICTED> symbol (for example, Windows NT) it is assumed that ``chown() giveaway'' is possible and the recursive test is performed. @@ -1717,7 +1730,7 @@ The level can be changed as follows: The level constants are not exported by the module. Currently, you must be running at least perl v5.6.0 in order to -run with MEDIUM or HIGH security. This is simply because the +run with MEDIUM or HIGH security. This is simply because the safety tests use functions from L that are not available in older versions of perl. The problem is that the version number for Fcntl is the same in perl 5.6.0 and in 5.005_03 even though @@ -1734,7 +1747,7 @@ If you really need to see whether the change has been accepted simply examine the return value of C. $newlevel = File::Temp->safe_level( File::Temp::HIGH ); - die "Could not change to high security" + die "Could not change to high security" if $newlevel != File::Temp::HIGH; =cut @@ -1744,7 +1757,7 @@ simply examine the return value of C. my $LEVEL = STANDARD; sub safe_level { my $self = shift; - if (@_) { + if (@_) { my $level = shift; if (($level != STANDARD) && ($level != MEDIUM) && ($level != HIGH)) { carp "safe_level: Specified level ($level) not STANDARD, MEDIUM or HIGH - ignoring\n" if $^W; @@ -1766,8 +1779,8 @@ simply examine the return value of C. =item TopSystemUID This is the highest UID on the current system that refers to a root -UID. This is used to make sure that the temporary directory is -owned by a system UID (C, C, C etc) rather than +UID. This is used to make sure that the temporary directory is +owned by a system UID (C, C, C etc) rather than simply by root. This is required since on many unix systems C is not owned @@ -1840,7 +1853,7 @@ operating system and to help with portability. L, L, L, L -See L and L for different implementations of +See L and L for different implementations of temporary file handling. =head1 AUTHOR @@ -1852,7 +1865,7 @@ Astronomy Research Council. All Rights Reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. -Original Perl implementation loosely based on the OpenBSD C code for +Original Perl implementation loosely based on the OpenBSD C code for mkstemp(). Thanks to Tom Christiansen for suggesting that this module should be written and providing ideas for code improvements and security enhancements. diff --git a/lib/File/Temp/t/security.t b/lib/File/Temp/t/security.t index 7f557e3..e0cf85b 100755 --- a/lib/File/Temp/t/security.t +++ b/lib/File/Temp/t/security.t @@ -27,7 +27,7 @@ ok(1); # The high security tests must currently be skipped on some platforms my $skipplat = ( ( # No sticky bits. - $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'os2' || $^O eq 'dos' || $^O eq 'mpeix' + $^O eq 'MSWin32' || $^O eq 'NetWare' || $^O eq 'os2' || $^O eq 'dos' || $^O eq 'mpeix' || $^O eq 'MacOS' ) ? 1 : 0 ); # Can not run high security tests in perls before 5.6.0 diff --git a/lib/strict.t b/lib/strict.t index 6067ad3..3a0a2ec 100644 --- a/lib/strict.t +++ b/lib/strict.t @@ -69,11 +69,11 @@ for (@prgs){ print TEST $prog,"\n"; close TEST; my $results = $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : - $^O eq 'MacOS' ? - `$^X -I::lib $switch $tmpfile` : + `.\\perl -I../lib $switch $tmpfile 2>&1` : $^O eq 'NetWare' ? - `perl -I../lib $switch $tmpfile 2>&1` : + `perl -I../lib $switch $tmpfile 2>&1` : + $^O eq 'MacOS' ? + `$^X -I::lib -MMac::err=unix $switch $tmpfile` : `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; diff --git a/lib/subs.t b/lib/subs.t index 2f684b4..a98dd1d 100644 --- a/lib/subs.t +++ b/lib/subs.t @@ -47,11 +47,13 @@ for (@prgs){ print TEST $prog,"\n"; close TEST; my $results = $Is_VMS ? - `./perl $switch $tmpfile 2>&1` : + `./perl $switch $tmpfile 2>&1` : $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : + `.\\perl -I../lib $switch $tmpfile 2>&1` : $Is_NetWare ? - `perl -I../lib $switch $tmpfile 2>&1` : + `perl -I../lib $switch $tmpfile 2>&1` : + $Is_MacOS ? + `$^X -I::lib -MMac::err=unix $switch $tmpfile` : `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; diff --git a/lib/warnings.t b/lib/warnings.t index d234a98..b6daebc 100644 --- a/lib/warnings.t +++ b/lib/warnings.t @@ -91,11 +91,13 @@ for (@prgs){ print TEST $prog,"\n"; close TEST; my $results = $Is_VMS ? - `./perl "-I../lib" $switch $tmpfile` : + `./perl "-I../lib" $switch $tmpfile` : $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile` : + `.\\perl -I../lib $switch $tmpfile` : $Is_NetWare ? - `perl -I../lib $switch $tmpfile` : + `perl -I../lib $switch $tmpfile` : + $Is_MacOS ? + `$^X -I::lib $switch -MMac::err=unix $tmpfile` : `./perl -I../lib $switch $tmpfile`; my $status = $?; $results =~ s/\n+$//; diff --git a/perl.c b/perl.c index 5f07bfc..c671343 100644 --- a/perl.c +++ b/perl.c @@ -1562,7 +1562,7 @@ S_run_body(pTHX_ I32 oldscope) if (PL_minus_c) { #ifdef MACOS_TRADITIONAL - PerlIO_printf(Perl_error_log, "%s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); + PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename)); #else PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename); #endif diff --git a/perl.h b/perl.h index 6601c76..6f3026c 100644 --- a/perl.h +++ b/perl.h @@ -1813,6 +1813,10 @@ typedef struct ptr_tbl PTR_TBL_t; # define PERL_SYS_INIT3(argvp,argcp,envp) PERL_SYS_INIT(argvp,argcp) #endif +#ifndef PERL_WRITE_MSG_TO_CONSOLE +# define PERL_WRITE_MSG_TO_CONSOLE(io, msg, len) PerlIO_write(io, msg, len) +#endif + #ifndef MAXPATHLEN # ifdef PATH_MAX # ifdef _POSIX_PATH_MAX diff --git a/pp_ctl.c b/pp_ctl.c index 2c7bde3..4b81fe5 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -1493,7 +1493,7 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen) #endif PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; diff --git a/t/op/magic.t b/t/op/magic.t index ae1b1d9..bbccd8e 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -37,21 +37,26 @@ sub skip { print "1..41\n"; - $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; $Is_VMS = $^O eq 'VMS'; -$Is_Dos = $^O eq 'dos'; -$Is_os2 = $^O eq 'os2'; -$Is_Cygwin = $^O eq 'cygwin'; +$Is_Dos = $^O eq 'dos'; +$Is_os2 = $^O eq 'os2'; +$Is_Cygwin = $^O eq 'cygwin'; +$Is_MacOS = $^O eq 'MacOS'; $Is_MPE = $^O eq 'mpeix'; -$PERL = ($Is_MSWin32 ? '.\perl' : ($Is_NetWare ? 'perl' : './perl')); + +$PERL = ($Is_NetWare ? 'perl' : + $Is_MacOS ? $^X : + $Is_MSWin32 ? '.\perl' : + './perl'); eval '$ENV{"FOO"} = "hi there";'; # check that ENV is inited inside eval # cmd.exe will echo 'variable=value' but 4nt will echo just the value # -- Nikola Knezevic -if ($Is_MSWin32) { ok `set FOO` =~ /^(FOO=)?hi there$/; } -else { ok `echo \$FOO` eq "hi there\n"; } +if ($Is_MSWin32) { ok `set FOO` =~ /^(FOO=)?hi there$/; } +elsif ($Is_MacOS) { ok "1 # skipped", 1; } +else { ok `echo \$FOO` eq "hi there\n"; } unlink 'ajslkdfpqjsjfk'; $! = 0; @@ -59,7 +64,7 @@ open(FOO,'ajslkdfpqjsjfk'); ok $!, $!; close FOO; # just mention it, squelch used-only-once -if ($Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE) { +if ($Is_MSWin32 || $Is_NetWare || $Is_Dos || $Is_MPE || $Is_MacOS) { skip() for 1..2; } else { @@ -142,10 +147,13 @@ ok $$ > 0, $$; elsif($Is_os2) { $wd = Cwd::sys_cwd(); } + elsif($Is_MacOS) { + $wd = ':'; + } else { $wd = '.'; } - my $perl = "$wd/perl"; + my $perl = $Is_MacOS ? $^X : "$wd/perl"; my $headmaybe = ''; my $tailmaybe = ''; $script = "$wd/show-shebang"; @@ -170,6 +178,12 @@ EOT elsif ($Is_os2) { $script = "./show-shebang"; } + elsif ($Is_MacOS) { + $script = ":show-shebang"; + } + elsif ($Is_MacOS) { + $script = ":show-shebang"; + } if ($^O eq 'os390' or $^O eq 'posix-bc' or $^O eq 'vmesa') { # no shebang $headmaybe = <= 5.00319, $]; ok $^O; ok $^T > 850000000, $^T; -if ($Is_VMS || $Is_Dos) { +if ($Is_VMS || $Is_Dos || $Is_MacOS) { skip() for 1..2; } else { diff --git a/t/op/runlevel.t b/t/op/runlevel.t index 1364801..60c19a5 100755 --- a/t/op/runlevel.t +++ b/t/op/runlevel.t @@ -33,12 +33,14 @@ for (@prgs){ print TEST "$prog\n"; close TEST; my $results = $Is_VMS ? - `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : - $Is_MSWin32 ? - `.\\perl -I../lib $switch $tmpfile 2>&1` : - $Is_NetWare ? - `perl -I../lib $switch $tmpfile 2>&1` : - `./perl $switch $tmpfile 2>&1`; + `MCR $^X "-I[-.lib]" $switch $tmpfile 2>&1` : + $Is_MSWin32 ? + `.\\perl -I../lib $switch $tmpfile 2>&1` : + $Is_NetWare ? + `perl -I../lib $switch $tmpfile 2>&1` : + $Is_MacOS ? + `$^X -I::lib -MMac::err=unix $switch $tmpfile` : + `./perl $switch $tmpfile 2>&1`; my $status = $?; $results =~ s/\n+$//; # allow expected output to be written as if $prog is on STDIN diff --git a/t/pod/testp2pt.pl b/t/pod/testp2pt.pl index 735350f..4d99f82 100644 --- a/t/pod/testp2pt.pl +++ b/t/pod/testp2pt.pl @@ -47,8 +47,10 @@ if ($^O eq 'VMS') { # clean up directory spec $INSTDIR =~ s#/$##; $INSTDIR =~ s#/000000/#/#; } +# cut 't/pod' from path (cut 't:pod:' on Mac OS) $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 'pod'); $INSTDIR = (dirname $INSTDIR) if (basename($INSTDIR) eq 't'); + my @PODINCDIRS = ( catfile($INSTDIR, 'lib', 'Pod'), catfile($INSTDIR, 'scripts'), catfile($INSTDIR, 'pod'), diff --git a/t/run/kill_perl.t b/t/run/kill_perl.t index 9dcd59d..1d09d4e 100644 --- a/t/run/kill_perl.t +++ b/t/run/kill_perl.t @@ -75,6 +75,9 @@ foreach my $prog (@prgs) { elsif ($^O eq 'NetWare') { $results = `perl -I../lib $switch $tmpfile 2>&1`; } + elsif ($^O eq 'MacOS') { + $results = `$^X -I::lib -MMac::err=unix $switch $tmpfile`; + } else { $results = `./perl -I../lib $switch $tmpfile 2>&1`; } diff --git a/util.c b/util.c index e1bf571..29935d2 100644 --- a/util.c +++ b/util.c @@ -1234,7 +1234,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) #endif PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; @@ -1327,7 +1327,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!' @@ -1442,7 +1442,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); } my_failure_exit(); @@ -1479,7 +1479,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!'