1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
|
package ExtUtils::Helpers::VMS;
$ExtUtils::Helpers::VMS::VERSION = '0.022';
use strict;
use warnings FATAL => 'all';
use Exporter 5.57 'import';
our @EXPORT = qw/make_executable split_like_shell detildefy/;
use ExtUtils::Helpers::Unix qw/split_like_shell/; # Probably very wrong, but whatever
use File::Copy qw/copy/;
sub make_executable {
my $filename = shift;
my $batchname = "$filename.com";
copy($filename, $batchname);
ExtUtils::Helpers::Unix::make_executable($batchname);
return;
}
sub detildefy {
my $arg = shift;
# Apparently double ~ are not translated.
return $arg if ($arg =~ /^~~/);
# Apparently ~ followed by whitespace are not translated.
return $arg if ($arg =~ /^~ /);
if ($arg =~ /^~/) {
my $spec = $arg;
# Remove the tilde
$spec =~ s/^~//;
# Remove any slash following the tilde if present.
$spec =~ s#^/##;
# break up the paths for the merge
my $home = VMS::Filespec::unixify($ENV{HOME});
# In the default VMS mode, the trailing slash is present.
# In Unix report mode it is not. The parsing logic assumes that
# it is present.
$home .= '/' unless $home =~ m#/$#;
# Trivial case of just ~ by it self
if ($spec eq '') {
$home =~ s#/$##;
return $home;
}
my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
if ($hdir eq '') {
# Someone has tampered with $ENV{HOME}
# So hfile is probably the directory since this should be
# a path.
$hdir = $hfile;
}
my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
my @hdirs = File::Spec::Unix->splitdir($hdir);
my @dirs = File::Spec::Unix->splitdir($dir);
my $newdirs;
# Two cases of tilde handling
if ($arg =~ m#^~/#) {
# Simple case, just merge together
$newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
} else {
# Complex case, need to add an updir - No delimiters
my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
$newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
}
# Now put the two cases back together
$arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
}
return $arg;
}
# ABSTRACT: VMS specific helper bits
__END__
=pod
=encoding UTF-8
=head1 NAME
ExtUtils::Helpers::VMS - VMS specific helper bits
=head1 VERSION
version 0.022
=for Pod::Coverage make_executable
detildefy
=head1 AUTHORS
=over 4
=item *
Ken Williams <kwilliams@cpan.org>
=item *
Leon Timmermans <leont@cpan.org>
=back
=head1 COPYRIGHT AND LICENSE
This software is copyright (c) 2004 by Ken Williams, Leon Timmermans.
This is free software; you can redistribute it and/or modify it under
the same terms as the Perl 5 programming language system itself.
=cut
|
