1 package Module::Build::Platform::VMS;
6 $VERSION = eval $VERSION;
7 use Module::Build::Base;
11 @ISA = qw(Module::Build::Base);
17 Module::Build::Platform::VMS - Builder class for VMS platforms
21 This module inherits from C<Module::Build::Base> and alters a few
22 minor details of its functionality. Please see L<Module::Build> for
25 =head2 Overridden Methods
31 Change $self->{build_script} to 'Build.com' so @Build works.
37 $self->SUPER::_set_defaults(@_);
39 $self->{properties}{build_script} = 'Build.com';
45 '@Build foo' on VMS will not preserve the case of 'foo'. Rather than forcing
46 people to write '@Build "foo"' we'll dispatch case-insensitively.
52 my($action, $args) = $self->SUPER::cull_args(@_);
53 my @possible_actions = grep { lc $_ eq lc $action } $self->known_actions;
55 die "Ambiguous action '$action'. Could be one of @possible_actions"
56 if @possible_actions > 1;
58 return ($possible_actions[0], $args);
62 =item manpage_separator
64 Use '__' instead of '::'.
68 sub manpage_separator {
75 Prefixify taking into account VMS' filepath syntax.
79 # Translated from ExtUtils::MM_VMS::prefixify()
82 my($self, $rprefix, $default) = @_;
84 my($rvol, $rdirs) = File::Spec->splitpath($rprefix);
86 return File::Spec->catpath($rvol,
87 File::Spec->catdir($rdirs, $default),
92 return File::Spec->catdir($rdirs, $default);
98 my($self, $path, $sprefix, $type) = @_;
99 my $rprefix = $self->prefix;
101 return '' unless defined $path;
103 $self->log_verbose(" prefixify $path from $sprefix to $rprefix\n");
105 # Translate $(PERLPREFIX) to a real path.
106 $rprefix = VMS::Filespec::vmspath($rprefix) if $rprefix;
107 $sprefix = VMS::Filespec::vmspath($sprefix) if $sprefix;
109 $self->log_verbose(" rprefix translated to $rprefix\n".
110 " sprefix translated to $sprefix\n");
112 if( length($path) == 0 ) {
113 $self->log_verbose(" no path to prefixify.\n")
115 elsif( !File::Spec->file_name_is_absolute($path) ) {
116 $self->log_verbose(" path is relative, not prefixifying.\n");
118 elsif( $sprefix eq $rprefix ) {
119 $self->log_verbose(" no new prefix.\n");
122 my($path_vol, $path_dirs) = File::Spec->splitpath( $path );
123 my $vms_prefix = $self->config('vms_prefix');
124 if( $path_vol eq $vms_prefix.':' ) {
125 $self->log_verbose(" $vms_prefix: seen\n");
127 $path_dirs =~ s{^\[}{\[.} unless $path_dirs =~ m{^\[\.};
128 $path = $self->_catprefix($rprefix, $path_dirs);
131 $self->log_verbose(" cannot prefixify.\n");
132 return $self->prefix_relpaths($self->installdirs, $type);
136 $self->log_verbose(" now $path\n");
143 Command-line arguments (but not the command itself) must be quoted
144 to ensure case preservation.
149 # Returns a string that can become [part of] a command line with
150 # proper quoting so that the subprocess sees this same list of args,
151 # or if we get a single arg that is an array reference, quote the
152 # elements of it and return the reference.
153 my ($self, @args) = @_;
154 my $got_arrayref = (scalar(@args) == 1
155 && UNIVERSAL::isa($args[0], 'ARRAY'))
159 # Do not quote qualifiers that begin with '/'.
161 $_ =~ s/\"/""/g; # escape C<"> by doubling
165 ($got_arrayref ? @{$args[0]}
169 return $got_arrayref ? $args[0]
175 There is no native fork(), so some constructs depending on it are not
180 sub have_forkpipe { 0 }
184 Override to ensure that we quote the arguments but not the command.
189 # The command must not be quoted but the arguments to it must be.
190 my ($self, @cmd) = @_;
191 my $cmd = shift @cmd;
192 my $args = $self->_quote_args(@cmd);
198 Local an executable program
203 my ($self, $command) = @_;
205 # a lot of VMS executables have a symbol defined
207 if ( $^O eq 'VMS' ) {
209 my $syms = VMS::DCLsym->new;
210 return $command if scalar $syms->getsym( uc $command );
213 $self->SUPER::find_command($command);
216 # _maybe_command copied from ExtUtils::MM_VMS::maybe_command
218 =item _maybe_command (override)
220 Follows VMS naming conventions for executable files.
221 If the name passed in doesn't exactly match an executable file,
222 appends F<.Exe> (or equivalent) to check for executable image, and F<.Com>
223 to check for DCL procedure. If this fails, checks directories in DCL$PATH
224 and finally F<Sys$System:> for an executable file having the name specified,
225 with or without the F<.Exe>-equivalent suffix.
230 my($self,$file) = @_;
231 return $file if -x $file && ! -d _;
233 my(@exts) = ('',$Config{'exe_ext'},'.exe','.com');
235 if ($file !~ m![/:>\]]!) {
236 for (my $i = 0; defined $ENV{"DCL\$PATH;$i"}; $i++) {
237 my $dir = $ENV{"DCL\$PATH;$i"};
238 $dir .= ':' unless $dir =~ m%[\]:]$%;
241 push(@dirs,'Sys$System:');
242 foreach my $dir (@dirs) {
243 my $sysfile = "$dir$file";
244 foreach my $ext (@exts) {
245 return $file if -x "$sysfile$ext" && ! -d _;
254 Override to ensure that we quote the arguments but not the command.
259 # The command must not be quoted but the arguments to it must be.
260 my ($self, @cmd) = @_;
261 $self->log_verbose("@cmd\n");
262 my $cmd = shift @cmd;
263 my $args = $self->_quote_args(@cmd);
264 return !system("$cmd $args");
269 Override to ensure that we do not quote the command.
275 my $oneliner = $self->SUPER::oneliner(@_);
277 $oneliner =~ s/^\"\S+\"//;
279 return "MCR $^X $oneliner";
284 Inherit the standard version but tweak the library file name to be
285 something Dynaloader can find.
293 my $spec = $self->SUPER::_infer_xs_spec($file);
295 # Need to create with the same name as DynaLoader will load with.
296 if (defined &DynaLoader::mod2fname) {
297 my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext');
299 $file = DynaLoader::mod2fname([$file]);
300 $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file);
308 Inherit the standard version but remove dots at end of name.
309 If the extended character set is in effect, do not remove dots from filenames
310 with Unix path delimiters.
315 my ($self, $dir, $pattern) = @_;
317 my $result = $self->SUPER::rscan_dir( $dir, $pattern );
319 for my $file (@$result) {
320 if (!_efs() && ($file =~ m#/#)) {
329 Inherit the standard version but replace embedded dots with underscores because
330 a dot is the directory delimiter on VMS.
337 my $dist_dir = $self->SUPER::dist_dir;
338 $dist_dir =~ s/\./_/g unless _efs();
344 Inherit the standard version but chop the extra manpage delimiter off the front if
345 there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'.
352 my $mpname = $self->SUPER::man3page_name( shift );
353 my $sep = $self->manpage_separator;
354 $mpname =~ s/^$sep//;
358 =item expand_test_dir
360 Inherit the standard version but relativize the paths as the native glob() doesn't
365 sub expand_test_dir {
366 my ($self, $dir) = @_;
368 my @reldirs = $self->SUPER::expand_test_dir( $dir );
370 for my $eachdir (@reldirs) {
371 my ($v,$d,$f) = File::Spec->splitpath( $eachdir );
372 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) );
373 $eachdir = File::Spec->catfile( $reldir, $f );
380 The home-grown glob() does not currently handle tildes, so provide limited support
381 here. Expect only UNIX format file specifications for now.
386 my ($self, $arg) = @_;
388 # Apparently double ~ are not translated.
389 return $arg if ($arg =~ /^~~/);
391 # Apparently ~ followed by whitespace are not translated.
392 return $arg if ($arg =~ /^~ /);
400 # Remove any slash following the tilde if present.
403 # break up the paths for the merge
404 my $home = VMS::Filespec::unixify($ENV{HOME});
406 # In the default VMS mode, the trailing slash is present.
407 # In Unix report mode it is not. The parsing logic assumes that
409 $home .= '/' unless $home =~ m#/$#;
411 # Trivial case of just ~ by it self
417 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home);
419 # Someone has tampered with $ENV{HOME}
420 # So hfile is probably the directory since this should be
425 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec);
427 my @hdirs = File::Spec::Unix->splitdir($hdir);
428 my @dirs = File::Spec::Unix->splitdir($dir);
432 # Two cases of tilde handling
433 if ($arg =~ m#^~/#) {
435 # Simple case, just merge together
436 $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs);
440 # Complex case, need to add an updir - No delimiters
441 my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir);
443 $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs);
447 # Now put the two cases back together
448 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file);
455 =item find_perl_interpreter
457 On VMS, $^X returns the fully qualified absolute path including version
458 number. It's logically impossible to improve on it for getting the perl
459 we're currently running, and attempting to manipulate it is usually
464 sub find_perl_interpreter {
465 return VMS::Filespec::vmsify($^X);
468 =item localize_file_path
470 Convert the file path to the local syntax
474 sub localize_file_path {
475 my ($self, $path) = @_;
476 $path = VMS::Filespec::vmsify($path);
481 =item localize_dir_path
483 Convert the directory path to the local syntax
487 sub localize_dir_path {
488 my ($self, $path) = @_;
489 return VMS::Filespec::vmspath($path);
494 The home-grown glob() expands a bit too aggressively when given a bare name,
495 so default in a zero-length extension.
501 foreach my $item (map glob(VMS::Filespec::rmsexpand($_, '.;0')), $self->cleanup) {
502 $self->delete_filetree($item);
507 # Need to look up the feature settings. The preferred way is to use the
508 # VMS::Feature module, but that may not be available to dual life modules.
512 if (eval { local $SIG{__DIE__}; require VMS::Feature; }) {
517 # Need to look up the UNIX report mode. This may become a dynamic mode
522 $unix_rpt = VMS::Feature::current("filename_unix_report");
524 my $env_unix_rpt = $ENV{'DECC$FILENAME_UNIX_REPORT'} || '';
525 $unix_rpt = $env_unix_rpt =~ /^[ET1]/i;
530 # Need to look up the EFS character set mode. This may become a dynamic
531 # mode in the future.
535 $efs = VMS::Feature::current("efs_charset");
537 my $env_efs = $ENV{'DECC$EFS_CHARSET'} || '';
538 $efs = $env_efs =~ /^[ET1]/i;
547 Michael G Schwern <schwern@pobox.com>
548 Ken Williams <kwilliams@cpan.org>
549 Craig A. Berry <craigberry@mac.com>
553 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)