1 | # ------------------------------------------------------------------------------ |
---|
2 | # NAME |
---|
3 | # Fcm::Dest |
---|
4 | # |
---|
5 | # DESCRIPTION |
---|
6 | # This class contains methods to set up a destination location of an FCM |
---|
7 | # extract/build. |
---|
8 | # |
---|
9 | # COPYRIGHT |
---|
10 | # (C) Crown copyright Met Office. All rights reserved. |
---|
11 | # For further details please refer to the file COPYRIGHT.txt |
---|
12 | # which you should have received as part of this distribution. |
---|
13 | # ------------------------------------------------------------------------------ |
---|
14 | use warnings; |
---|
15 | use strict; |
---|
16 | |
---|
17 | package Fcm::Dest; |
---|
18 | use base qw{Fcm::Base}; |
---|
19 | |
---|
20 | use Carp qw{croak} ; |
---|
21 | use Cwd qw{cwd} ; |
---|
22 | use Fcm::CfgLine ; |
---|
23 | use Fcm::Timer qw{timestamp_command} ; |
---|
24 | use Fcm::Util qw{run_command touch_file w_report}; |
---|
25 | use File::Basename qw{basename dirname} ; |
---|
26 | use File::Find qw{find} ; |
---|
27 | use File::Path qw{mkpath rmtree} ; |
---|
28 | use File::Spec ; |
---|
29 | use Sys::Hostname qw{hostname} ; |
---|
30 | use Text::ParseWords qw{shellwords} ; |
---|
31 | |
---|
32 | # Useful variables |
---|
33 | # ------------------------------------------------------------------------------ |
---|
34 | # List of configuration files |
---|
35 | our @cfgfiles = ( |
---|
36 | 'bldcfg', # default location of the build configuration file |
---|
37 | 'extcfg', # default location of the extract configuration file |
---|
38 | ); |
---|
39 | |
---|
40 | # List of cache and configuration files, according to the dest type |
---|
41 | our @cfgfiles_type = ( |
---|
42 | 'cache', # default location of the cache file |
---|
43 | 'cfg', # default location of the configuration file |
---|
44 | 'parsedcfg', # default location of the as-parsed configuration file |
---|
45 | ); |
---|
46 | |
---|
47 | # List of lock files |
---|
48 | our @lockfiles = ( |
---|
49 | 'bldlock', # the build lock file |
---|
50 | 'extlock', # the extract lock file |
---|
51 | ); |
---|
52 | |
---|
53 | # List of misc files |
---|
54 | our @miscfiles_bld = ( |
---|
55 | 'bldrunenvsh', # the build run environment shell script |
---|
56 | 'bldmakefile', # the build Makefile |
---|
57 | ); |
---|
58 | |
---|
59 | # List of sub-directories created by extract |
---|
60 | our @subdirs_ext = ( |
---|
61 | 'cfgdir', # sub-directory for configuration files |
---|
62 | 'srcdir', # sub-directory for source tree |
---|
63 | ); |
---|
64 | |
---|
65 | # List of sub-directories that can be archived by "tar" at end of build |
---|
66 | our @subdirs_tar = ( |
---|
67 | 'donedir', # sub-directory for "done" files |
---|
68 | 'flagsdir', # sub-directory for "flags" files |
---|
69 | 'incdir', # sub-directory for include files |
---|
70 | 'ppsrcdir', # sub-directory for pre-process source tree |
---|
71 | 'objdir', # sub-directory for object files |
---|
72 | ); |
---|
73 | |
---|
74 | # List of sub-directories created by build |
---|
75 | our @subdirs_bld = ( |
---|
76 | 'bindir', # sub-directory for executables |
---|
77 | 'etcdir', # sub-directory for miscellaneous files |
---|
78 | 'libdir', # sub-directory for object libraries |
---|
79 | 'tmpdir', # sub-directory for temporary build files |
---|
80 | @subdirs_tar, # -see above- |
---|
81 | ); |
---|
82 | |
---|
83 | # List of sub-directories under rootdir |
---|
84 | our @subdirs = ( |
---|
85 | 'cachedir', # sub-directory for caches |
---|
86 | @subdirs_ext, # -see above- |
---|
87 | @subdirs_bld, # -see above- |
---|
88 | ); |
---|
89 | |
---|
90 | # List of inherited search paths |
---|
91 | # "rootdir" + all @subdirs, with "XXXdir" replaced with "XXXpath" |
---|
92 | our @paths = ( |
---|
93 | 'rootpath', |
---|
94 | (map {my $key = $_; $key =~ s{dir\z}{path}msx; $key} @subdirs), |
---|
95 | ); |
---|
96 | |
---|
97 | # List of properties and their default values. |
---|
98 | my %PROP_OF = ( |
---|
99 | # the original destination (if current destination is a mirror) |
---|
100 | 'dest0' => undef, |
---|
101 | # list of inherited Fcm::Dest objects |
---|
102 | 'inherit' => [], |
---|
103 | # remote login name |
---|
104 | 'logname' => scalar(getpwuid($<)), |
---|
105 | # lock file |
---|
106 | 'lockfile' => undef, |
---|
107 | # remote machine |
---|
108 | 'machine' => hostname(), |
---|
109 | # mirror command to use |
---|
110 | 'mirror_cmd' => 'rsync', |
---|
111 | # (for rsync) remote mkdir, the remote shell command |
---|
112 | 'rsh_mkdir_rsh' => 'ssh', |
---|
113 | # (for rsync) remote mkdir, the remote shell command flags |
---|
114 | 'rsh_mkdir_rshflags' => '-n -oBatchMode=yes', |
---|
115 | # (for rsync) remote mkdir, the remote shell command |
---|
116 | 'rsh_mkdir_mkdir' => 'mkdir', |
---|
117 | # (for rsync) remote mkdir, the remote shell command flags |
---|
118 | 'rsh_mkdir_mkdirflags' => '-p', |
---|
119 | # (for rsync) remote mkdir, the remote shell command |
---|
120 | 'rsync' => 'rsync', |
---|
121 | # (for rsync) remote mkdir, the remote shell command flags |
---|
122 | 'rsyncflags' => q{-a --exclude='.*' --delete-excluded} |
---|
123 | . q{ --timeout=900 --rsh='ssh -oBatchMode=yes'}, |
---|
124 | # destination root directory |
---|
125 | 'rootdir' => undef, |
---|
126 | # destination type, "bld" (default) or "ext" |
---|
127 | 'type' => 'bld', |
---|
128 | ); |
---|
129 | # Hook for property setter |
---|
130 | my %PROP_HOOK_OF = ( |
---|
131 | 'inherit' => \&_reset_inherit, |
---|
132 | 'rootdir' => \&_reset_rootdir, |
---|
133 | ); |
---|
134 | |
---|
135 | # Mirror implementations |
---|
136 | my %MIRROR_IMPL_OF = ( |
---|
137 | rdist => \&_mirror_with_rdist, |
---|
138 | rsync => \&_mirror_with_rsync, |
---|
139 | ); |
---|
140 | |
---|
141 | # ------------------------------------------------------------------------------ |
---|
142 | # SYNOPSIS |
---|
143 | # $obj = Fcm::Dest->new(%args); |
---|
144 | # |
---|
145 | # DESCRIPTION |
---|
146 | # This method constructs a new instance of the Fcm::Dest class. See above for |
---|
147 | # allowed list of properties. (KEYS should be in uppercase.) |
---|
148 | # ------------------------------------------------------------------------------ |
---|
149 | |
---|
150 | sub new { |
---|
151 | my ($class, %args) = @_; |
---|
152 | my $self = bless(Fcm::Base->new(%args), $class); |
---|
153 | while (my ($key, $value) = each(%args)) { |
---|
154 | $key = lc($key); |
---|
155 | if (exists($PROP_OF{$key})) { |
---|
156 | $self->{$key} = $value; |
---|
157 | } |
---|
158 | } |
---|
159 | for my $key (@subdirs, @paths, @lockfiles, @cfgfiles) { |
---|
160 | $self->{$key} = undef; |
---|
161 | } |
---|
162 | return $self; |
---|
163 | } |
---|
164 | |
---|
165 | # ------------------------------------------------------------------------------ |
---|
166 | # SYNOPSIS |
---|
167 | # $self->DESTROY; |
---|
168 | # |
---|
169 | # DESCRIPTION |
---|
170 | # This method is called automatically when the Fcm::Dest object is |
---|
171 | # destroyed. |
---|
172 | # ------------------------------------------------------------------------------ |
---|
173 | |
---|
174 | sub DESTROY { |
---|
175 | my $self = shift; |
---|
176 | |
---|
177 | # Remove the lockfile if it is set |
---|
178 | unlink $self->lockfile if $self->lockfile and -w $self->lockfile; |
---|
179 | |
---|
180 | return; |
---|
181 | } |
---|
182 | |
---|
183 | # ------------------------------------------------------------------------------ |
---|
184 | # SYNOPSIS |
---|
185 | # $value = $obj->X($value); |
---|
186 | # |
---|
187 | # DESCRIPTION |
---|
188 | # Details of these properties are explained in %PROP_OF. |
---|
189 | # ------------------------------------------------------------------------------ |
---|
190 | |
---|
191 | while (my ($key, $default) = each(%PROP_OF)) { |
---|
192 | no strict 'refs'; |
---|
193 | *{$key} = sub { |
---|
194 | my $self = shift(); |
---|
195 | # Set property to specified value |
---|
196 | if (@_) { |
---|
197 | $self->{$key} = $_[0]; |
---|
198 | if (exists($PROP_HOOK_OF{$key})) { |
---|
199 | $PROP_HOOK_OF{$key}->($self, $key); |
---|
200 | } |
---|
201 | } |
---|
202 | # Sets default where possible |
---|
203 | if (!defined($self->{$key})) { |
---|
204 | $self->{$key} = $default; |
---|
205 | } |
---|
206 | return $self->{$key}; |
---|
207 | }; |
---|
208 | } |
---|
209 | |
---|
210 | # Remote shell property: deprecated. |
---|
211 | sub remote_shell { |
---|
212 | my $self = shift(); |
---|
213 | $self->rsh_mkdir_rsh(@_); |
---|
214 | } |
---|
215 | |
---|
216 | # Resets properties associated with root directory. |
---|
217 | sub _reset_rootdir { |
---|
218 | my $self = shift(); |
---|
219 | for my $key (@cfgfiles, @lockfiles, @miscfiles_bld, @subdirs) { |
---|
220 | $self->{$key} = undef; |
---|
221 | } |
---|
222 | } |
---|
223 | |
---|
224 | # Reset properties associated with inherited paths. |
---|
225 | sub _reset_inherit { |
---|
226 | my $self = shift(); |
---|
227 | for my $key (@paths) { |
---|
228 | $self->{$key} = undef; |
---|
229 | } |
---|
230 | } |
---|
231 | |
---|
232 | # ------------------------------------------------------------------------------ |
---|
233 | # SYNOPSIS |
---|
234 | # $value = $obj->X; |
---|
235 | # |
---|
236 | # DESCRIPTION |
---|
237 | # This method returns X, where X is a location derived from rootdir, and can |
---|
238 | # be one of: |
---|
239 | # bindir, bldcfg, blddir, bldlock, bldrunenv, cache, cachedir, cfg, cfgdir, |
---|
240 | # donedir, etcdir, extcfg, extlock, flagsdir, incdir, libdir, parsedcfg, |
---|
241 | # ppsrcdir, objdir, or tmpdir. |
---|
242 | # |
---|
243 | # Details of these properties are explained earlier. |
---|
244 | # ------------------------------------------------------------------------------ |
---|
245 | |
---|
246 | for my $name (@cfgfiles, @cfgfiles_type, @lockfiles, @miscfiles_bld, @subdirs) { |
---|
247 | no strict 'refs'; |
---|
248 | |
---|
249 | *$name = sub { |
---|
250 | my $self = shift; |
---|
251 | |
---|
252 | # If variable not set, derive it from rootdir |
---|
253 | if ($self->rootdir and not defined $self->{$name}) { |
---|
254 | if ($name eq 'cache') { |
---|
255 | # Cache file under root/.cache |
---|
256 | $self->{$name} = File::Spec->catfile ( |
---|
257 | $self->cachedir, $self->setting ('CACHE'), |
---|
258 | ); |
---|
259 | |
---|
260 | } elsif ($name eq 'cfg') { |
---|
261 | # Configuration file of current type |
---|
262 | my $method = $self->type . 'cfg'; |
---|
263 | $self->{$name} = $self->$method; |
---|
264 | |
---|
265 | } elsif (grep {$name eq $_} @cfgfiles) { |
---|
266 | # Configuration files under the root/cfg |
---|
267 | (my $label = uc ($name)) =~ s/CFG//; |
---|
268 | $self->{$name} = File::Spec->catfile ( |
---|
269 | $self->cfgdir, $self->setting ('CFG_NAME', $label), |
---|
270 | ); |
---|
271 | |
---|
272 | } elsif (grep {$name eq $_} @lockfiles) { |
---|
273 | # Lock file |
---|
274 | $self->{$name} = File::Spec->catfile ( |
---|
275 | $self->rootdir, $self->setting ('LOCK', uc ($name)), |
---|
276 | ); |
---|
277 | |
---|
278 | } elsif (grep {$name eq $_} @miscfiles_bld) { |
---|
279 | # Misc file |
---|
280 | $self->{$name} = File::Spec->catfile ( |
---|
281 | $self->rootdir, $self->setting ('BLD_MISC', uc ($name)), |
---|
282 | ); |
---|
283 | |
---|
284 | } elsif ($name eq 'parsedcfg') { |
---|
285 | # As-parsed configuration file of current type |
---|
286 | $self->{$name} = File::Spec->catfile ( |
---|
287 | dirname ($self->cfg), |
---|
288 | $self->setting (qw/CFG_NAME PARSED/) . basename ($self->cfg), |
---|
289 | ) |
---|
290 | |
---|
291 | } elsif (grep {$name eq $_} @subdirs) { |
---|
292 | # Sub-directories under the root |
---|
293 | (my $label = uc ($name)) =~ s/DIR//; |
---|
294 | $self->{$name} = File::Spec->catfile ( |
---|
295 | $self->rootdir, |
---|
296 | $self->setting ('DIR', $label), |
---|
297 | ($name eq 'cachedir' ? '.' . $self->type : ()), |
---|
298 | ); |
---|
299 | } |
---|
300 | } |
---|
301 | |
---|
302 | return $self->{$name}; |
---|
303 | } |
---|
304 | } |
---|
305 | |
---|
306 | # ------------------------------------------------------------------------------ |
---|
307 | # SYNOPSIS |
---|
308 | # $value = $obj->X; |
---|
309 | # |
---|
310 | # DESCRIPTION |
---|
311 | # This method returns X, an array containing the search path of a destination |
---|
312 | # directory, which can be one of: |
---|
313 | # binpath, bldpath, cachepath, cfgpath, donepath, etcpath, flagspath, |
---|
314 | # incpath, libpath, ppsrcpath, objpath, rootpath, srcpath, or tmppath, |
---|
315 | # |
---|
316 | # Details of these properties are explained earlier. |
---|
317 | # ------------------------------------------------------------------------------ |
---|
318 | |
---|
319 | for my $name (@paths) { |
---|
320 | no strict 'refs'; |
---|
321 | |
---|
322 | *$name = sub { |
---|
323 | my $self = shift; |
---|
324 | |
---|
325 | (my $dir = $name) =~ s/path/dir/; |
---|
326 | |
---|
327 | if ($self->$dir and not defined $self->{$name}) { |
---|
328 | my @path = (); |
---|
329 | |
---|
330 | # Recursively inherit the search path |
---|
331 | for my $d (@{ $self->inherit }) { |
---|
332 | unshift @path, $d->$dir; |
---|
333 | } |
---|
334 | |
---|
335 | # Place the path of the current build in the front |
---|
336 | unshift @path, $self->$dir; |
---|
337 | |
---|
338 | $self->{$name} = \@path; |
---|
339 | } |
---|
340 | |
---|
341 | return $self->{$name}; |
---|
342 | } |
---|
343 | } |
---|
344 | |
---|
345 | # ------------------------------------------------------------------------------ |
---|
346 | # SYNOPSIS |
---|
347 | # $rc = $obj->archive (); |
---|
348 | # |
---|
349 | # DESCRIPTION |
---|
350 | # This method creates TAR archives for selected sub-directories. |
---|
351 | # ------------------------------------------------------------------------------ |
---|
352 | |
---|
353 | sub archive { |
---|
354 | my $self = shift; |
---|
355 | |
---|
356 | # Save current directory |
---|
357 | my $cwd = cwd (); |
---|
358 | |
---|
359 | my $tar = $self->setting (qw/OUTFILE_EXT TAR/); |
---|
360 | my $verbose = $self->verbose; |
---|
361 | |
---|
362 | for my $name (@subdirs_tar) { |
---|
363 | my $dir = $self->$name; |
---|
364 | |
---|
365 | # Ignore unless sub-directory exists |
---|
366 | next unless -d $dir; |
---|
367 | |
---|
368 | # Change to container directory |
---|
369 | my $base = basename ($dir); |
---|
370 | print 'cd ', dirname ($dir), "\n" if $verbose > 2; |
---|
371 | chdir dirname ($dir); |
---|
372 | |
---|
373 | # Run "tar" command |
---|
374 | my $rc = &run_command ( |
---|
375 | [qw/tar -czf/, $base . $tar, $base], |
---|
376 | PRINT => $verbose > 1, ERROR => 'warn', |
---|
377 | ); |
---|
378 | |
---|
379 | # Remove sub-directory |
---|
380 | &run_command ([qw/rm -rf/, $base], PRINT => $verbose > 1) if not $rc; |
---|
381 | } |
---|
382 | |
---|
383 | # Change back to "current" directory |
---|
384 | print 'cd ', $cwd, "\n" if $verbose > 2; |
---|
385 | chdir $cwd; |
---|
386 | |
---|
387 | return 1; |
---|
388 | } |
---|
389 | |
---|
390 | # ------------------------------------------------------------------------------ |
---|
391 | # SYNOPSIS |
---|
392 | # $authority = $obj->authority(); |
---|
393 | # |
---|
394 | # DESCRIPTION |
---|
395 | # Returns LOGNAME@MACHINE for this destination if LOGNAME is defined and not |
---|
396 | # the same as the user ID of the current process. Returns MACHINE if LOGNAME |
---|
397 | # is the same as the user ID of the current process, but MACHINE is not the |
---|
398 | # same as the current hostname. Returns an empty string if LOGNAME and |
---|
399 | # MACHINE are not defined or are the same as in the current process. |
---|
400 | # ------------------------------------------------------------------------------ |
---|
401 | |
---|
402 | sub authority { |
---|
403 | my $self = shift; |
---|
404 | my $return = ''; |
---|
405 | |
---|
406 | if ($self->logname ne $self->config->user_id) { |
---|
407 | $return = $self->logname . '@' . $self->machine; |
---|
408 | |
---|
409 | } elsif ($self->machine ne &hostname()) { |
---|
410 | $return = $self->machine; |
---|
411 | } |
---|
412 | |
---|
413 | return $return; |
---|
414 | } |
---|
415 | |
---|
416 | # ------------------------------------------------------------------------------ |
---|
417 | # SYNOPSIS |
---|
418 | # $rc = $obj->clean([ITEM => <list>,] [MODE => 'ALL|CONTENT|EMPTY',]); |
---|
419 | # |
---|
420 | # DESCRIPTION |
---|
421 | # This method removes files/directories from the destination. If ITEM is set, |
---|
422 | # it must be a reference to a list of method names for files/directories to |
---|
423 | # be removed. Otherwise, the list is determined by the destination type. If |
---|
424 | # MODE is ALL, all directories/files created by the extract/build are |
---|
425 | # removed. If MODE is CONTENT, only contents within sub-directories are |
---|
426 | # removed. If MODE is EMPTY (default), only empty sub-directories are |
---|
427 | # removed. |
---|
428 | # ------------------------------------------------------------------------------ |
---|
429 | |
---|
430 | sub clean { |
---|
431 | my ($self, %args) = @_; |
---|
432 | my $mode = exists $args{MODE} ? $args{MODE} : 'EMPTY'; |
---|
433 | my $rc = 1; |
---|
434 | my @names |
---|
435 | = $args{ITEM} ? @{$args{ITEM}} |
---|
436 | : $self->type() eq 'ext' ? ('cachedir', @subdirs_ext) |
---|
437 | : ('cachedir', @subdirs_bld, @miscfiles_bld) |
---|
438 | ; |
---|
439 | my @items; |
---|
440 | if ($mode eq 'CONTENT') { |
---|
441 | for my $name (@names) { |
---|
442 | my $item = $self->$name(); |
---|
443 | push(@items, _directory_contents($item)); |
---|
444 | } |
---|
445 | } |
---|
446 | else { |
---|
447 | for my $name (@names) { |
---|
448 | my $item = $self->$name(); |
---|
449 | if ($mode eq 'ALL' || -d $item && !_directory_contents($item)) { |
---|
450 | push(@items, $item); |
---|
451 | } |
---|
452 | } |
---|
453 | } |
---|
454 | for my $item (@items) { |
---|
455 | if ($self->verbose() >= 2) { |
---|
456 | printf("%s: remove\n", $item); |
---|
457 | } |
---|
458 | eval {rmtree($item)}; |
---|
459 | if ($@) { |
---|
460 | w_report($@); |
---|
461 | $rc = 0; |
---|
462 | } |
---|
463 | } |
---|
464 | return $rc; |
---|
465 | } |
---|
466 | |
---|
467 | # ------------------------------------------------------------------------------ |
---|
468 | # SYNOPSIS |
---|
469 | # $rc = $obj->create ([DIR => <dir-list>,]); |
---|
470 | # |
---|
471 | # DESCRIPTION |
---|
472 | # This method creates the directories of a destination. If DIR is set, it |
---|
473 | # must be a reference to a list of sub-directories to be created. Otherwise, |
---|
474 | # the sub-directory list is determined by the destination type. It returns |
---|
475 | # true if the destination is created or if it exists and is writable. |
---|
476 | # ------------------------------------------------------------------------------ |
---|
477 | |
---|
478 | sub create { |
---|
479 | my ($self, %args) = @_; |
---|
480 | |
---|
481 | my $rc = 1; |
---|
482 | |
---|
483 | my @dirs; |
---|
484 | if (exists $args{DIR} and $args{DIR}) { |
---|
485 | # Create only selected sub-directories |
---|
486 | @dirs = @{ $args{DIR} }; |
---|
487 | |
---|
488 | } else { |
---|
489 | # Create rootdir, cachedir and read-write sub-directories for extract/build |
---|
490 | @dirs = ( |
---|
491 | qw/rootdir cachedir/, |
---|
492 | ($self->type eq 'ext' ? @subdirs_ext : @subdirs_bld), |
---|
493 | ); |
---|
494 | } |
---|
495 | |
---|
496 | for my $name (@dirs) { |
---|
497 | my $dir = $self->$name; |
---|
498 | |
---|
499 | # Create directory if it does not already exist |
---|
500 | if (not -d $dir) { |
---|
501 | print 'Make directory: ', $dir, "\n" if $self->verbose > 1; |
---|
502 | mkpath $dir; |
---|
503 | } |
---|
504 | |
---|
505 | # Check whether directory exists and is writable |
---|
506 | unless (-d $dir and -w $dir) { |
---|
507 | w_report 'ERROR: ', $dir, ': cannot write to destination.'; |
---|
508 | $rc = 0; |
---|
509 | } |
---|
510 | } |
---|
511 | |
---|
512 | return $rc; |
---|
513 | } |
---|
514 | |
---|
515 | # ------------------------------------------------------------------------------ |
---|
516 | # SYNOPSIS |
---|
517 | # $rc = $obj->create_bldrunenvsh (); |
---|
518 | # |
---|
519 | # DESCRIPTION |
---|
520 | # This method creates the runtime environment script for the build. |
---|
521 | # ------------------------------------------------------------------------------ |
---|
522 | |
---|
523 | sub create_bldrunenvsh { |
---|
524 | my $self = shift; |
---|
525 | |
---|
526 | # Path to executable files and directory for misc files |
---|
527 | my @bin_paths = grep {_directory_contents($_)} @{$self->binpath()}; |
---|
528 | my $bin_dir = -d $self->bindir() ? $self->bindir() : undef; |
---|
529 | my $etc_dir = _directory_contents($self->etcdir()) ? $self->etcdir() : undef; |
---|
530 | |
---|
531 | # Create a runtime environment script if necessary |
---|
532 | if (@bin_paths || $etc_dir) { |
---|
533 | my $path = $self->bldrunenvsh(); |
---|
534 | open(my $handle, '>', $path) || croak("$path: cannot open ($!)\n"); |
---|
535 | printf($handle "#!%s\n", $self->setting(qw/TOOL SHELL/)); |
---|
536 | if (@bin_paths) { |
---|
537 | printf($handle "PATH=%s:\$PATH\n", join(':', @bin_paths)); |
---|
538 | print($handle "export PATH\n"); |
---|
539 | } |
---|
540 | if ($etc_dir) { |
---|
541 | printf($handle "FCM_ETCDIR=%s\n", $etc_dir); |
---|
542 | print($handle "export FCM_ETCDIR\n"); |
---|
543 | } |
---|
544 | close($handle) || croak("$path: cannot close ($!)\n"); |
---|
545 | |
---|
546 | # Create symbolic links fcm_env.ksh and bin/fcm_env.ksh for backward |
---|
547 | # compatibility |
---|
548 | my $FCM_ENV_KSH = 'fcm_env.ksh'; |
---|
549 | for my $link ( |
---|
550 | File::Spec->catfile($self->rootdir, $FCM_ENV_KSH), |
---|
551 | ($bin_dir ? File::Spec->catfile($bin_dir, $FCM_ENV_KSH) : ()), |
---|
552 | ) { |
---|
553 | if (-l $link && readlink($link) ne $path || -e $link) { |
---|
554 | unlink($link); |
---|
555 | } |
---|
556 | if (!-l $link) { |
---|
557 | symlink($path, $link) || croak("$link: cannot create symbolic link\n"); |
---|
558 | } |
---|
559 | } |
---|
560 | } |
---|
561 | return 1; |
---|
562 | } |
---|
563 | |
---|
564 | # ------------------------------------------------------------------------------ |
---|
565 | # SYNOPSIS |
---|
566 | # $rc = $obj->dearchive (); |
---|
567 | # |
---|
568 | # DESCRIPTION |
---|
569 | # This method extracts from TAR archives for selected sub-directories. |
---|
570 | # ------------------------------------------------------------------------------ |
---|
571 | |
---|
572 | sub dearchive { |
---|
573 | my $self = shift; |
---|
574 | |
---|
575 | my $tar = $self->setting (qw/OUTFILE_EXT TAR/); |
---|
576 | my $verbose = $self->verbose; |
---|
577 | |
---|
578 | # Extract archives if necessary |
---|
579 | for my $name (@subdirs_tar) { |
---|
580 | my $tar_file = $self->$name . $tar; |
---|
581 | |
---|
582 | # Check whether tar archive exists for the named sub-directory |
---|
583 | next unless -f $tar_file; |
---|
584 | |
---|
585 | # If so, extract the archive and remove it afterwards |
---|
586 | &run_command ([qw/tar -xzf/, $tar_file], PRINT => $verbose > 1); |
---|
587 | &run_command ([qw/rm -f/, $tar_file], PRINT => $verbose > 1); |
---|
588 | } |
---|
589 | |
---|
590 | return 1; |
---|
591 | } |
---|
592 | |
---|
593 | # ------------------------------------------------------------------------------ |
---|
594 | # SYNOPSIS |
---|
595 | # $name = $obj->get_pkgname_of_path ($path); |
---|
596 | # |
---|
597 | # DESCRIPTION |
---|
598 | # This method returns the package name of $path if $path is in (a relative |
---|
599 | # path of) $self->srcdir, or undef otherwise. |
---|
600 | # ------------------------------------------------------------------------------ |
---|
601 | |
---|
602 | sub get_pkgname_of_path { |
---|
603 | my ($self, $path) = @_; |
---|
604 | |
---|
605 | my $relpath = File::Spec->abs2rel ($path, $self->srcdir); |
---|
606 | my $name = $relpath ? [File::Spec->splitdir ($relpath)] : undef; |
---|
607 | |
---|
608 | return $name; |
---|
609 | } |
---|
610 | |
---|
611 | # ------------------------------------------------------------------------------ |
---|
612 | # SYNOPSIS |
---|
613 | # %src = $obj->get_source_files (); |
---|
614 | # |
---|
615 | # DESCRIPTION |
---|
616 | # This method returns a hash (keys = package names, values = file names) |
---|
617 | # under $self->srcdir. |
---|
618 | # ------------------------------------------------------------------------------ |
---|
619 | |
---|
620 | sub get_source_files { |
---|
621 | my $self = shift; |
---|
622 | |
---|
623 | my %src; |
---|
624 | if ($self->srcdir and -d $self->srcdir) { |
---|
625 | &find (sub { |
---|
626 | return if /^\./; # ignore system/hidden file |
---|
627 | return if -d $File::Find::name; # ignore directory |
---|
628 | return if not -r $File::Find::name; # ignore unreadable files |
---|
629 | |
---|
630 | my $name = join ( |
---|
631 | '__', @{ $self->get_pkgname_of_path ($File::Find::name) }, |
---|
632 | ); |
---|
633 | $src{$name} = $File::Find::name; |
---|
634 | }, $self->srcdir); |
---|
635 | } |
---|
636 | |
---|
637 | return \%src; |
---|
638 | } |
---|
639 | |
---|
640 | # ------------------------------------------------------------------------------ |
---|
641 | # SYNOPSIS |
---|
642 | # $rc = $obj->mirror (\@items); |
---|
643 | # |
---|
644 | # DESCRIPTION |
---|
645 | # This method mirrors @items (list of method names for directories or files) |
---|
646 | # from $dest0 (which must be an instance of Fcm::Dest for a local |
---|
647 | # destination) to this destination. |
---|
648 | # ------------------------------------------------------------------------------ |
---|
649 | |
---|
650 | sub mirror { |
---|
651 | my ($self, $items_ref) = @_; |
---|
652 | if ($self->authority() || $self->dest0()->rootdir() ne $self->rootdir()) { |
---|
653 | # Diagnostic |
---|
654 | if ($self->verbose()) { |
---|
655 | printf( |
---|
656 | "Destination: %s\n", |
---|
657 | ($self->authority() ? $self->authority() . q{:} : q{}) . $self->rootdir() |
---|
658 | ); |
---|
659 | } |
---|
660 | if ($MIRROR_IMPL_OF{$self->mirror_cmd()}) { |
---|
661 | $MIRROR_IMPL_OF{$self->mirror_cmd()}->($self, $self->dest0(), $items_ref); |
---|
662 | } |
---|
663 | else { |
---|
664 | # Unknown mirroring tool |
---|
665 | w_report($self->mirror_cmd, ': unknown mirroring tool, abort.'); |
---|
666 | return 0; |
---|
667 | } |
---|
668 | } |
---|
669 | return 1; |
---|
670 | } |
---|
671 | |
---|
672 | # ------------------------------------------------------------------------------ |
---|
673 | # SYNOPSIS |
---|
674 | # $rc = $self->_mirror_with_rdist ($dest0, \@items); |
---|
675 | # |
---|
676 | # DESCRIPTION |
---|
677 | # This internal method implements $self->mirror with "rdist". |
---|
678 | # ------------------------------------------------------------------------------ |
---|
679 | |
---|
680 | sub _mirror_with_rdist { |
---|
681 | my ($self, $dest0, $items) = @_; |
---|
682 | |
---|
683 | my $rhost = $self->authority ? $self->authority : &hostname(); |
---|
684 | |
---|
685 | # Print distfile content to temporary file |
---|
686 | my @distfile = (); |
---|
687 | for my $label (@$items) { |
---|
688 | push @distfile, '( ' . $dest0->$label . ' ) -> ' . $rhost . "\n"; |
---|
689 | push @distfile, ' install ' . $self->$label . ';' . "\n"; |
---|
690 | } |
---|
691 | |
---|
692 | # Set up mirroring command (use "rdist" at the moment) |
---|
693 | my $command = 'rdist -R'; |
---|
694 | $command .= ' -q' unless $self->verbose > 1; |
---|
695 | $command .= ' -f - 1>/dev/null'; |
---|
696 | |
---|
697 | # Diagnostic |
---|
698 | my $croak = 'Cannot execute "' . $command . '"'; |
---|
699 | if ($self->verbose > 2) { |
---|
700 | print timestamp_command ($command, 'Start'); |
---|
701 | print ' ', $_ for (@distfile); |
---|
702 | } |
---|
703 | |
---|
704 | # Execute the mirroring command |
---|
705 | open COMMAND, '|-', $command or croak $croak, ' (', $!, '), abort'; |
---|
706 | for my $line (@distfile) { |
---|
707 | print COMMAND $line; |
---|
708 | } |
---|
709 | close COMMAND or croak $croak, ' (', $?, '), abort'; |
---|
710 | |
---|
711 | # Diagnostic |
---|
712 | print timestamp_command ($command, 'End ') if $self->verbose > 2; |
---|
713 | |
---|
714 | return 1; |
---|
715 | } |
---|
716 | |
---|
717 | # ------------------------------------------------------------------------------ |
---|
718 | # SYNOPSIS |
---|
719 | # $rc = $self->_mirror_with_rsync($dest0, \@items); |
---|
720 | # |
---|
721 | # DESCRIPTION |
---|
722 | # This internal method implements $self->mirror() with "rsync". |
---|
723 | # ------------------------------------------------------------------------------ |
---|
724 | |
---|
725 | sub _mirror_with_rsync { |
---|
726 | my ($self, $dest0, $items_ref) = @_; |
---|
727 | my @rsh_mkdir; |
---|
728 | if ($self->authority()) { |
---|
729 | @rsh_mkdir = ( |
---|
730 | $self->rsh_mkdir_rsh(), |
---|
731 | shellwords($self->rsh_mkdir_rshflags()), |
---|
732 | $self->authority(), |
---|
733 | $self->rsh_mkdir_mkdir(), |
---|
734 | shellwords($self->rsh_mkdir_mkdirflags()), |
---|
735 | ); |
---|
736 | } |
---|
737 | my @rsync = ($self->rsync(), shellwords($self->rsyncflags())); |
---|
738 | my @rsync_verbose = ($self->verbose() > 2 ? '-v' : ()); |
---|
739 | my $auth = $self->authority() ? $self->authority() . q{:} : q{}; |
---|
740 | for my $item (@{$items_ref}) { |
---|
741 | # Create container directory, as rsync does not do it automatically |
---|
742 | my $dir = dirname($self->$item()); |
---|
743 | if (@rsh_mkdir) { |
---|
744 | run_command([@rsh_mkdir, $dir], TIME => $self->verbose() > 2); |
---|
745 | } |
---|
746 | else { |
---|
747 | mkpath($dir); |
---|
748 | } |
---|
749 | run_command( |
---|
750 | [@rsync, @rsync_verbose, $dest0->$item(), $auth . $dir], |
---|
751 | TIME => $self->verbose > 2, |
---|
752 | ); |
---|
753 | } |
---|
754 | return 1; |
---|
755 | } |
---|
756 | |
---|
757 | # ------------------------------------------------------------------------------ |
---|
758 | # SYNOPSIS |
---|
759 | # $rc = $obj->set_lock (); |
---|
760 | # |
---|
761 | # DESCRIPTION |
---|
762 | # This method sets a lock in the current destination. |
---|
763 | # ------------------------------------------------------------------------------ |
---|
764 | |
---|
765 | sub set_lock { |
---|
766 | my $self = shift; |
---|
767 | |
---|
768 | $self->lockfile (); |
---|
769 | |
---|
770 | if ($self->type eq 'ext' and not $self->dest0) { |
---|
771 | # Only set an extract lock for the local destination |
---|
772 | $self->lockfile ($self->extlock); |
---|
773 | |
---|
774 | } elsif ($self->type eq 'bld') { |
---|
775 | # Set a build lock |
---|
776 | $self->lockfile ($self->bldlock); |
---|
777 | } |
---|
778 | |
---|
779 | return &touch_file ($self->lockfile) if $self->lockfile; |
---|
780 | } |
---|
781 | |
---|
782 | # ------------------------------------------------------------------------------ |
---|
783 | # SYNOPSIS |
---|
784 | # @cfglines = $obj->to_cfglines ([$index]); |
---|
785 | # |
---|
786 | # DESCRIPTION |
---|
787 | # This method returns a list of configuration lines for the current |
---|
788 | # destination. If it is set, $index is the index number of the current |
---|
789 | # destination. |
---|
790 | # ------------------------------------------------------------------------------ |
---|
791 | |
---|
792 | sub to_cfglines { |
---|
793 | my ($self, $index) = @_; |
---|
794 | |
---|
795 | my $PREFIX = $self->cfglabel($self->dest0() ? 'RDEST' : 'DEST'); |
---|
796 | my $SUFFIX = ($index ? $Fcm::Config::DELIMITER . $index : q{}); |
---|
797 | |
---|
798 | my @return = ( |
---|
799 | Fcm::CfgLine->new(label => $PREFIX . $SUFFIX, value => $self->rootdir()), |
---|
800 | ); |
---|
801 | if ($self->dest0()) { |
---|
802 | for my $name (qw{ |
---|
803 | logname |
---|
804 | machine |
---|
805 | mirror_cmd |
---|
806 | rsh_mkdir_rsh |
---|
807 | rsh_mkdir_rshflags |
---|
808 | rsh_mkdir_mkdir |
---|
809 | rsh_mkdir_mkdirflags |
---|
810 | rsync |
---|
811 | rsyncflags |
---|
812 | }) { |
---|
813 | if ($self->{$name} && $self->{$name} ne $PROP_OF{$name}) { # not default |
---|
814 | push( |
---|
815 | @return, |
---|
816 | Fcm::CfgLine->new( |
---|
817 | label => $PREFIX . $Fcm::Config::DELIMITER . uc($name) . $SUFFIX, |
---|
818 | value => $self->{$name}, |
---|
819 | ), |
---|
820 | ); |
---|
821 | } |
---|
822 | } |
---|
823 | } |
---|
824 | |
---|
825 | return @return; |
---|
826 | } |
---|
827 | |
---|
828 | # ------------------------------------------------------------------------------ |
---|
829 | # SYNOPSIS |
---|
830 | # $string = $obj->write_rules (); |
---|
831 | # |
---|
832 | # DESCRIPTION |
---|
833 | # This method returns a string containing Makefile variable declarations for |
---|
834 | # directories and search paths in this destination. |
---|
835 | # ------------------------------------------------------------------------------ |
---|
836 | |
---|
837 | sub write_rules { |
---|
838 | my $self = shift; |
---|
839 | my $return = ''; |
---|
840 | |
---|
841 | # FCM_*DIR* |
---|
842 | for my $i (0 .. @{ $self->inherit }) { |
---|
843 | for my $name (@paths) { |
---|
844 | (my $label = $name) =~ s/path$/dir/; |
---|
845 | my $dir = $name eq 'rootpath' ? $self->$name->[$i] : File::Spec->catfile ( |
---|
846 | '$(FCM_ROOTDIR' . ($i ? $i : '') . ')', |
---|
847 | File::Spec->abs2rel ($self->$name->[$i], $self->rootpath->[$i]), |
---|
848 | ); |
---|
849 | |
---|
850 | $return .= ($i ? '' : 'export ') . 'FCM_' . uc ($label) . ($i ? $i : '') . |
---|
851 | ' := ' . $dir . "\n"; |
---|
852 | } |
---|
853 | } |
---|
854 | |
---|
855 | # FCM_*PATH |
---|
856 | for my $name (@paths) { |
---|
857 | (my $label = $name) =~ s/path$/dir/; |
---|
858 | |
---|
859 | $return .= 'export FCM_' . uc ($name) . ' := '; |
---|
860 | for my $i (0 .. @{ $self->$name } - 1) { |
---|
861 | $return .= ($i ? ':' : '') . '$(FCM_' . uc ($label) . ($i ? $i : '') . ')'; |
---|
862 | } |
---|
863 | $return .= "\n"; |
---|
864 | } |
---|
865 | |
---|
866 | $return .= "\n"; |
---|
867 | |
---|
868 | return $return; |
---|
869 | } |
---|
870 | |
---|
871 | # Returns contents in directory. |
---|
872 | sub _directory_contents { |
---|
873 | my $path = shift(); |
---|
874 | if (!-d $path) { |
---|
875 | return; |
---|
876 | } |
---|
877 | opendir(my $handle, $path) || croak("$path: cannot open directory ($!)\n"); |
---|
878 | my @items = grep {$_ ne q{.} && $_ ne q{..}} readdir($handle); |
---|
879 | closedir($handle); |
---|
880 | map {File::Spec->catfile($path . $_)} @items; |
---|
881 | } |
---|
882 | |
---|
883 | # ------------------------------------------------------------------------------ |
---|
884 | |
---|
885 | 1; |
---|
886 | |
---|
887 | __END__ |
---|