Bump Module::Build version to 0.340201
[perl.git] / lib / Module / Build / Platform / VMS.pm
1 package Module::Build::Platform::VMS;
2
3 use strict;
4 use vars qw($VERSION);
5 $VERSION = '0.340201';
6 $VERSION = eval $VERSION;
7 use Module::Build::Base;
8
9 use vars qw(@ISA);
10 @ISA = qw(Module::Build::Base);
11
12
13
14 =head1 NAME
15
16 Module::Build::Platform::VMS - Builder class for VMS platforms
17
18 =head1 DESCRIPTION
19
20 This module inherits from C<Module::Build::Base> and alters a few
21 minor details of its functionality.  Please see L<Module::Build> for
22 the general docs.
23
24 =head2 Overridden Methods
25
26 =over 4
27
28 =item _set_defaults
29
30 Change $self->{build_script} to 'Build.com' so @Build works.
31
32 =cut
33
34 sub _set_defaults {
35     my $self = shift;
36     $self->SUPER::_set_defaults(@_);
37
38     $self->{properties}{build_script} = 'Build.com';
39 }
40
41
42 =item cull_args
43
44 '@Build foo' on VMS will not preserve the case of 'foo'.  Rather than forcing
45 people to write '@Build "foo"' we'll dispatch case-insensitively.
46
47 =cut
48
49 sub cull_args {
50     my $self = shift;
51     my($action, $args) = $self->SUPER::cull_args(@_);
52     my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
53
54     die "Ambiguous action '$action'.  Could be one of @possible_actions"
55         if @possible_actions > 1;
56
57     return ($possible_actions[0], $args);
58 }
59
60
61 =item manpage_separator
62
63 Use '__' instead of '::'.
64
65 =cut
66
67 sub manpage_separator {
68     return '__';
69 }
70
71
72 =item prefixify
73
74 Prefixify taking into account VMS' filepath syntax.
75
76 =cut
77
78 # Translated from ExtUtils::MM_VMS::prefixify()
79 sub _prefixify {
80     my($self, $path, $sprefix, $type) = @_;
81     my $rprefix = $self->prefix;
82
83     $self->log_verbose("  prefixify $path from $sprefix to $rprefix\n");
84
85     # Translate $(PERLPREFIX) to a real path.
86     $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
87     $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
88
89     $self->log_verbose("  rprefix translated to $rprefix\n".
90                        "  sprefix translated to $sprefix\n");
91
92     if( length $path == 0 ) {
93         $self->log_verbose("  no path to prefixify.\n")
94     }
95     elsif( !File::Spec->file_name_is_absolute($path) ) {
96         $self->log_verbose("    path is relative, not prefixifying.\n");
97     }
98     elsif( $sprefix eq $rprefix ) {
99         $self->log_verbose("  no new prefix.\n");
100     }
101     else {
102         my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
103         my $vms_prefix = $self->config('vms_prefix');
104         if( $path_vol eq $vms_prefix.':' ) {
105             $self->log_verbose("  $vms_prefix: seen\n");
106
107             $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
108             $path = $self->_catprefix($rprefix, $path_dirs);
109         }
110         else {
111             $self->log_verbose("    cannot prefixify.\n");
112             return $self->prefix_relpaths($self->installdirs, $type);
113         }
114     }
115
116     $self->log_verbose("    now $path\n");
117
118     return $path;
119 }
120
121 =item _quote_args
122
123 Command-line arguments (but not the command itself) must be quoted
124 to ensure case preservation.
125
126 =cut
127
128 sub _quote_args {
129   # Returns a string that can become [part of] a command line with
130   # proper quoting so that the subprocess sees this same list of args,
131   # or if we get a single arg that is an array reference, quote the
132   # elements of it and return the reference.
133   my ($self, @args) = @_;
134   my $got_arrayref = (scalar(@args) == 1 
135                       && UNIVERSAL::isa($args[0], 'ARRAY')) 
136                    ? 1 
137                    : 0;
138
139   # Do not quote qualifiers that begin with '/'.
140   map { if (!/^\//) { 
141           $_ =~ s/\"/""/g;     # escape C<"> by doubling
142           $_ = q(").$_.q(");
143         }
144   }
145     ($got_arrayref ? @{$args[0]} 
146                    : @args
147     );
148
149   return $got_arrayref ? $args[0] 
150                        : join(' ', @args);
151 }
152
153 =item have_forkpipe
154
155 There is no native fork(), so some constructs depending on it are not
156 available.
157
158 =cut
159
160 sub have_forkpipe { 0 }
161
162 =item _backticks
163
164 Override to ensure that we quote the arguments but not the command.
165
166 =cut
167
168 sub _backticks {
169   # The command must not be quoted but the arguments to it must be.
170   my ($self, @cmd) = @_;
171   my $cmd = shift @cmd;
172   my $args = $self->_quote_args(@cmd);
173   return `$cmd $args`;
174 }
175
176 =item do_system
177
178 Override to ensure that we quote the arguments but not the command.
179
180 =cut
181
182 sub do_system {
183   # The command must not be quoted but the arguments to it must be.
184   my ($self, @cmd) = @_;
185   $self->log_info("@cmd\n");
186   my $cmd = shift @cmd;
187   my $args = $self->_quote_args(@cmd);
188   return !system("$cmd $args");
189 }
190
191 =item oneliner
192
193 Override to ensure that we do not quote the command.
194
195 =cut
196
197 sub oneliner {
198     my $self = shift;
199     my $oneliner = $self->SUPER::oneliner(@_);
200
201     $oneliner =~ s/^\"\S+\"//;
202
203     return "MCR $^X $oneliner";
204 }
205
206 =item _infer_xs_spec
207
208 Inherit the standard version but tweak the library file name to be 
209 something Dynaloader can find.
210
211 =cut
212
213 sub _infer_xs_spec {
214   my $self = shift;
215   my $file = shift;
216
217   my $spec = $self->SUPER::_infer_xs_spec($file);
218
219   # Need to create with the same name as DynaLoader will load with.
220   if (defined &DynaLoader::mod2fname) {
221     my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
222     $file =~ tr/:/_/;
223     $file = DynaLoader::mod2fname([$file]);
224     $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
225   }
226
227   return $spec;
228 }
229
230 =item rscan_dir
231
232 Inherit the standard version but remove dots at end of name.
233 If the extended character set is in effect, do not remove dots from filenames
234 with Unix path delimiters.
235
236 =cut
237
238 sub rscan_dir {
239   my ($self, $dir, $pattern) = @_;
240
241   my $result = $self->SUPER::rscan_dir( $dir, $pattern );
242
243   for my $file (@$result) {
244       if (!_efs() && ($file =~ m#/#)) {
245           $file =~ s/\.$//;
246       }
247   }
248   return $result;
249 }
250
251 =item dist_dir
252
253 Inherit the standard version but replace embedded dots with underscores because 
254 a dot is the directory delimiter on VMS.
255
256 =cut
257
258 sub dist_dir {
259   my $self = shift;
260
261   my $dist_dir = $self->SUPER::dist_dir;
262   $dist_dir =~ s/\./_/g unless _efs();
263   return $dist_dir;
264 }
265
266 =item man3page_name
267
268 Inherit the standard version but chop the extra manpage delimiter off the front if 
269 there is one.  The VMS version of splitdir('[.foo]') returns '', 'foo'.
270
271 =cut
272
273 sub man3page_name {
274   my $self = shift;
275
276   my $mpname = $self->SUPER::man3page_name( shift );
277   my $sep = $self->manpage_separator;
278   $mpname =~ s/^$sep//;
279   return $mpname;
280 }
281
282 =item expand_test_dir
283
284 Inherit the standard version but relativize the paths as the native glob() doesn't
285 do that for us.
286
287 =cut
288
289 sub expand_test_dir {
290   my ($self, $dir) = @_;
291
292   my @reldirs = $self->SUPER::expand_test_dir( $dir );
293
294   for my $eachdir (@reldirs) {
295     my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
296     my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
297     $eachdir = File::Spec->catfile( $reldir, $f );
298   }
299   return @reldirs;
300 }
301
302 =item _detildefy
303
304 The home-grown glob() does not currently handle tildes, so provide limited support
305 here.  Expect only UNIX format file specifications for now.
306
307 =cut
308
309 sub _detildefy {
310     my ($self, $arg) = @_;
311
312     # Apparently double ~ are not translated.
313     return $arg if ($arg =~ /^~~/);
314
315     # Apparently ~ followed by whitespace are not translated.
316     return $arg if ($arg =~ /^~ /);
317
318     if ($arg =~ /^~/) {
319         my $spec = $arg;
320
321         # Remove the tilde
322         $spec =~ s/^~//;
323
324         # Remove any slash following the tilde if present.
325         $spec =~ s#^/##;
326
327         # break up the paths for the merge
328         my $home = VMS::Filespec::unixify($ENV{HOME});
329
330         # In the default VMS mode, the trailing slash is present.
331         # In Unix report mode it is not.  The parsing logic assumes that
332         # it is present.
333         $home .= '/' unless $home =~ m#/$#;
334
335         # Trivial case of just ~ by it self
336         if ($spec eq '') {
337             $home =~ s#/$##;
338             return $home;
339         }
340
341         my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
342         if ($hdir eq '') {
343              # Someone has tampered with $ENV{HOME}
344              # So hfile is probably the directory since this should be
345              # a path.
346              $hdir = $hfile;
347         }
348
349         my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
350
351         my @hdirs = File::Spec::Unix->splitdir($hdir);
352         my @dirs = File::Spec::Unix->splitdir($dir);
353
354         my $newdirs;
355
356         # Two cases of tilde handling
357         if ($arg =~ m#^~/#) {
358
359             # Simple case, just merge together
360             $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
361
362         } else {
363
364             # Complex case, need to add an updir - No delimiters
365             my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
366
367             $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
368
369         }
370         
371         # Now put the two cases back together
372         $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
373
374     }
375     return $arg;
376
377 }
378
379 =item find_perl_interpreter
380
381 On VMS, $^X returns the fully qualified absolute path including version
382 number.  It's logically impossible to improve on it for getting the perl
383 we're currently running, and attempting to manipulate it is usually
384 lossy.
385
386 =cut
387
388 sub find_perl_interpreter {
389     return VMS::Filespec::vmsify($^X);
390 }
391
392 =item localize_file_path
393
394 Convert the file path to the local syntax
395
396 =cut
397
398 sub localize_file_path {
399   my ($self, $path) = @_;
400   $path = VMS::Filespec::vmsify($path);
401   $path =~ s/\.\z//;
402   return $path;
403 }
404
405 =item localize_dir_path
406
407 Convert the directory path to the local syntax
408
409 =cut
410
411 sub localize_dir_path {
412   my ($self, $path) = @_;
413   return VMS::Filespec::vmspath($path);
414 }
415
416 =item ACTION_clean
417
418 The home-grown glob() expands a bit too aggressively when given a bare name,
419 so default in a zero-length extension.
420
421 =cut
422
423 sub ACTION_clean {
424   my ($self) = @_;
425   foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
426     $self->delete_filetree($item);
427   }
428 }
429
430
431 # Need to look up the feature settings.  The preferred way is to use the
432 # VMS::Feature module, but that may not be available to dual life modules.
433
434 my $use_feature;
435 BEGIN {
436     if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
437         $use_feature = 1;
438     }
439 }
440
441 # Need to look up the UNIX report mode.  This may become a dynamic mode
442 # in the future.
443 sub _unix_rpt {
444     my $unix_rpt;
445     if ($use_feature) {
446         $unix_rpt = VMS::Feature::current("filename_unix_report");
447     } else {
448         my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
449         $unix_rpt = $env_unix_rpt =~ /^[ET1]/i; 
450     }
451     return $unix_rpt;
452 }
453
454 # Need to look up the EFS character set mode.  This may become a dynamic
455 # mode in the future.
456 sub _efs {
457     my $efs;
458     if ($use_feature) {
459         $efs = VMS::Feature::current("efs_charset");
460     } else {
461         my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
462         $efs = $env_efs =~ /^[ET1]/i; 
463     }
464     return $efs;
465 }
466
467 =back
468
469 =head1 AUTHOR
470
471 Michael G Schwern <schwern@pobox.com>
472 Ken Williams <kwilliams@cpan.org>
473 Craig A. Berry <craigberry@mac.com>
474
475 =head1 SEE ALSO
476
477 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
478
479 =cut
480
481 1;
482 __END__