This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
VMS override for Module::Build::Base::find_perl_interpreter,
[perl5.git] / lib / Module / Build / Platform / VMS.pm
1 package Module::Build::Platform::VMS;
2
3 use strict;
4 use Module::Build::Base;
5
6 use vars qw(@ISA);
7 @ISA = qw(Module::Build::Base);
8
9
10
11 =head1 NAME
12
13 Module::Build::Platform::VMS - Builder class for VMS platforms
14
15 =head1 DESCRIPTION
16
17 This module inherits from C<Module::Build::Base> and alters a few
18 minor details of its functionality.  Please see L<Module::Build> for
19 the general docs.
20
21 =head2 Overridden Methods
22
23 =over 4
24
25 =item _set_defaults
26
27 Change $self->{build_script} to 'Build.com' so @Build works.
28
29 =cut
30
31 sub _set_defaults {
32     my $self = shift;
33     $self->SUPER::_set_defaults(@_);
34
35     $self->{properties}{build_script} = 'Build.com';
36 }
37
38
39 =item cull_args
40
41 '@Build foo' on VMS will not preserve the case of 'foo'.  Rather than forcing
42 people to write '@Build "foo"' we'll dispatch case-insensitively.
43
44 =cut
45
46 sub cull_args {
47     my $self = shift;
48     my($action, $args) = $self->SUPER::cull_args(@_);
49     my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
50
51     die "Ambiguous action '$action'.  Could be one of @possible_actions"
52         if @possible_actions > 1;
53
54     return ($possible_actions[0], $args);
55 }
56
57
58 =item manpage_separator
59
60 Use '__' instead of '::'.
61
62 =cut
63
64 sub manpage_separator {
65     return '__';
66 }
67
68
69 =item prefixify
70
71 Prefixify taking into account VMS' filepath syntax.
72
73 =cut
74
75 # Translated from ExtUtils::MM_VMS::prefixify()
76 sub _prefixify {
77     my($self, $path, $sprefix, $type) = @_;
78     my $rprefix = $self->prefix;
79
80     $self->log_verbose("  prefixify $path from $sprefix to $rprefix\n");
81
82     # Translate $(PERLPREFIX) to a real path.
83     $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
84     $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
85
86     $self->log_verbose("  rprefix translated to $rprefix\n".
87                        "  sprefix translated to $sprefix\n");
88
89     if( length $path == 0 ) {
90         $self->log_verbose("  no path to prefixify.\n")
91     }
92     elsif( !File::Spec->file_name_is_absolute($path) ) {
93         $self->log_verbose("    path is relative, not prefixifying.\n");
94     }
95     elsif( $sprefix eq $rprefix ) {
96         $self->log_verbose("  no new prefix.\n");
97     }
98     else {
99         my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
100         my $vms_prefix = $self->config('vms_prefix');
101         if( $path_vol eq $vms_prefix.':' ) {
102             $self->log_verbose("  $vms_prefix: seen\n");
103
104             $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
105             $path = $self->_catprefix($rprefix, $path_dirs);
106         }
107         else {
108             $self->log_verbose("    cannot prefixify.\n");
109             return $self->prefix_relpaths($self->installdirs, $type);
110         }
111     }
112
113     $self->log_verbose("    now $path\n");
114
115     return $path;
116 }
117
118 =item _quote_args
119
120 Command-line arguments (but not the command itself) must be quoted
121 to ensure case preservation.
122
123 =cut
124
125 sub _quote_args {
126   # Returns a string that can become [part of] a command line with
127   # proper quoting so that the subprocess sees this same list of args,
128   # or if we get a single arg that is an array reference, quote the
129   # elements of it and return the reference.
130   my ($self, @args) = @_;
131   my $got_arrayref = (scalar(@args) == 1 
132                       && UNIVERSAL::isa($args[0], 'ARRAY')) 
133                    ? 1 
134                    : 0;
135
136   map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 }
137      ($got_arrayref ? @{$args[0]} 
138                     : @args
139      );
140
141   return $got_arrayref ? $args[0] 
142                        : join(' ', @args);
143 }
144
145 =item have_forkpipe
146
147 There is no native fork(), so some constructs depending on it are not
148 available.
149
150 =cut
151
152 sub have_forkpipe { 0 }
153
154 =item _backticks
155
156 Override to ensure that we quote the arguments but not the command.
157
158 =cut
159
160 sub _backticks {
161   # The command must not be quoted but the arguments to it must be.
162   my ($self, @cmd) = @_;
163   my $cmd = shift @cmd;
164   my $args = $self->_quote_args(@cmd);
165   return `$cmd $args`;
166 }
167
168 =item do_system
169
170 Override to ensure that we quote the arguments but not the command.
171
172 =cut
173
174 sub do_system {
175   # The command must not be quoted but the arguments to it must be.
176   my ($self, @cmd) = @_;
177   $self->log_info("@cmd\n");
178   my $cmd = shift @cmd;
179   my $args = $self->_quote_args(@cmd);
180   return !system("$cmd $args");
181 }
182
183 =item _infer_xs_spec
184
185 Inherit the standard version but tweak the library file name to be 
186 something Dynaloader can find.
187
188 =cut
189
190 sub _infer_xs_spec {
191   my $self = shift;
192   my $file = shift;
193
194   my $spec = $self->SUPER::_infer_xs_spec($file);
195
196   # Need to create with the same name as DynaLoader will load with.
197   if (defined &DynaLoader::mod2fname) {
198     my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
199     $file =~ tr/:/_/;
200     $file = DynaLoader::mod2fname([$file]);
201     $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
202   }
203
204   return $spec;
205 }
206
207 =item rscan_dir
208
209 Inherit the standard version but remove dots at end of name.  This may not be 
210 necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect.
211
212 =cut
213
214 sub rscan_dir {
215   my ($self, $dir, $pattern) = @_;
216
217   my $result = $self->SUPER::rscan_dir( $dir, $pattern );
218
219   for my $file (@$result) { $file =~ s/\.$//; }
220   return $result;
221 }
222
223 =item dist_dir
224
225 Inherit the standard version but replace embedded dots with underscores because 
226 a dot is the directory delimiter on VMS.
227
228 =cut
229
230 sub dist_dir {
231   my $self = shift;
232
233   my $dist_dir = $self->SUPER::dist_dir;
234   $dist_dir =~ s/\./_/g;
235   return $dist_dir;
236 }
237
238 =item man3page_name
239
240 Inherit the standard version but chop the extra manpage delimiter off the front if 
241 there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
242
243 =cut
244
245 sub man3page_name {
246   my $self = shift;
247
248   my $mpname = $self->SUPER::man3page_name( shift );
249   my $sep = $self->manpage_separator;
250   $mpname =~ s/^$sep//;
251   return $mpname;
252 }
253
254 =item expand_test_dir
255
256 Inherit the standard version but relativize the paths as the native glob() doesn't
257 do that for us.
258
259 =cut
260
261 sub expand_test_dir {
262   my ($self, $dir) = @_;
263
264   my @reldirs = $self->SUPER::expand_test_dir( $dir );
265
266   for my $eachdir (@reldirs) {
267     my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
268     my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
269     $eachdir = File::Spec->catfile( $reldir, $f );
270   }
271   return @reldirs;
272 }
273
274 =item _detildefy
275
276 The home-grown glob() does not currently handle tildes, so provide limited support
277 here.  Expect only UNIX format file specifications for now.
278
279 =cut
280
281 sub _detildefy {
282     my ($self, $arg) = @_;
283
284     # Apparently double ~ are not translated.
285     return $arg if ($arg =~ /^~~/);
286
287     # Apparently ~ followed by whitespace are not translated.
288     return $arg if ($arg =~ /^~ /);
289
290     if ($arg =~ /^~/) {
291         my $spec = $arg;
292
293         # Remove the tilde
294         $spec =~ s/^~//;
295
296         # Remove any slash folloing the tilde if present.
297         $spec =~ s#^/##;
298
299         # break up the paths for the merge
300         my $home = VMS::Filespec::unixify($ENV{HOME});
301
302         # Trivial case of just ~ by it self
303         if ($spec eq '') {
304             return $home;
305         }
306
307         my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
308         if ($hdir eq '') {
309              # Someone has tampered with $ENV{HOME}
310              # So hfile is probably the directory since this should be
311              # a path.
312              $hdir = $hfile;
313         }
314
315         my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
316
317         my @hdirs = File::Spec::Unix->splitdir($hdir);
318         my @dirs = File::Spec::Unix->splitdir($dir);
319
320         my $newdirs;
321
322         # Two cases of tilde handling
323         if ($arg =~ m#^~/#) {
324
325             # Simple case, just merge together
326             $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
327
328         } else {
329
330             # Complex case, need to add an updir - No delimiters
331             my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
332
333             $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
334
335         }
336         
337         # Now put the two cases back together
338         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
339
340     } else {
341         return $arg;
342     }
343
344 }
345
346 =item find_perl_interpreter
347
348 On VMS, $^X returns the fully qualified absolute path including version number. 
349 It's logically impossible to improve on it for getting the perl we're currently
350 running, and attempting to manipulate it is usually lossy.
351
352 =cut
353
354 sub find_perl_interpreter { return $^X; }
355
356 =back
357
358 =head1 AUTHOR
359
360 Michael G Schwern <schwern@pobox.com>
361 Ken Williams <kwilliams@cpan.org>
362 Craig A. Berry <craigberry@mac.com>
363
364 =head1 SEE ALSO
365
366 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
367
368 =cut
369
370 1;
371 __END__