xref: /aoo42x/main/solenv/bin/deliver.pl (revision f8ab842f)
1:
2eval 'exec perl -wS $0 ${1+"$@"}'
3    if 0;
4#**************************************************************
5#
6#  Licensed to the Apache Software Foundation (ASF) under one
7#  or more contributor license agreements.  See the NOTICE file
8#  distributed with this work for additional information
9#  regarding copyright ownership.  The ASF licenses this file
10#  to you under the Apache License, Version 2.0 (the
11#  "License"); you may not use this file except in compliance
12#  with the License.  You may obtain a copy of the License at
13#
14#    http://www.apache.org/licenses/LICENSE-2.0
15#
16#  Unless required by applicable law or agreed to in writing,
17#  software distributed under the License is distributed on an
18#  "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
19#  KIND, either express or implied.  See the License for the
20#  specific language governing permissions and limitations
21#  under the License.
22#
23#**************************************************************
24
25
26
27#
28# deliver.pl - copy from module output tree to solver
29#
30
31use Cwd;
32use File::Basename;
33use File::Copy;
34use File::DosGlob 'glob';
35use File::Path;
36use File::Spec;
37
38#### script id #####
39
40( $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;
41
42$id_str = ' $Revision$ ';
43$id_str =~ /Revision:\s+(\S+)\s+\$/
44  ? ($script_rev = $1) : ($script_rev = "-");
45
46
47#### globals ####
48
49### valid actions ###
50# if you add a action 'foo', than add 'foo' to this list and
51# implement 'do_foo()' in the implemented actions area
52@action_list        =   (           # valid actions
53                        'copy',
54                        'dos',
55                        'addincpath',
56                        'linklib',
57                        'mkdir',
58                        'symlink',
59                        'touch'
60                        );
61
62# copy filter: files matching these patterns won't be copied by
63# the copy action
64@copy_filter_patterns = (
65                        );
66
67$strip              = '';
68$is_debug           = 0;
69
70$error              = 0;
71$module             = 0;            # module name
72$repository         = 0;            # parent directory of this module
73$base_dir           = 0;            # path to module base directory
74$dlst_file          = 0;            # path to d.lst
75$ilst_ext           = 'ilst';       # extension of image lists
76$umask              = 22;           # default file/directory creation mask
77$dest               = 0;            # optional destination path
78$common_build       = 0;            # do we have common trees?
79$common_dest        = 0;            # common tree on solver
80
81@action_data        = ();           # LoL with all action data
82@macros             = ();           # d.lst macros
83@addincpath_list    = ();           # files which have to be filtered through addincpath
84@dirlist            = ();           # List of 'mkdir' targets
85@zip_list           = ();           # files which have to be zipped
86@common_zip_list    = ();           # common files which have to be zipped
87@log_list           = ();           # LoL for logging all copy and link actions
88@common_log_list    = ();           # LoL for logging all copy and link actions in common_dest
89$logfiledate        = 0;            # Make log file as old as newest delivered file
90$commonlogfiledate  = 0;            # Make log file as old as newest delivered file
91
92$files_copied       = 0;            # statistics
93$files_unchanged    = 0;            # statistics
94
95$opt_force          = 0;            # option force copy
96$opt_check          = 0;            # do actually execute any action
97$opt_zip            = 0;            # create an additional zip file
98$opt_silent         = 0;            # be silent, only report errors
99$opt_verbose        = 0;            # be verbose (former default behaviour)
100$opt_log            = 1;            # create an additional log file
101$opt_link           = 0;            # hard link files into the solver to save disk space
102$opt_deloutput      = 0;            # delete the output tree for the project once successfully delivered
103$opt_checkdlst      = 0;
104$delete_common      = 1;            # for "-delete": if defined delete files from common tree also
105
106if ($^O ne 'cygwin') {              # iz59477 - cygwin needes a dot "." at the end of filenames to disable
107    $maybedot     = '';             # some .exe transformation magic.
108} else {
109    my $cygvernum = `uname -r`;
110    my @cygvernum = split( /\./, $cygvernum);
111    $cygvernum = shift @cygvernum;
112    $cygvernum .= shift @cygvernum;
113    if ( $cygvernum < 17 ) {
114        $maybedot     = '.';
115    } else {
116        $maybedot     = '';               # no longer works with cygwin 1.7. other magic below.
117    }
118}
119
120($gui		= lc($ENV{GUI})) 		|| die "Can't determine 'GUI'. Please set environment.\n";
121$tempcounter        = 0;
122
123# zip is default for RE master builds
124$opt_zip = 1 if ( defined($ENV{DELIVER_TO_ZIP}) && uc($ENV{DELIVER_TO_ZIP}) eq 'TRUE' && ! defined($ENV{CWS_WORK_STAMP}));
125
126$has_symlinks       = 0;            # system supports symlinks
127
128for (@action_list) {
129    $action_hash{$_}++;
130}
131
132# trap normal signals (HUP, INT, PIPE, TERM)
133# for clean up on unexpected termination
134use sigtrap 'handler' => \&cleanup_and_die, 'normal-signals';
135
136#### main ####
137
138parse_options();
139init_globals();
140
141print "$script_name -- version: $script_rev\n" if !$opt_silent;
142
143if ( ! $opt_delete ) {
144    if ( $ENV{GUI} eq 'WNT' ) {
145        if ($ENV{COM} eq 'GCC') {
146            initialize_strip() ;
147        };
148    } else {
149        initialize_strip();
150    }
151}
152
153push_default_actions();
154parse_dlst();
155check_dlst() if $opt_checkdlst;
156walk_action_data();
157walk_addincpath_list();
158write_log() if $opt_log;
159zip_files() if $opt_zip;
160cleanup() if $opt_delete;
161delete_output() if $opt_deloutput;
162print_stats();
163
164exit($error);
165
166#### implemented actions #####
167
168sub do_copy
169{
170    # We need to copy two times:
171    # from the platform dependent output tree
172    # and from the common output tree
173    my ($dependent, $common, $from, $to, $file_list);
174    my $line = shift;
175    my $touch = 0;
176
177    $dependent = expand_macros($line);
178    ($from, $to) = split(' ', $dependent);
179    print "copy dependent: from: $from, to: $to\n" if $is_debug;
180    glob_and_copy($from, $to, $touch);
181
182    if ($delete_common && $common_build && ( $line !~ /%COMMON_OUTDIR%/ ) ) {
183        $line =~ s/%__SRC%/%COMMON_OUTDIR%/ig;
184        if ( $line =~ /%COMMON_OUTDIR%/ ) {
185            $line =~ s/%_DEST%/%COMMON_DEST%/ig;
186            $common = expand_macros($line);
187            ($from, $to) = split(' ', $common);
188            print "copy common: from: $from, to: $to\n" if $is_debug;
189            glob_and_copy($from, $to, $touch);
190        }
191    }
192}
193
194sub do_dos
195{
196    my $line = shift;
197
198    my $command = expand_macros($line);
199    if ( $opt_check ) {
200        print "DOS: $command\n";
201    }
202    else {
203        # HACK: remove MACOSX stuff which is wrongly labeled with dos
204        # better: fix broken d.lst
205        return if ( $command =~ /MACOSX/ );
206        $command =~ s#/#\\#g if $^O eq 'MSWin32';
207        system($command);
208    }
209}
210
211sub do_addincpath
212{
213    # just collect all addincpath files, actual filtering is done later
214    my $line = shift;
215    my ($from, $to);
216    my @globbed_files = ();
217
218    $line = expand_macros($line);
219    ($from, $to) = split(' ', $line);
220
221    push( @addincpath_list, @{glob_line($from, $to)});
222}
223
224sub do_linklib
225{
226    my ($lib_base, $lib_major,$from_dir, $to_dir);
227    my $lib = shift;
228    my @globbed_files = ();
229    my %globbed_hash = ();
230
231    print "linklib: $lib\n" if $is_debug;
232    print "has symlinks\n" if ( $has_symlinks && $is_debug );
233
234    return unless $has_symlinks;
235
236    $from_dir = expand_macros('../%__SRC%/lib');
237    $to_dir = expand_macros('%_DEST%/lib%_EXT%');
238
239    @globbed_files = glob("$from_dir/$lib");
240
241    if ( $#globbed_files == -1 ) {
242       return;
243    }
244
245    foreach $lib (@globbed_files) {
246        $lib = basename($lib);
247        if ( $lib =~ /^(lib\S+(\.so|\.dylib))\.(\d+)\.(\d+)(\.(\d+))?$/
248             || $lib =~ /^(lib\S+(\.so|\.dylib))\.(\d+)$/ )
249        {
250           push(@{$globbed_hash{$1}}, $lib);
251        }
252        else {
253            print_warning("invalid library name: $lib");
254        }
255    }
256
257    foreach $lib_base ( sort keys %globbed_hash ) {
258        $lib = get_latest_patchlevel(@{$globbed_hash{$lib_base}});
259
260        if ( $lib =~ /^(lib\S+(\.so|\.dylib))\.(\d+)\.(\d+)(\.(\d+))?$/ )
261        {
262            $lib_major = "$lib_base.$3";
263            $long = 1;
264        }
265        else
266        {
267            # $lib =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)$/;
268            $long = 0;
269        }
270
271        if ( $opt_check ) {
272            if ( $opt_delete ) {
273                print "REMOVE: $to_dir/$lib_major\n" if $long;
274                print "REMOVE: $to_dir/$lib_base\n";
275            }
276            else {
277                print "LINKLIB: $to_dir/$lib -> $to_dir/$lib_major\n" if $long;
278                print "LINKLIB: $to_dir/$lib -> $to_dir/$lib_base\n";
279            }
280        }
281        else {
282            if ( $opt_delete ) {
283                print "REMOVE: $to_dir/$lib_major\n" if ($long && $opt_verbose);
284                print "REMOVE: $to_dir/$lib_base\n" if $opt_verbose;
285                unlink "$to_dir/$lib_major" if $long;
286                unlink "$to_dir/$lib_base";
287                if ( $opt_zip ) {
288                    push_on_ziplist("$to_dir/$lib_major") if $long;
289                    push_on_ziplist("$to_dir/$lib_base");
290                }
291                return;
292            }
293            my $symlib;
294            my @symlibs;
295            if ($long)
296            {
297                @symlibs = ("$to_dir/$lib_major", "$to_dir/$lib_base");
298            }
299            else
300            {
301                @symlibs = ("$to_dir/$lib_base");
302            }
303            # remove old symlinks
304            unlink(@symlibs);
305            foreach $symlib (@symlibs) {
306                print "LINKLIB: $lib -> $symlib\n" if $opt_verbose;
307                if ( !symlink("$lib", "$symlib") ) {
308                    print_error("can't symlink $lib -> $symlib: $!",0);
309                }
310                else {
311                    push_on_ziplist($symlib) if $opt_zip;
312                    push_on_loglist("LINK", "$lib", "$symlib") if $opt_log;
313                }
314            }
315        }
316    }
317}
318
319sub do_mkdir
320{
321    my $path = expand_macros(shift);
322    # strip whitespaces from path name
323    $path =~ s/\s$//;
324    if (( ! $opt_delete ) && ( ! -d $path )) {
325        if ( $opt_check ) {
326            print "MKDIR: $path\n";
327        } else {
328            mkpath($path, 0, 0777-$umask);
329            if ( ! -d $path ) {
330                print_error("mkdir: could not create directory '$path'", 0);
331            }
332        }
333    }
334}
335
336sub do_symlink
337{
338    my $line = shift;
339
340    $line = expand_macros($line);
341    ($from, $to) = split(' ',$line);
342    my $fullfrom = $from;
343    if ( dirname($from) eq dirname($to) ) {
344        $from = basename($from);
345    }
346    elsif ( dirname($from) eq '.' ) {
347        # nothing to do
348    }
349    else {
350        print_error("symlink: link must be in the same directory as file",0);
351        return 0;
352    }
353
354    print "symlink: $from, to: $to\n" if $is_debug;
355
356    return unless $has_symlinks;
357
358    if ( $opt_check ) {
359        if ( $opt_delete ) {
360            print "REMOVE: $to\n";
361        }
362        else {
363            print "SYMLINK $from -> $to\n";
364        }
365    }
366    else {
367        print "REMOVE: $to\n" if $opt_verbose;
368        unlink $to;
369        if ( $opt_delete ) {
370            push_on_ziplist($to) if $opt_zip;
371            return;
372        }
373        return unless -e $fullfrom;
374        print "SYMLIB: $from -> $to\n" if $opt_verbose;
375        if ( !symlink("$from", "$to") ) {
376            print_error("can't symlink $from -> $to: $!",0);
377        }
378        else {
379            push_on_ziplist($to) if $opt_zip;
380            push_on_loglist("LINK", "$from", "$to") if $opt_log;
381        }
382    }
383}
384
385sub do_touch
386{
387    my ($from, $to);
388    my $line = shift;
389    my $touch = 1;
390
391    $line = expand_macros($line);
392    ($from, $to) = split(' ', $line);
393    print "touch: $from, to: $to\n" if $is_debug;
394    glob_and_copy($from, $to, $touch);
395}
396
397#### subroutines #####
398
399sub parse_options
400{
401    my $arg;
402    my $dontdeletecommon = 0;
403    $opt_silent = 1 if ( defined $ENV{VERBOSE} && $ENV{VERBOSE} eq 'FALSE');
404    $opt_verbose = 1 if ( defined $ENV{VERBOSE} && $ENV{VERBOSE} eq 'TRUE');
405    while ( $arg = shift @ARGV ) {
406        $arg =~ /^-force$/      and $opt_force  = 1  and next;
407        $arg =~ /^-check$/      and $opt_check  = 1  and $opt_verbose = 1 and next;
408        $arg =~ /^-quiet$/      and $opt_silent = 1  and next;
409        $arg =~ /^-verbose$/    and $opt_verbose = 1 and next;
410        $arg =~ /^-zip$/        and $opt_zip    = 1  and next;
411        $arg =~ /^-delete$/     and $opt_delete = 1  and next;
412        $arg =~ /^-dontdeletecommon$/ and $dontdeletecommon = 1 and next;
413        $arg =~ /^-help$/       and $opt_help   = 1  and $arg = '';
414        $arg =~ /^-link$/       and $ENV{GUI} ne 'WNT' and $opt_link = 1 and next;
415        $arg =~ /^-deloutput$/  and $opt_deloutput = 1 and next;
416        $arg =~ /^-debug$/      and $is_debug   = 1  and next;
417        $arg =~ /^-checkdlst$/  and $opt_checkdlst = 1 and next;
418        print_error("invalid option $arg") if ( $arg =~ /^-/ );
419        if ( $arg =~ /^-/ || $opt_help || $#ARGV > -1 ) {
420            usage(1);
421        }
422        $dest = $arg;
423    }
424    # $dest and $opt_zip or $opt_delete are mutually exclusive
425    if ( $dest and ($opt_zip || $opt_delete) ) {
426        usage(1);
427    }
428    # $opt_silent and $opt_check or $opt_verbose are mutually exclusive
429    if ( ($opt_check or $opt_verbose) and $opt_silent ) {
430        print STDERR "Error on command line: options '-check' and '-quiet' are mutually exclusive.\n";
431        usage(1);
432    }
433    if ($dontdeletecommon) {
434        if (!$opt_delete) {
435            usage(1);
436        }
437        $delete_common = 0;
438    };
439    # $opt_delete implies $opt_force
440    $opt_force = 1 if $opt_delete;
441}
442
443sub init_globals
444{
445    my $ext;
446    ($module, $repository, $base_dir, $dlst_file) =  get_base();
447
448    # for CWS:
449    $module =~ s/\.lnk$//;
450
451    print "Module=$module, Base_Dir=$base_dir, d.lst=$dlst_file\n" if $is_debug;
452
453    $umask = umask();
454    if ( !defined($umask) ) {
455        $umask = 22;
456    }
457
458    my $build_sosl    = $ENV{'BUILD_SOSL'};
459    my $common_outdir = $ENV{'COMMON_OUTDIR'};
460    my $inpath        = $ENV{'INPATH'};
461    my $solarversion  = $ENV{'SOLARVERSION'};
462    my $updater       = $ENV{'UPDATER'};
463    my $updminor      = $ENV{'UPDMINOR'};
464    my $updminorext   = $ENV{'UPDMINOREXT'};
465    my $work_stamp    = $ENV{'WORK_STAMP'};
466
467    $::CC_PATH=(fileparse( $ENV{"CC"}))[1];
468
469    # special security check for release engineers
470    if ( defined($updater) && !defined($build_sosl) && !$opt_force) {
471        my $path = getcwd();
472        if ( $path !~ /$work_stamp/io ) {
473            print_error("can't deliver from local directory to SOLARVERSION");
474            print STDERR "\nDANGER! Release Engineer:\n";
475            print STDERR "do you really want to deliver from $path to SOLARVERSION?\n";
476            print STDERR "If so, please use the -force switch\n\n";
477            exit(7);
478        }
479    }
480
481    # do we have a valid environment?
482    if ( !defined($inpath) ) {
483            print_error("no environment", 0);
484            exit(3);
485    }
486
487    $ext = "";
488    if ( ($updminor) && !$dest ) {
489        $ext = "$updminorext";
490    }
491
492    # Do we have common trees?
493    if ( defined($ENV{'common_build'}) && $ENV{'common_build'} eq 'TRUE' ) {
494        $common_build = 1;
495        if ((defined $common_outdir) && ($common_outdir ne "")) {
496            $common_outdir = $common_outdir . ".pro" if $inpath =~ /\.pro$/;
497            if ( $dest ) {
498                $common_dest = $dest;
499            } else {
500                $common_dest = "$solarversion/$common_outdir";
501                $dest = "$solarversion/$inpath";
502            }
503        } else {
504            print_error("common_build defined without common_outdir", 0);
505            exit(6);
506        }
507    } else {
508        $common_outdir = $inpath;
509        $dest = "$solarversion/$inpath" if ( !$dest );
510        $common_dest = $dest;
511    }
512    $dest =~ s#\\#/#g;
513    $common_dest =~ s#\\#/#g;
514
515    # the following macros are obsolete, will be flagged as error
516    # %__WORKSTAMP%
517    # %GUIBASE%
518    # %SDK%
519    # %SOLARVER%
520    # %__OFFENV%
521    # %DLLSUFFIX%'
522    # %OUTPATH%
523    # %L10N_FRAMEWORK%
524    # %UPD%
525
526    # valid macros
527    @macros = (
528                [ '%__PRJROOT%',        $base_dir       ],
529                [ '%__SRC%',            $inpath         ],
530                [ '%_DEST%',            $dest           ],
531                [ '%_EXT%',             $ext            ],
532                [ '%COMMON_OUTDIR%',    $common_outdir  ],
533                [ '%COMMON_DEST%',      $common_dest    ],
534                [ '%GUI%',              $gui            ]
535              );
536
537    # find out if the system supports symlinks
538    $has_symlinks = eval { symlink("",""); 1 };
539}
540
541sub get_base
542{
543    # a module base dir contains a subdir 'prj'
544    # which in turn contains a file 'd.lst'
545    my (@field, $repo, $base, $dlst);
546    my $path = getcwd();
547
548    @field = split(/\//, $path);
549
550    while ( $#field != -1 ) {
551        $base = join('/', @field);
552        $dlst = $base . '/prj/d.lst';
553        last if -e $dlst;
554        pop @field;
555    }
556
557    if ( $#field == -1 ) {
558        print_error("can't find d.lst");
559        exit(2);
560    }
561    else {
562        if ( defined $field[-2] ) {
563            $repo = $field[-2];
564        } else {
565            print_error("Internal error: cannot determine module's parent directory");
566        }
567        return ($field[-1], $repo, $base, $dlst);
568    }
569}
570
571sub parse_dlst
572{
573    my $line_cnt = 0;
574    open(DLST, "<$dlst_file") or die "can't open d.lst";
575    while(<DLST>) {
576        $line_cnt++;
577        tr/\r\n//d;
578        next if /^#/;
579        next if /^\s*$/;
580        if (!$delete_common && /%COMMON_DEST%/) {
581            # Just ignore all lines with %COMMON_DEST%
582            next;
583        };
584        if ( /^\s*(\w+?):\s+(.*)$/ ) {
585            if ( !exists $action_hash{$1} ) {
586                print_error("unknown action: \'$1\'", $line_cnt);
587                exit(4);
588            }
589            push(@action_data, [$1, $2]);
590        }
591        else {
592            if ( /^\s*%(COMMON)?_DEST%\\/ ) {
593                # only copy from source dir to solver, not from solver to solver
594                print_warning("illegal copy action, ignored: \'$_\'", $line_cnt);
595                next;
596            }
597            push(@action_data, ['copy', $_]);
598            # for each ressource file (.res) copy its image list (.ilst)
599            if ( /\.res\s/ ) {
600                my $imagelist = $_;
601                $imagelist =~ s/\.res/\.$ilst_ext/g;
602                $imagelist =~ s/\\bin%_EXT%\\/\\res%_EXT%\\img\\/;
603                push(@action_data, ['copy', $imagelist]);
604            }
605        }
606        # call expand_macros()just to find any undefined macros early
607        # real expansion is done later
608        expand_macros($_, $line_cnt);
609    }
610    close(DLST);
611}
612
613sub expand_macros
614{
615    # expand all macros and change backslashes to slashes
616    my $line        = shift;
617    my $line_cnt    = shift;
618    my $i;
619
620    for ($i=0; $i<=$#macros; $i++)  {
621        $line =~ s/$macros[$i][0]/$macros[$i][1]/gi
622    }
623    if ( $line =~ /(%\w+%)/ ) {
624        if ( $1 ne '%OS%' ) {   # %OS% looks like a macro but is not ...
625            print_error("unknown/obsolete macro: \'$1\'", $line_cnt);
626        }
627    }
628    $line =~ s#\\#/#g;
629    return $line;
630}
631
632sub walk_action_data
633{
634    # all actions have to be excuted relative to the prj directory
635    chdir("$base_dir/prj");
636    # dispatch depending on action type
637    for (my $i=0; $i <= $#action_data; $i++) {
638            &{"do_".$action_data[$i][0]}($action_data[$i][1]);
639            if ( $action_data[$i][0] eq 'mkdir' ) {
640                # fill array with (possibly) created directories in
641                # revers order for removal in 'cleanup'
642                unshift @dirlist, $action_data[$i][1];
643            }
644    }
645}
646
647sub glob_line
648{
649    my $from = shift;
650    my $to = shift;
651    my $to_dir = shift;
652    my $replace = 0;
653    my @globbed_files = ();
654
655    if ( ! ( $from && $to ) ) {
656        print_warning("Error in d.lst? source: '$from' destination: '$to'");
657        return \@globbed_files;
658    }
659
660    if ( $to =~ /[\*\?\[\]]/ ) {
661        my $to_fname;
662        ($to_fname, $to_dir) = fileparse($to);
663        $replace = 1;
664    }
665
666    if ( $from =~ /[\*\?\[\]]/ ) {
667        # globbing necessary, no renaming possible
668        my $file;
669        my @file_list = glob($from);
670
671        foreach $file ( @file_list ) {
672            next if ( -d $file); # we only copy files, not directories
673            my ($fname, $dir) = fileparse($file);
674            my $copy = ($replace) ? $to_dir . $fname : $to . '/' . $fname;
675            push(@globbed_files, [$file, $copy]);
676        }
677    }
678    else {
679        # no globbing but renaming possible
680        # #i89066#
681        if (-d $to && -f $from) {
682            my $filename = File::Basename::basename($from);
683            $to .= '/' if ($to !~ /[\\|\/]$/);
684            $to .= $filename;
685        };
686        push(@globbed_files, [$from, $to]);
687    }
688    if ( $opt_checkdlst ) {
689        my $outtree = expand_macros("%__SRC%");
690        my $commonouttree = expand_macros("%COMMON_OUTDIR%");
691        if (( $from !~ /\Q$outtree\E/ ) && ( $from !~ /\Q$commonouttree\E/ )) {
692            print_warning("'$from' does not match any file") if ( $#globbed_files == -1 );
693        }
694    }
695    return \@globbed_files;
696}
697
698
699sub glob_and_copy
700{
701    my $from = shift;
702    my $to = shift;
703    my $touch = shift;
704
705    my @copy_files = @{glob_line($from, $to)};
706
707    for (my $i = 0; $i <= $#copy_files; $i++) {
708        next if filter_out($copy_files[$i][0]); # apply copy filter
709        copy_if_newer($copy_files[$i][0], $copy_files[$i][1], $touch)
710                    ? $files_copied++ : $files_unchanged++;
711    }
712}
713
714sub is_unstripped {
715    my $file_name = shift;
716    my $nm_output;
717
718    if (-f $file_name.$maybedot) {
719        my $file_type = `file $file_name`;
720        # OS X file command doesn't know if a file is stripped or not
721        if (($file_type =~ /not stripped/o) || ($file_type =~ /Mach-O/o) ||
722            (($file_type =~ /PE/o) && ($ENV{GUI} eq 'WNT') &&
723             ($nm_output = `nm $file_name 2>&1`) && $nm_output &&
724             !($nm_output =~ /no symbols/i) && !($nm_output =~ /not recognized/i))) {
725            return '1' if ($file_name =~ /\.bin$/o);
726            return '1' if ($file_name =~ /\.so\.*/o);
727            return '1' if ($file_name =~ /\.dylib\.*/o);
728            return '1' if ($file_name =~ /\.com\.*/o);
729            return '1' if ($file_name =~ /\.dll\.*/o);
730            return '1' if ($file_name =~ /\.exe\.*/o);
731            return '1' if (basename($file_name) !~ /\./o);
732        }
733    };
734    return '';
735}
736
737sub initialize_strip {
738    if ((!defined $ENV{DISABLE_STRIP}) || ($ENV{DISABLE_STRIP} eq "")) {
739        $strip .= 'guw ' if ($^O eq 'cygwin');
740        $strip .= $::CC_PATH if (-e $::CC_PATH.'/strip');
741        $strip .= 'strip';
742        $strip .= " -x" if ($ENV{OS} eq 'MACOSX');
743        $strip .= " -R '.comment' -s" if ($ENV{OS} eq 'LINUX');
744    };
745};
746
747sub is_jar {
748    my $file_name = shift;
749
750    if (-f $file_name && (( `file $file_name` ) =~ /Zip archive/o)) {
751        return '1' if ($file_name =~ /\.jar\.*/o);
752    };
753    return '';
754}
755
756sub execute_system {
757    my $command = shift;
758    if (system($command)) {
759        print_error("Failed to execute $command");
760        exit($?);
761    };
762};
763
764sub strip_target {
765    my $file = shift;
766    my $temp_file = shift;
767    $temp_file =~ s/\/{2,}/\//g;
768    my $rc = copy($file, $temp_file);
769    execute_system("$strip $temp_file");
770    return $rc;
771};
772
773sub copy_if_newer
774{
775    # return 0 if file is unchanged ( for whatever reason )
776    # return 1 if file has been copied
777    my $from = shift;
778    my $to = shift;
779    my $touch = shift;
780    my $from_stat_ref;
781    my $rc = 0;
782
783    print "testing $from, $to\n" if $is_debug;
784    push_on_ziplist($to) if $opt_zip;
785    push_on_loglist("COPY", "$from", "$to") if $opt_log;
786    return 0 unless ($from_stat_ref = is_newer($from, $to, $touch));
787
788    if ( $opt_delete ) {
789        print "REMOVE: $to\n" if $opt_verbose;
790        $rc = unlink($to) unless $opt_check;
791        return 1 if $opt_check;
792        return $rc;
793    }
794
795    if( !$opt_check && $opt_link ) {
796        # hard link if possible
797        if( link($from, $to) ){
798            print "LINK: $from -> $to\n" if $opt_verbose;
799            return 1;
800        }
801    }
802
803    if( $touch ) {
804       print "TOUCH: $from -> $to\n" if $opt_verbose;
805    }
806    else {
807       print "COPY: $from -> $to\n" if $opt_verbose;
808    }
809
810    return 1 if( $opt_check );
811
812    #
813    # copy to temporary file first and rename later
814    # to minimize the possibility for race conditions
815    local $temp_file = sprintf('%s.%d-%d', $to, $$, time());
816    $rc = '';
817    if (($strip ne '') && (defined $ENV{PROEXT}) && (is_unstripped($from))) {
818        $rc = strip_target($from, $temp_file);
819    } else {
820        $rc = copy($from, $temp_file);
821    };
822    if ( $rc) {
823        if ( is_newer($temp_file, $from, 0) ) {
824            $rc = utime($$from_stat_ref[9], $$from_stat_ref[9], $temp_file);
825            if ( !$rc ) {
826                print_warning("can't update temporary file modification time '$temp_file': $!\n
827                               Check file permissions of '$from'.",0);
828            }
829        }
830        fix_file_permissions($$from_stat_ref[2], $temp_file);
831        if ( $^O eq 'os2' )
832        {
833            $rc = unlink($to); # YD OS/2 can't rename if $to exists!
834        }
835        # Ugly hack: on windows file locking(?) sometimes prevents renaming.
836        # Until we've found and fixed the real reason try it repeatedly :-(
837        my $try = 0;
838        my $maxtries = 1;
839        $maxtries = 5 if ( $^O eq 'MSWin32' );
840        my $success = 0;
841        while ( $try < $maxtries && ! $success ) {
842            sleep $try;
843            $try ++;
844            $success = rename($temp_file, $to);
845            if ( $^O eq 'cygwin' && $to =~ /\.bin$/) {
846                # hack to survive automatically added .exe for executables renamed to
847                # *.bin - will break if there is intentionally a .bin _and_ .bin.exe file.
848                $success = rename( "$to.exe", $to ) if -f "$to.exe";
849            }
850        }
851        if ( $success ) {
852            # handle special packaging of *.dylib files for Mac OS X
853            if ( $^O eq 'darwin' )
854            {
855                system("macosx-create-bundle", "$to=$from.app") if ( -d "$from.app" );
856                system("ranlib", "$to" ) if ( $to =~ /\.a/ );
857            }
858            if ( $try > 1 ) {
859                print_warning("File '$to' temporarily locked. Dependency bug?");
860            }
861            return 1;
862        }
863        else {
864            print_error("can't rename temporary file to $to: $!",0);
865        }
866    }
867    else {
868        print_error("can't copy $from: $!",0);
869        my $destdir = dirname($to);
870        if ( ! -d $destdir ) {
871            print_error("directory '$destdir' does not exist", 0);
872        }
873    }
874    unlink($temp_file);
875    return 0;
876}
877
878sub is_newer
879{
880        # returns whole stat buffer if newer
881        my $from = shift;
882        my $to = shift;
883        my $touch = shift;
884        my (@from_stat, @to_stat);
885
886        @from_stat = stat($from.$maybedot);
887        if ( $opt_checkdlst ) {
888            my $outtree = expand_macros("%__SRC%");
889            my $commonouttree = expand_macros("%COMMON_OUTDIR%");
890            if ( $from !~ /$outtree/ ) {
891                if ( $from !~ /$commonouttree/ ) {
892                    print_warning("'$from' does not exist") unless -e _;
893                }
894            }
895        }
896        return 0 unless -f _;
897
898        if ( $touch ) {
899            $from_stat[9] = time();
900        }
901        # adjust timestamps to even seconds
902        # this is necessary since NT platforms have a
903        # 2s modified time granularity while the timestamps
904        # on Samba volumes have a 1s granularity
905
906        $from_stat[9]-- if $from_stat[9] % 2;
907
908        if ( $to =~ /^\Q$dest\E/ ) {
909            if ( $from_stat[9] > $logfiledate ) {
910                $logfiledate = $from_stat[9];
911            }
912        } elsif ( $common_build && ( $to =~ /^\Q$common_dest\E/ ) ) {
913            if ( $from_stat[9] > $commonlogfiledate ) {
914                $commonlogfiledate = $from_stat[9];
915            }
916        }
917
918        @to_stat = stat($to.$maybedot);
919        return \@from_stat unless -f _;
920
921        if ( $opt_force ) {
922            return \@from_stat;
923        }
924        else {
925            return ($from_stat[9] > $to_stat[9]) ? \@from_stat : 0;
926        }
927}
928
929sub filter_out
930{
931    my $file = shift;
932
933    foreach my $pattern ( @copy_filter_patterns ) {
934        if  ( $file =~ /$pattern/ ) {
935           print "filter out: $file\n" if $is_debug;
936           return 1;
937        }
938    }
939
940    return 0;
941}
942
943sub fix_file_permissions
944{
945    my $mode = shift;
946    my $file = shift;
947
948    if ( ($mode >> 6) % 2 == 1 ) {
949        $mode = 0777 & ~$umask;
950    }
951    else {
952        $mode = 0666 & ~$umask;
953    }
954    chmod($mode, $file);
955}
956
957sub get_latest_patchlevel
958{
959    # note: feed only well formed library names to this function
960    # of the form libfoo.so.x.y.z with x,y,z numbers
961
962    my @sorted_files = sort by_rev @_;
963    return $sorted_files[-1];
964
965    sub by_rev {
966    # comparison function for sorting
967        my (@field_a, @field_b, $i);
968
969        $a =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)\.(\d+)\.(\d+)$/;
970        @field_a = ($3, $4, $5);
971        $b =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)\.(\d+)\.(\d+)$/;
972        @field_b = ($3, $4, $5);
973
974        for ($i = 0; $i < 3; $i++)
975          {
976              # if unitialized assign 0 as default value.
977              $field_a[$i] //= 0;
978              $field_b[$i] //= 0;
979              if ( ($field_a[$i] < $field_b[$i]) ) {
980                  return -1;
981              }
982              if ( ($field_a[$i] > $field_b[$i]) ) {
983                  return 1;
984              }
985          }
986
987        # can't happen
988        return 0;
989    }
990
991}
992
993sub push_default_actions
994{
995    # any default action (that is an action which must be done even without
996    # a corresponding d.lst entry) should be pushed here on the
997    # @action_data list.
998    my $subdir;
999    my @subdirs = (
1000                    'bin',
1001                    'doc',
1002                    'inc',
1003                    'lib',
1004                    'par',
1005                    'pck',
1006                    'rdb',
1007                    'res',
1008                    'tmp',
1009                    'xml'
1010                );
1011    push(@subdirs, 'zip') if $opt_zip;
1012    push(@subdirs, 'idl') if ! $common_build;
1013    push(@subdirs, 'pus') if ! $common_build;
1014    my @common_subdirs = (
1015                    'bin',
1016                    'idl',
1017                    'inc',
1018                    'pck',
1019                    'pus',
1020                    'res'
1021                );
1022    push(@common_subdirs, 'zip') if $opt_zip;
1023
1024    if ( ! $opt_delete ) {
1025        # create all the subdirectories on solver
1026        foreach $subdir (@subdirs) {
1027            push(@action_data, ['mkdir', "%_DEST%/$subdir%_EXT%"]);
1028        }
1029        if ( $common_build ) {
1030            foreach $subdir (@common_subdirs) {
1031                push(@action_data, ['mkdir', "%COMMON_DEST%/$subdir%_EXT%"]);
1032            }
1033        }
1034    }
1035    push(@action_data, ['mkdir', "%_DEST%/inc%_EXT%/$module"]);
1036    if ( $common_build ) {
1037        push(@action_data, ['mkdir', "%COMMON_DEST%/inc%_EXT%/$module"]);
1038        push(@action_data, ['mkdir', "%COMMON_DEST%/res%_EXT%/img"]);
1039    } else {
1040        push(@action_data, ['mkdir', "%_DEST%/res%_EXT%/img"]);
1041    }
1042
1043    # deliver build.lst to $dest/inc/$module
1044    push(@action_data, ['copy', "build.lst %_DEST%/inc%_EXT%/$module/build.lst"]);
1045    if ( $common_build ) {
1046        # ... and to $common_dest/inc/$module
1047        push(@action_data, ['copy', "build.lst %COMMON_DEST%/inc%_EXT%/$module/build.lst"]);
1048    }
1049
1050    # need to copy libstaticmxp.dylib for Mac OS X
1051    if ( $^O eq 'darwin' )
1052    {
1053        push(@action_data, ['copy', "../%__SRC%/lib/lib*static*.dylib %_DEST%/lib%_EXT%/lib*static*.dylib"]);
1054    }
1055}
1056
1057sub walk_addincpath_list
1058{
1059    my (@addincpath_headers);
1060    return if $#addincpath_list == -1;
1061
1062    # create hash with all addincpath header names
1063    for (my $i = 0; $i <= $#addincpath_list; $i++) {
1064        my @field = split('/', $addincpath_list[$i][0]);
1065        push (@addincpath_headers, $field[-1]);
1066    }
1067
1068    # now stream all addincpath headers through addincpath filter
1069    for (my $i = 0; $i <= $#addincpath_list; $i++) {
1070        add_incpath_if_newer($addincpath_list[$i][0], $addincpath_list[$i][1], \@addincpath_headers)
1071                ? $files_copied++ : $files_unchanged++;
1072    }
1073}
1074
1075sub add_incpath_if_newer
1076{
1077    my $from = shift;
1078    my $to = shift;
1079    my $modify_headers_ref = shift;
1080    my ($from_stat_ref, $header);
1081
1082    push_on_ziplist($to) if $opt_zip;
1083    push_on_loglist("ADDINCPATH", "$from", "$to") if $opt_log;
1084
1085    if ( $opt_delete ) {
1086        print "REMOVE: $to\n" if $opt_verbose;
1087        my $rc = unlink($to);
1088        return 1 if $rc;
1089        return 0;
1090    }
1091
1092    if ( $from_stat_ref = is_newer($from, $to) ) {
1093        print "ADDINCPATH: $from -> $to\n" if $opt_verbose;
1094
1095        return 1 if $opt_check;
1096
1097        my $save = $/;
1098        undef $/;
1099        open(FROM, "<$from");
1100        # slurp whole file in one big string
1101        my $content = <FROM>;
1102        close(FROM);
1103        $/ = $save;
1104
1105        foreach $header (@$modify_headers_ref) {
1106            $content =~ s/#include [<"]$header[>"]/#include <$module\/$header>/g;
1107        }
1108
1109        open(TO, ">$to");
1110        print TO $content;
1111        close(TO);
1112
1113        utime($$from_stat_ref[9], $$from_stat_ref[9], $to);
1114        fix_file_permissions($$from_stat_ref[2], $to);
1115        return 1;
1116    }
1117    return 0;
1118}
1119
1120sub push_on_ziplist
1121{
1122    my $file = shift;
1123    return if ( $opt_check );
1124    # strip $dest from path since we don't want to record it in zip file
1125    if ( $file =~ s#^\Q$dest\E/##o ) {
1126        if ( $updminor ){
1127            # strip minor from path
1128            my $ext = "%_EXT%";
1129            $ext = expand_macros($ext);
1130            $file =~ s#^$ext##o;
1131        }
1132        push(@zip_list, $file);
1133    } elsif ( $file =~ s#^\Q$common_dest\E/##o ) {
1134        if ( $updminor ){
1135            # strip minor from path
1136            my $ext = "%_EXT%";
1137            $ext = expand_macros($ext);
1138            $file =~ s#^$ext##o;
1139        }
1140        push(@common_zip_list, $file);
1141    }
1142}
1143
1144sub push_on_loglist
1145{
1146    my @entry = @_;
1147    return 0 if ( $opt_check );
1148    return -1 if ( $#entry != 2 );
1149    if (( $entry[0] eq "COPY" ) || ( $entry[0] eq "ADDINCPATH" )) {
1150        return 0 if ( ! -e $entry[1].$maybedot );
1151        # make 'from' relative to source root
1152        $entry[1] = $repository ."/" . $module . "/prj/" . $entry[1];
1153        $entry[1] =~ s/$module\/prj\/\.\./$module/;
1154    }
1155    # platform or common tree?
1156    my $common;
1157    if ( $entry[2] =~ /^\Q$dest\E/ ) {
1158        $common = 0;
1159    } elsif ( $common_build && ( $entry[2] =~ /^\Q$common_dest\E/ )) {
1160        $common = 1;
1161    } else {
1162        warn "Neither common nor platform tree?";
1163        return;
1164    }
1165    # make 'to' relative to SOLARVERSION
1166    my $solarversion  = $ENV{'SOLARVERSION'};
1167    $solarversion =~ s#\\#/#g;
1168    $entry[2] =~ s/^\Q$solarversion\E\///;
1169    # strip minor from 'to'
1170    my $ext = "%_EXT%";
1171    $ext = expand_macros($ext);
1172    $entry[2] =~ s#$ext([\\\/])#$1#o;
1173
1174    if ( $common ) {
1175        push @common_log_list, [@entry];
1176    } else {
1177        push @log_list, [@entry];
1178    }
1179    return 1;
1180}
1181
1182sub zip_files
1183{
1184    my $zipexe = 'zip';
1185    $zipexe .= ' -y' unless  $^O eq 'MSWin32';
1186
1187    my ($platform_zip_file, $common_zip_file);
1188    $platform_zip_file = "%_DEST%/zip%_EXT%/$module.zip";
1189    $platform_zip_file = expand_macros($platform_zip_file);
1190    my (%dest_dir, %list_ref);
1191    $dest_dir{$platform_zip_file} = $dest;
1192    $list_ref{$platform_zip_file} = \@zip_list;
1193    if ( $common_build ) {
1194        $common_zip_file = "%COMMON_DEST%/zip%_EXT%/$module.zip";
1195        $common_zip_file = expand_macros($common_zip_file);
1196        $dest_dir{$common_zip_file}   = $common_dest;
1197        $list_ref{$common_zip_file}   = \@common_zip_list;
1198    }
1199
1200    my $ext = "%_EXT%";
1201    $ext = expand_macros($ext);
1202
1203    my @zipfiles;
1204    $zipfiles[0] = $platform_zip_file;
1205    if ( $common_build ) {
1206        push @zipfiles, ($common_zip_file);
1207    }
1208    foreach my $zip_file ( @zipfiles ) {
1209        print "ZIP: updating $zip_file\n" if $opt_verbose;
1210        next if ( $opt_check );
1211
1212        if ( $opt_delete ) {
1213            if ( -e $zip_file ) {
1214                unlink $zip_file or die "Error: can't remove file '$zip_file': $!";
1215            }
1216            next;
1217        }
1218
1219        local $work_file = "";
1220        if ( $zip_file eq $common_zip_file) {
1221            # Zip file in common tree: work on uniq copy to avoid collisions
1222            $work_file = $zip_file;
1223            $work_file =~ s/\.zip$//;
1224            $work_file .= (sprintf('.%d-%d', $$, time())) . ".zip";
1225            die "Error: temp file $work_file already exists" if ( -e $work_file);
1226            if ( -e $zip_file ) {
1227                if ( -z $zip_file) {
1228                    # sometimes there are files of 0 byte size - remove them
1229                    unlink $zip_file or print_error("can't remove empty file '$zip_file': $!",0);
1230                } else {
1231                    if ( ! copy($zip_file, $work_file)) {
1232                        # give a warning, not an error:
1233                        # we can zip from scratch instead of just updating the old zip file
1234                        print_warning("can't copy'$zip_file' into '$work_file': $!", 0);
1235                        unlink $work_file;
1236                    }
1237                }
1238            }
1239        } else {
1240            # No pre processing necessary, working directly on solver.
1241            $work_file = $zip_file;
1242        }
1243
1244        # zip content has to be relative to $dest_dir
1245        chdir($dest_dir{$zip_file}) or die "Error: cannot chdir into $dest_dir{$zip_file}";
1246        my $this_ref = $list_ref{$zip_file};
1247        open(ZIP, "| $zipexe -q -o -u -@ $work_file") or die "error opening zip file";
1248        foreach $file ( @$this_ref ) {
1249            print "ZIP: adding $file to $zip_file\n" if $is_debug;
1250            print ZIP "$file\n";
1251        }
1252        close(ZIP);
1253        fix_broken_cygwin_created_zips($work_file) if $^O eq "cygwin";
1254
1255        if ( $zip_file eq $common_zip_file) {
1256            # rename work file back
1257            if ( -e $work_file ) {
1258                if ( -e $zip_file) {
1259                    # do some tricks to be fast. otherwise we may disturb other platforms
1260                    # by unlinking a file which just gets copied -> stale file handle.
1261                    my $buffer_file=$work_file . '_rm';
1262                    rename($zip_file, $buffer_file) or warn "Warning: can't rename old zip file '$zip_file': $!";
1263                    if (! rename($work_file, $zip_file)) {
1264                        print_error("can't rename temporary file to $zip_file: $!",0);
1265                        unlink $work_file;
1266                    }
1267                    unlink $buffer_file;
1268                } else {
1269                    if (! rename($work_file, $zip_file)) {
1270                        print_error("can't rename temporary file to $zip_file: $!",0);
1271                        unlink $work_file;
1272                    }
1273                }
1274            }
1275        }
1276    }
1277}
1278
1279sub fix_broken_cygwin_created_zips
1280# add given extension to or strip it from stored path
1281{
1282    require Archive::Zip; import Archive::Zip;
1283    my $zip_file = shift;
1284
1285    $zip = Archive::Zip->new();
1286    unless ( $zip->read($work_file) == AZ_OK ) {
1287        die "Error: can't open zip file '$zip_file' to fix broken cygwin file permissions";
1288    }
1289    my $latest_member_mod_time = 0;
1290    foreach $member ( $zip->members() ) {
1291        my $attributes = $member->unixFileAttributes();
1292        $attributes &= ~0xFE00;
1293        print $member->fileName() . ": " . sprintf("%lo", $attributes) if $is_debug;
1294        $attributes |= 0x10; # add group write permission
1295        print "-> " . sprintf("%lo", $attributes) . "\n" if $is_debug;
1296        $member->unixFileAttributes($attributes);
1297        if ( $latest_member_mod_time < $member->lastModTime() ) {
1298            $latest_member_mod_time = $member->lastModTime();
1299        }
1300    }
1301    die "Error: can't overwrite zip file '$zip_file' for fixing permissions" unless $zip->overwrite() == AZ_OK;
1302    utime($latest_member_mod_time, $latest_member_mod_time, $zip_file);
1303}
1304
1305sub get_tempfilename
1306{
1307    my $temp_dir = shift;
1308    $temp_dir = ( -d '/tmp' ? '/tmp' : $ENV{TMPDIR} || $ENV{TEMP} || '.' )
1309            unless defined($temp_dir);
1310 	if ( ! -d $temp_dir ) {
1311        die "no temp directory $temp_dir\n";
1312    }
1313    my $base_name = sprintf( "%d-%di-%d", $$, time(), $tempcounter++ );
1314    return "$temp_dir/$base_name";
1315}
1316
1317sub write_log
1318{
1319    my (%log_file, %file_date);
1320    $log_file{\@log_list} = "%_DEST%/inc%_EXT%/$module/deliver.log";
1321    $log_file{\@common_log_list} = "%COMMON_DEST%/inc%_EXT%/$module/deliver.log";
1322    $file_date{\@log_list} = $logfiledate;
1323    $file_date{\@common_log_list} = $commonlogfiledate;
1324
1325    my @logs = ( \@log_list );
1326    push @logs, ( \@common_log_list ) if ( $common_build );
1327    foreach my $log ( @logs ) {
1328        $log_file{$log} = expand_macros( $log_file{$log} );
1329        if ( $opt_delete ) {
1330            print "LOG: removing $log_file{$log}\n" if $opt_verbose;
1331            next if ( $opt_check );
1332            unlink $log_file{$log};
1333        } else {
1334            print "LOG: writing $log_file{$log}\n" if $opt_verbose;
1335            next if ( $opt_check );
1336            open( LOGFILE, "> $log_file{$log}" ) or warn "Error: could not open log file.";
1337            foreach my $item ( @$log ) {
1338                print LOGFILE "@$item\n";
1339            }
1340            close( LOGFILE );
1341            utime($file_date{$log}, $file_date{$log}, $log_file{$log});
1342        }
1343        push_on_ziplist( $log_file{$log} ) if $opt_zip;
1344    }
1345    return;
1346}
1347
1348sub check_dlst
1349{
1350    my %createddir;
1351    my %destdir;
1352    my %destfile;
1353    # get all checkable actions to perform
1354    foreach my $action ( @action_data ) {
1355        my $path = expand_macros( $$action[1] );
1356        if ( $$action[0] eq 'mkdir' ) {
1357            $createddir{$path} ++;
1358        } elsif (( $$action[0] eq 'copy' ) || ( $$action[0] eq 'addincpath' )) {
1359            my ($from, $to) = split(' ', $path);
1360            my ($to_fname, $to_dir);
1361            my $withwildcard = 0;
1362            if ( $from =~ /[\*\?\[\]]/ ) {
1363                $withwildcard = 1;
1364            }
1365            ($to_fname, $to_dir) = fileparse($to);
1366            if ( $withwildcard ) {
1367                if ( $to !~ /[\*\?\[\]]/ ) {
1368                    $to_dir = $to;
1369                    $to_fname ='';
1370                }
1371            }
1372            $to_dir =~ s/[\\\/\s]$//;
1373            $destdir{$to_dir} ++;
1374            # Check: copy into non existing directory?
1375            if ( ! $createddir{$to_dir} ) {
1376                # unfortunately it is not so easy: it's OK if a subdirectory of $to_dir
1377                # gets created, because mkpath creates the whole tree
1378                foreach my $directory ( keys %createddir ) {
1379                    if ( $directory =~ /^\Q$to_dir\E[\\\/]/ ) {
1380                        $createddir{$to_dir} ++;
1381                        last;
1382                    }
1383                }
1384                print_warning("Possibly copying into directory without creating in before: '$to_dir'")
1385                    unless $createddir{$to_dir};
1386            }
1387            # Check: overwrite file?
1388            if ( ! $to ) {
1389                if ( $destfile{$to} ) {
1390                    print_warning("Multiple entries copying to '$to'");
1391                }
1392                $destfile{$to} ++;
1393            }
1394        }
1395    }
1396}
1397
1398sub cleanup
1399{
1400    # remove empty directories
1401    foreach my $path ( @dirlist ) {
1402        $path = expand_macros($path);
1403        if ( $opt_check ) {
1404            print "RMDIR: $path\n" if $opt_verbose;
1405        } else {
1406            rmdir $path;
1407        }
1408    }
1409}
1410
1411sub delete_output
1412{
1413    my $output_path = expand_macros("../%__SRC%");
1414    if ( "$output_path" ne "../" ) {
1415        if ( rmtree([$output_path], 0, 1) ) {
1416            print "Deleted output tree.\n" if $opt_verbose;
1417        }
1418        else {
1419            print_error("Error deleting output tree $output_path: $!",0);
1420        }
1421    }
1422    else {
1423        print_error("Output not deleted - INPATH is not set");
1424    }
1425}
1426
1427sub print_warning
1428{
1429    my $message = shift;
1430    my $line = shift;
1431
1432    print STDERR "$script_name: ";
1433    if ( $dlst_file ) {
1434        print STDERR "$dlst_file: ";
1435    }
1436    if ( $line ) {
1437        print STDERR "line $line: ";
1438    }
1439    print STDERR "WARNING: $message\n";
1440}
1441
1442sub print_error
1443{
1444    my $message = shift;
1445    my $line = shift;
1446
1447    print STDERR "$script_name: ";
1448    if ( $dlst_file ) {
1449        print STDERR "$dlst_file: ";
1450    }
1451    if ( $line ) {
1452        print STDERR "line $line: ";
1453    }
1454    print STDERR "ERROR: $message\n";
1455    $error ++;
1456}
1457
1458sub print_stats
1459{
1460    print "Module '$module' delivered ";
1461    if ( $error ) {
1462        print "with errors\n";
1463    } else {
1464        print "successfully.";
1465        if ( $opt_delete ) {
1466            print " $files_copied files removed,";
1467        }
1468        else {
1469            print " $files_copied files copied,";
1470        }
1471        print " $files_unchanged files unchanged\n";
1472    }
1473}
1474
1475sub cleanup_and_die
1476{
1477    # clean up on unexpected termination
1478    my $sig = shift;
1479    if ( defined($temp_file) && -e $temp_file ) {
1480        unlink($temp_file);
1481    }
1482    if ( defined($work_file) && -e $work_file ) {
1483        unlink($work_file);
1484        print STDERR "$work_file removed\n";
1485    }
1486
1487    die "caught unexpected signal $sig, terminating ...";
1488}
1489
1490sub usage
1491{
1492    my $exit_code = shift;
1493    print STDERR "Usage:\ndeliver [OPTIONS] [DESTINATION-PATH]\n";
1494    print STDERR "Options:\n";
1495    print STDERR "  -check       just print what would happen, no actual copying of files\n";
1496    print STDERR "  -checkdlst   be verbose about (possible) d.lst bugs\n";
1497    print STDERR "  -delete      delete files (undeliver), use with care\n";
1498    print STDERR "  -deloutput   remove the output tree after copying\n";
1499    print STDERR "  -dontdeletecommon do not delete common files (for -delete option)\n";
1500    print STDERR "  -force       copy even if not newer\n";
1501    print STDERR "  -help        print this message\n";
1502    if ( !defined($ENV{GUI}) || $ENV{GUI} ne 'WNT' ) {
1503        print STDERR "  -link        hard link files into the solver to save disk space\n";
1504    }
1505    print STDERR "  -quiet       be quiet, only report errors\n";
1506    print STDERR "  -verbose     be verbose\n";
1507    print STDERR "  -zip         additionally create zip files of delivered content\n";
1508    print STDERR "Options '-zip' and a destination-path are mutually exclusive.\n";
1509    print STDERR "Options '-check' and '-quiet' are mutually exclusive.\n";
1510    exit($exit_code);
1511}
1512
1513# vim: set ts=4 shiftwidth=4 expandtab syntax=perl:
1514