[ Index ] |
PHP Cross Reference of Unnamed Project |
[Summary view] [Print] [Text view]
1 package Module::Build::Platform::VMS; 2 3 use strict; 4 use vars qw($VERSION); 5 $VERSION = '0.2808_01'; 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 map { $_ = q(").$_.q(") if !/^\"/ && length($_) > 0 } 140 ($got_arrayref ? @{$args[0]} 141 : @args 142 ); 143 144 return $got_arrayref ? $args[0] 145 : join(' ', @args); 146 } 147 148 =item have_forkpipe 149 150 There is no native fork(), so some constructs depending on it are not 151 available. 152 153 =cut 154 155 sub have_forkpipe { 0 } 156 157 =item _backticks 158 159 Override to ensure that we quote the arguments but not the command. 160 161 =cut 162 163 sub _backticks { 164 # The command must not be quoted but the arguments to it must be. 165 my ($self, @cmd) = @_; 166 my $cmd = shift @cmd; 167 my $args = $self->_quote_args(@cmd); 168 return `$cmd $args`; 169 } 170 171 =item do_system 172 173 Override to ensure that we quote the arguments but not the command. 174 175 =cut 176 177 sub do_system { 178 # The command must not be quoted but the arguments to it must be. 179 my ($self, @cmd) = @_; 180 $self->log_info("@cmd\n"); 181 my $cmd = shift @cmd; 182 my $args = $self->_quote_args(@cmd); 183 return !system("$cmd $args"); 184 } 185 186 =item _infer_xs_spec 187 188 Inherit the standard version but tweak the library file name to be 189 something Dynaloader can find. 190 191 =cut 192 193 sub _infer_xs_spec { 194 my $self = shift; 195 my $file = shift; 196 197 my $spec = $self->SUPER::_infer_xs_spec($file); 198 199 # Need to create with the same name as DynaLoader will load with. 200 if (defined &DynaLoader::mod2fname) { 201 my $file = $$spec{module_name} . '.' . $self->{config}->get('dlext'); 202 $file =~ tr/:/_/; 203 $file = DynaLoader::mod2fname([$file]); 204 $$spec{lib_file} = File::Spec->catfile($$spec{archdir}, $file); 205 } 206 207 return $spec; 208 } 209 210 =item rscan_dir 211 212 Inherit the standard version but remove dots at end of name. This may not be 213 necessary if File::Find has been fixed or DECC$FILENAME_UNIX_REPORT is in effect. 214 215 =cut 216 217 sub rscan_dir { 218 my ($self, $dir, $pattern) = @_; 219 220 my $result = $self->SUPER::rscan_dir( $dir, $pattern ); 221 222 for my $file (@$result) { $file =~ s/\.$//; } 223 return $result; 224 } 225 226 =item dist_dir 227 228 Inherit the standard version but replace embedded dots with underscores because 229 a dot is the directory delimiter on VMS. 230 231 =cut 232 233 sub dist_dir { 234 my $self = shift; 235 236 my $dist_dir = $self->SUPER::dist_dir; 237 $dist_dir =~ s/\./_/g; 238 return $dist_dir; 239 } 240 241 =item man3page_name 242 243 Inherit the standard version but chop the extra manpage delimiter off the front if 244 there is one. The VMS version of splitdir('[.foo]') returns '', 'foo'. 245 246 =cut 247 248 sub man3page_name { 249 my $self = shift; 250 251 my $mpname = $self->SUPER::man3page_name( shift ); 252 my $sep = $self->manpage_separator; 253 $mpname =~ s/^$sep//; 254 return $mpname; 255 } 256 257 =item expand_test_dir 258 259 Inherit the standard version but relativize the paths as the native glob() doesn't 260 do that for us. 261 262 =cut 263 264 sub expand_test_dir { 265 my ($self, $dir) = @_; 266 267 my @reldirs = $self->SUPER::expand_test_dir( $dir ); 268 269 for my $eachdir (@reldirs) { 270 my ($v,$d,$f) = File::Spec->splitpath( $eachdir ); 271 my $reldir = File::Spec->abs2rel( File::Spec->catpath( $v, $d, '' ) ); 272 $eachdir = File::Spec->catfile( $reldir, $f ); 273 } 274 return @reldirs; 275 } 276 277 =item _detildefy 278 279 The home-grown glob() does not currently handle tildes, so provide limited support 280 here. Expect only UNIX format file specifications for now. 281 282 =cut 283 284 sub _detildefy { 285 my ($self, $arg) = @_; 286 287 # Apparently double ~ are not translated. 288 return $arg if ($arg =~ /^~~/); 289 290 # Apparently ~ followed by whitespace are not translated. 291 return $arg if ($arg =~ /^~ /); 292 293 if ($arg =~ /^~/) { 294 my $spec = $arg; 295 296 # Remove the tilde 297 $spec =~ s/^~//; 298 299 # Remove any slash folloing the tilde if present. 300 $spec =~ s#^/##; 301 302 # break up the paths for the merge 303 my $home = VMS::Filespec::unixify($ENV{HOME}); 304 305 # Trivial case of just ~ by it self 306 if ($spec eq '') { 307 return $home; 308 } 309 310 my ($hvol, $hdir, $hfile) = File::Spec::Unix->splitpath($home); 311 if ($hdir eq '') { 312 # Someone has tampered with $ENV{HOME} 313 # So hfile is probably the directory since this should be 314 # a path. 315 $hdir = $hfile; 316 } 317 318 my ($vol, $dir, $file) = File::Spec::Unix->splitpath($spec); 319 320 my @hdirs = File::Spec::Unix->splitdir($hdir); 321 my @dirs = File::Spec::Unix->splitdir($dir); 322 323 my $newdirs; 324 325 # Two cases of tilde handling 326 if ($arg =~ m#^~/#) { 327 328 # Simple case, just merge together 329 $newdirs = File::Spec::Unix->catdir(@hdirs, @dirs); 330 331 } else { 332 333 # Complex case, need to add an updir - No delimiters 334 my @backup = File::Spec::Unix->splitdir(File::Spec::Unix->updir); 335 336 $newdirs = File::Spec::Unix->catdir(@hdirs, @backup, @dirs); 337 338 } 339 340 # Now put the two cases back together 341 $arg = File::Spec::Unix->catpath($hvol, $newdirs, $file); 342 343 } else { 344 return $arg; 345 } 346 347 } 348 349 =item find_perl_interpreter 350 351 On VMS, $^X returns the fully qualified absolute path including version 352 number. It's logically impossible to improve on it for getting the perl 353 we're currently running, and attempting to manipulate it is usually 354 lossy. 355 356 =cut 357 358 sub find_perl_interpreter { return $^X; } 359 360 =back 361 362 =head1 AUTHOR 363 364 Michael G Schwern <schwern@pobox.com> 365 Ken Williams <kwilliams@cpan.org> 366 Craig A. Berry <craigberry@mac.com> 367 368 =head1 SEE ALSO 369 370 perl(1), Module::Build(3), ExtUtils::MakeMaker(3) 371 372 =cut 373 374 1; 375 __END__
title
Description
Body
title
Description
Body
title
Description
Body
title
Body
Generated: Tue Mar 17 22:47:18 2015 | Cross-referenced by PHPXref 0.7.1 |