This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Try a bit harder to get *PL_sighandlerp to agree with its
[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 =back
347
348 =head1 AUTHOR
349
350 Michael G Schwern <schwern@pobox.com>
351 Ken Williams <kwilliams@cpan.org>
352 Craig A. Berry <craigberry@mac.com>
353
354 =head1 SEE ALSO
355
356 perl(1), Module::Build(3), ExtUtils::MakeMaker(3)
357
358 =cut
359
360 1;
361 __END__