solenv/bin/deliver.pl

   1 :
   2 eval 'exec perl -wS $0 ${1+"$@"}'
   3     if 0;
   4 #*************************************************************************
   5 #
   6 # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   7 #
   8 # Copyright 2008 by Sun Microsystems, Inc.
   9 #
  10 # OpenOffice.org - a multi-platform office productivity suite
  11 #
  12 # $RCSfile: deliver.pl,v $
  13 #
  14 # $Revision$
  15 #
  16 # This file is part of OpenOffice.org.
  17 #
  18 # OpenOffice.org is free software: you can redistribute it and/or modify
  19 # it under the terms of the GNU Lesser General Public License version 3
  20 # only, as published by the Free Software Foundation.
  21 #
  22 # OpenOffice.org is distributed in the hope that it will be useful,
  23 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  24 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  25 # GNU Lesser General Public License version 3 for more details
  26 # (a copy is included in the LICENSE file that accompanied this code).
  27 #
  28 # You should have received a copy of the GNU Lesser General Public License
  29 # version 3 along with OpenOffice.org.  If not, see
  30 # <http://www.openoffice.org/license.html>
  31 # for a copy of the LGPLv3 License.
  32 #
  33 #*************************************************************************
  34
  35 #
  36 # deliver.pl - copy from module output tree to solver
  37 #
  38
  39 use Cwd;
  40 use File::Basename;
  41 use File::Copy;
  42 use File::DosGlob 'glob';
  43 use File::Path;
  44 use File::Spec;
  45
  46 #### script id #####
  47
  48 ( $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;
  49
  50 $id_str = ' $Revision$ ';
  51 $id_str =~ /Revision:\s+(\S+)\s+\$/
  52   ? ($script_rev = $1) : ($script_rev = "-");
  53
  54
  55 #### globals ####
  56
  57 ### valid actions ###
  58 # if you add a action 'foo', than add 'foo' to this list and
  59 # implement 'do_foo()' in the implemented actions area
  60 @action_list        =   (           # valid actions
  61                         'copy',
  62                         'dos',
  63                         'addincpath',
  64                         'linklib',
  65                         'mkdir',
  66                         'symlink',
  67                         'touch'
  68                         );
  69
  70 # copy filter: files matching these patterns won't be copied by
  71 # the copy action
  72 @copy_filter_patterns = (
  73                         );
  74
  75 $strip              = '';
  76 $is_debug           = 0;
  77
  78 $error              = 0;
  79 $module             = 0;            # module name
  80 $base_dir           = 0;            # path to module base directory
  81 $dlst_file          = 0;            # path to d.lst
  82 $ilst_ext           = 'ilst';       # extension of image lists
  83 $umask              = 22;           # default file/directory creation mask
  84 $dest               = 0;            # optional destination path
  85 $common_build       = 0;            # do we have common trees?
  86 $common_dest        = 0;            # common tree on solver
  87
  88 @action_data        = ();           # LoL with all action data
  89 @macros             = ();           # d.lst macros
  90 @addincpath_list    = ();           # files which have to be filtered through addincpath
  91 @dirlist            = ();           # List of 'mkdir' targets
  92 @zip_list           = ();           # files which have to be zipped
  93 @common_zip_list    = ();           # common files which have to be zipped
  94 @log_list           = ();           # LoL for logging all copy and link actions
  95 @common_log_list    = ();           # LoL for logging all copy and link actions in common_dest
  96 $logfiledate        = 0;            # Make log file as old as newest delivered file
  97 $commonlogfiledate  = 0;            # Make log file as old as newest delivered file
  98
  99 $files_copied       = 0;            # statistics
 100 $files_unchanged    = 0;            # statistics
 101
 102 $opt_force          = 0;            # option force copy
 103 $opt_minor          = 0;            # option deliver in minor
 104 $opt_check          = 0;            # do actually execute any action
 105 $opt_zip            = 0;            # create an additional zip file
 106 $opt_silent         = 0;            # be silent, only report errors
 107 $opt_verbose        = 0;            # be verbose (former default behaviour)
 108 $opt_log            = 1;            # create an additional log file
 109 $opt_link           = 0;            # hard link files into the solver to save disk space
 110 $opt_deloutput      = 0;            # delete the output tree for the project once successfully delivered
 111 $opt_checkdlst      = 0;
 112 $delete_common      = 1;            # for "-delete": if defined delete files from common tree also
 113
 114 if ($^O ne 'cygwin') {              # iz59477 - cygwin needes a dot "." at the end of filenames to disable
 115   $maybedot     = '';               # some .exe transformation magic.
 116 } else {
 117   $maybedot     = '.';
 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
 128 for (@action_list) {
 129     $action_hash{$_}++;
 130 }
 131
 132 # trap normal signals (HUP, INT, PIPE, TERM)
 133 # for clean up on unexpected termination
 134 use sigtrap 'handler' => \&cleanup_and_die, 'normal-signals';
 135
 136 #### main ####
 137
 138 parse_options();
 139
 140 print "$script_name -- version: $script_rev\n" if !$opt_silent;
 141
 142 if ( ! $opt_delete ) {
 143     if ( $ENV{GUI} eq 'WNT' ) {
 144         if ($ENV{COM} eq 'GCC') {
 145             initialize_strip() ;
 146         };
 147     } else {
 148         initialize_strip();
 149     }
 150 }
 151
 152 init_globals();
 153 push_default_actions();
 154 parse_dlst();
 155 check_dlst() if $opt_checkdlst;
 156 walk_action_data();
 157 walk_addincpath_list();
 158 write_log() if $opt_log;
 159 zip_files() if $opt_zip;
 160 cleanup() if $opt_delete;
 161 delete_output() if $opt_deloutput;
 162 print_stats();
 163
 164 exit($error);
 165
 166 #### implemented actions #####
 167
 168 sub 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
 194 sub 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 labled 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
 211 sub 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
 224 sub 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
 319 sub 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
 336 sub 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
 385 sub 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
 399 sub parse_options
 400 {
 401     my $arg;
 402     my $dontdeletecommon = 0;
 403     $opt_silent = 1 if ( !defined $ENV{VERBOSE} || (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 =~ /^-minor$/      and $opt_minor  = 1  and next;
 408         $arg =~ /^-check$/      and $opt_check  = 1  and $opt_verbose = 1 and next;
 409         $arg =~ /^-quiet$/      and $opt_silent = 1  and next;
 410         $arg =~ /^-verbose$/    and $opt_verbose = 1 and next;
 411         $arg =~ /^-zip$/        and $opt_zip    = 1  and next;
 412         $arg =~ /^-delete$/     and $opt_delete = 1  and next;
 413         $arg =~ /^-dontdeletecommon$/ and $dontdeletecommon = 1 and next;
 414         $arg =~ /^-help$/       and $opt_help   = 1  and $arg = '';
 415         $arg =~ /^-link$/       and $ENV{GUI} ne 'WNT' and $opt_link = 1 and next;
 416         $arg =~ /^-deloutput$/  and $opt_deloutput = 1 and next;
 417         $arg =~ /^-debug$/      and $is_debug   = 1  and next;
 418         $arg =~ /^-checkdlst$/  and $opt_checkdlst = 1 and next;
 419         print_error("invalid option $arg") if ( $arg =~ /^-/ );
 420         if ( $arg =~ /^-/ || $opt_help || $#ARGV > -1 ) {
 421             usage(1);
 422         }
 423         $dest = $arg;
 424     }
 425     # $dest and $opt_zip or $opt_delete are mutually exclusive
 426     if ( $dest and ($opt_zip || $opt_delete) ) {
 427         usage(1);
 428     }
 429     # $opt_silent and $opt_check or $opt_verbose are mutually exclusive
 430     if ( ($opt_check or $opt_verbose) and $opt_silent ) {
 431         print STDERR "Error on command line: options '-check' and '-quiet' are mutually exclusive.\n";
 432         usage(1);
 433     }
 434     if ($dontdeletecommon) {
 435         if (!$opt_delete) {
 436             usage(1);
 437         }
 438         $delete_common = 0;
 439     };
 440     # $opt_delete implies $opt_force
 441     $opt_force = 1 if $opt_delete;
 442 }
 443
 444 sub init_globals
 445 {
 446     my $ext;
 447     ($module, $base_dir, $dlst_file) =  get_base();
 448
 449     # for CWS:
 450     $module =~ s/\.lnk$//;
 451
 452     print "Module=$module, Base_Dir=$base_dir, d.lst=$dlst_file\n" if $is_debug;
 453
 454     $umask = umask();
 455     if ( !defined($umask) ) {
 456         $umask = 22;
 457     }
 458
 459     my $build_sosl    = $ENV{'BUILD_SOSL'};
 460     my $common_outdir = $ENV{'COMMON_OUTDIR'};
 461     my $inpath        = $ENV{'INPATH'};
 462     my $solarversion  = $ENV{'SOLARVERSION'};
 463     my $updater       = $ENV{'UPDATER'};
 464     my $updminor      = $ENV{'UPDMINOR'};
 465     my $work_stamp    = $ENV{'WORK_STAMP'};
 466
 467     # special security check for release engineers
 468     if ( defined($updater) && !defined($build_sosl) && !$opt_force) {
 469         my $path = getcwd();
 470         if ( $path !~ /$work_stamp/io ) {
 471             print_error("can't deliver from local directory to SOLARVERSION");
 472             print STDERR "\nDANGER! Release Engineer:\n";
 473             print STDERR "do you really want to deliver from $path to SOLARVERSION?\n";
 474             print STDERR "If so, please use the -force switch\n\n";
 475             exit(7);
 476         }
 477     }
 478
 479     # do we have a valid environment?
 480     if ( !defined($inpath) ) {
 481             print_error("no environment", 0);
 482             exit(3);
 483     }
 484
 485     $ext = "";
 486     if ( ($opt_minor || $updminor) && !$dest ) {
 487         if ( $updminor ) {
 488             $ext = ".$updminor";
 489         }
 490         else {
 491             print_error("can't determine UPDMINOR", 0);
 492             exit(3);
 493         }
 494     }
 495
 496     # Do we have common trees?
 497     if ( defined($ENV{'common_build'}) && $ENV{'common_build'} eq 'TRUE' ) {
 498         $common_build = 1;
 499         if ((defined $common_outdir) && ($common_outdir ne "")) {
 500             $common_outdir = $common_outdir . ".pro" if $inpath =~ /\.pro$/;
 501             if ( $dest ) {
 502                 $common_dest = $dest;
 503             } else {
 504                 $common_dest = "$solarversion/$common_outdir";
 505                 $dest = "$solarversion/$inpath";
 506             }
 507         } else {
 508             print_error("common_build defined without common_outdir", 0);
 509             exit(6);
 510         }
 511     } else {
 512         $common_outdir = $inpath;
 513         $dest = "$solarversion/$inpath" if ( !$dest );
 514         $common_dest = $dest;
 515     }
 516     $dest =~ s#\\#/#g;
 517     $common_dest =~ s#\\#/#g;
 518
 519     # the following macros are obsolete, will be flagged as error
 520     # %__WORKSTAMP%
 521     # %GUIBASE%
 522     # %SDK%
 523     # %SOLARVER%
 524     # %__OFFENV%
 525     # %DLLSUFFIX%'
 526     # %OUTPATH%
 527     # %L10N_FRAMEWORK%
 528     # %UPD%
 529
 530     # valid macros
 531     @macros = (
 532                 [ '%__PRJROOT%',        $base_dir       ],
 533                 [ '%__SRC%',            $inpath         ],
 534                 [ '%_DEST%',            $dest           ],
 535                 [ '%_EXT%',             $ext            ],
 536                 [ '%COMMON_OUTDIR%',    $common_outdir  ],
 537                 [ '%COMMON_DEST%',      $common_dest    ],
 538                 [ '%GUI%',              $gui            ]
 539               );
 540
 541     # find out if the system supports symlinks
 542     $has_symlinks = eval { symlink("",""); 1 };
 543 }
 544
 545 sub get_base
 546 {
 547     # a module base dir contains a subdir 'prj'
 548     # which in turn contains a file 'd.lst'
 549     my (@field, $base, $dlst);
 550     my $path = getcwd();
 551
 552     @field = split(/\//, $path);
 553
 554     while ( $#field != -1 ) {
 555         $base = join('/', @field);
 556         $dlst = $base . '/prj/d.lst';
 557         last if -e $dlst;
 558         pop @field;
 559     }
 560
 561     if ( $#field == -1 ) {
 562         print_error("can't determine module");
 563         exit(2);
 564     }
 565     else {
 566         return ($field[-1], $base, $dlst);
 567     }
 568 }
 569
 570 sub parse_dlst
 571 {
 572     my $line_cnt = 0;
 573     open(DLST, "<$dlst_file") or die "can't open d.lst";
 574     while(<DLST>) {
 575         $line_cnt++;
 576         tr/\r\n//d;
 577         next if /^#/;
 578         next if /^\s*$/;
 579         if (!$delete_common && /%COMMON_DEST%/) {
 580             # Just ignore all lines with %COMMON_DEST%
 581             next;
 582         };
 583         if ( /^\s*(\w+?):\s+(.*)$/ ) {
 584             if ( !exists $action_hash{$1} ) {
 585                 print_error("unknown action: \'$1\'", $line_cnt);
 586                 exit(4);
 587             }
 588             push(@action_data, [$1, $2]);
 589         }
 590         else {
 591             if ( /^\s*%(COMMON)?_DEST%\\/ ) {
 592                 # only copy from source dir to solver, not from solver to solver
 593                 print_warning("illegal copy action, ignored: \'$_\'", $line_cnt);
 594                 next;
 595             }
 596             push(@action_data, ['copy', $_]);
 597             # for each ressource file (.res) copy its image list (.ilst)
 598             if ( /\.res\s/ ) {
 599                 my $imagelist = $_;
 600                 $imagelist =~ s/\.res/\.$ilst_ext/g;
 601                 $imagelist =~ s/\\bin%_EXT%\\/\\res%_EXT%\\img\\/;
 602                 push(@action_data, ['copy', $imagelist]);
 603             }
 604         }
 605         # call expand_macros()just to find any undefined macros early
 606         # real expansion is done later
 607         expand_macros($_, $line_cnt);
 608     }
 609     close(DLST);
 610 }
 611
 612 sub expand_macros
 613 {
 614     # expand all macros and change backslashes to slashes
 615     my $line        = shift;
 616     my $line_cnt    = shift;
 617     my $i;
 618
 619     for ($i=0; $i<=$#macros; $i++)  {
 620         $line =~ s/$macros[$i][0]/$macros[$i][1]/gi
 621     }
 622     if ( $line =~ /(%\w+%)/ ) {
 623         if ( $1 ne '%OS%' ) {   # %OS% looks like a macro but is not ...
 624             print_error("unknown/obsolete macro: \'$1\'", $line_cnt);
 625         }
 626     }
 627     $line =~ s#\\#/#g;
 628     return $line;
 629 }
 630
 631 sub walk_action_data
 632 {
 633     # all actions have to be excuted relative to the prj directory
 634     chdir("$base_dir/prj");
 635     # dispatch depending on action type
 636     for (my $i=0; $i <= $#action_data; $i++) {
 637             &{"do_".$action_data[$i][0]}($action_data[$i][1]);
 638             if ( $action_data[$i][0] eq 'mkdir' ) {
 639                 # fill array with (possibly) created directories in
 640                 # revers order for removal in 'cleanup'
 641                 unshift @dirlist, $action_data[$i][1];
 642             }
 643     }
 644 }
 645
 646 sub glob_line
 647 {
 648     my $from = shift;
 649     my $to = shift;
 650     my $to_dir = shift;
 651     my $replace = 0;
 652     my @globbed_files = ();
 653
 654     if ( ! ( $from && $to ) ) {
 655         print_warning("Error in d.lst? source: '$from' destination: '$to'");
 656         return \@globbed_files;
 657     }
 658
 659     if ( $to =~ /[\*\?\[\]]/ ) {
 660         my $to_fname;
 661         ($to_fname, $to_dir) = fileparse($to);
 662         $replace = 1;
 663     }
 664
 665     if ( $from =~ /[\*\?\[\]]/ ) {
 666         # globbing necessary, no renaming possible
 667         my $file;
 668         my @file_list = glob($from);
 669
 670         foreach $file ( @file_list ) {
 671             my ($fname, $dir) = fileparse($file);
 672             my $copy = ($replace) ? $to_dir . $fname : $to . '/' . $fname;
 673             push(@globbed_files, [$file, $copy]);
 674         }
 675     }
 676     else {
 677         # no globbing but renaming possible
 678         push(@globbed_files, [$from, $to]);
 679     }
 680     if ( $opt_checkdlst ) {
 681         my $outtree = expand_macros("%__SRC%");
 682         my $commonouttree = expand_macros("%COMMON_OUTDIR%");
 683         if (( $from !~ /\Q$outtree\E/ ) && ( $from !~ /\Q$commonouttree\E/ )) {
 684             print_warning("'$from' does not match any file") if ( $#globbed_files == -1 );
 685         }
 686     }
 687     return \@globbed_files;
 688 }
 689
 690
 691 sub glob_and_copy
 692 {
 693     my $from = shift;
 694     my $to = shift;
 695     my $touch = shift;
 696
 697     my @copy_files = @{glob_line($from, $to)};
 698
 699     for (my $i = 0; $i <= $#copy_files; $i++) {
 700         next if filter_out($copy_files[$i][0]); # apply copy filter
 701         copy_if_newer($copy_files[$i][0], $copy_files[$i][1], $touch)
 702                     ? $files_copied++ : $files_unchanged++;
 703     }
 704 }
 705
 706 sub is_unstripped {
 707     my $file_name = shift;
 708     my $nm_output;
 709
 710     if (-f $file_name.$maybedot) {
 711         my $file_type = `file $file_name`;
 712         # OS X file command doesn't know if a file is stripped or not
 713         if (($file_type =~ /not stripped/o) || ($file_type =~ /Mach-O/o) ||
 714             (($file_type =~ /PE/o) && ($ENV{GUI} eq 'WNT') &&
 715              ($nm_output = `nm $file_name 2>&1`) && $nm_output &&
 716              !($nm_output =~ /no symbols/i) && !($nm_output =~ /not recognized/i))) {
 717             return '1' if ($file_name =~ /\.bin$/o);
 718             return '1' if ($file_name =~ /\.so\.*/o);
 719             return '1' if ($file_name =~ /\.dylib\.*/o);
 720             return '1' if ($file_name =~ /\.com\.*/o);
 721             return '1' if ($file_name =~ /\.dll\.*/o);
 722             return '1' if ($file_name =~ /\.exe\.*/o);
 723             return '1' if (basename($file_name) !~ /\./o);
 724         }
 725     };
 726     return '';
 727 }
 728
 729 sub initialize_strip {
 730     if ((!defined $ENV{DISABLE_STRIP}) || ($ENV{DISABLE_STRIP} eq "")) {
 731         $strip .= 'guw ' if ($^O eq 'cygwin');
 732         $strip .= 'strip';
 733         $strip .= " -x" if ($ENV{OS} eq 'MACOSX');
 734         $strip .= " -R '.comment' -s" if ($ENV{OS} eq 'LINUX');
 735     };
 736 };
 737
 738 sub is_jar {
 739     my $file_name = shift;
 740
 741     if (-f $file_name && (( `file $file_name` ) =~ /Zip archive/o)) {
 742         return '1' if ($file_name =~ /\.jar\.*/o);
 743     };
 744     return '';
 745 }
 746
 747 sub execute_system {
 748     my $command = shift;
 749     if (system($command)) {
 750         print_error("Failed to execute $command");
 751         exit($?);
 752     };
 753 };
 754
 755 sub strip_target {
 756     my $file = shift;
 757     my $temp_file = shift;
 758     $temp_file =~ s/\/{2,}/\//g;
 759     my $rc = copy($file, $temp_file);
 760     execute_system("$strip $temp_file");
 761     return $rc;
 762 };
 763
 764 sub copy_if_newer
 765 {
 766     # return 0 if file is unchanged ( for whatever reason )
 767     # return 1 if file has been copied
 768     my $from = shift;
 769     my $to = shift;
 770     my $touch = shift;
 771     my $from_stat_ref;
 772     my $rc = 0;
 773
 774     print "testing $from, $to\n" if $is_debug;
 775     push_on_ziplist($to) if $opt_zip;
 776     push_on_loglist("COPY", "$from", "$to") if $opt_log;
 777     return 0 unless ($from_stat_ref = is_newer($from, $to, $touch));
 778
 779     if ( $opt_delete ) {
 780         print "REMOVE: $to\n" if $opt_verbose;
 781         $rc = unlink($to) unless $opt_check;
 782         # handle special packaging of *.dylib files for Mac OS X
 783         if ( $to =~ s/\.dylib$/.jnilib/ ) {
 784             print "REMOVE: $to\n" if $opt_verbose;
 785             $rc += unlink "$to" unless $opt_check;
 786         }
 787         return 1 if $opt_check;
 788         return $rc;
 789     }
 790
 791     if( !$opt_check && $opt_link ) {
 792         # hard link if possible
 793         if( link($from, $to) ){
 794             print "LINK: $from -> $to\n" if $opt_verbose;
 795             return 1;
 796         }
 797     }
 798
 799     if( $touch ) {
 800        print "TOUCH: $from -> $to\n" if $opt_verbose;
 801     }
 802     else {
 803        print "COPY: $from -> $to\n" if $opt_verbose;
 804     }
 805
 806     return 1 if( $opt_check );
 807
 808     #
 809     # copy to temporary file first and rename later
 810     # to minimize the possibility for race conditions
 811     local $temp_file = sprintf('%s.%d-%d', $to, $$, time());
 812     $rc = '';
 813     if (($strip ne '') && (defined $ENV{PROEXT}) && (is_unstripped($from))) {
 814         $rc = strip_target($from, $temp_file);
 815     } else {
 816         $rc = copy($from, $temp_file);
 817     };
 818     if ( $rc) {
 819         if ( is_newer($temp_file, $from, 0) ) {
 820             $rc = utime($$from_stat_ref[9], $$from_stat_ref[9], $temp_file);
 821             if ( !$rc ) {
 822                 print_warning("can't update temporary file modification time '$temp_file': $!\n
 823                                Check file permissions of '$from'.",0);
 824             }
 825         }
 826         fix_file_permissions($$from_stat_ref[2], $temp_file);
 827         if ( $^O eq 'os2' )
 828         {
 829             $rc = unlink($to); # YD OS/2 can't rename if $to exists!
 830         }
 831         # Ugly hack: on windows file locking(?) sometimes prevents renaming.
 832         # Until we've found and fixed the real reason try it repeatedly :-(
 833         my $try = 0;
 834         my $maxtries = 1;
 835         $maxtries = 5 if ( $^O eq 'MSWin32' );
 836         my $success = 0;
 837         while ( $try < $maxtries && ! $success ) {
 838             sleep $try;
 839             $try ++;
 840             $success = rename($temp_file, $to);
 841         }
 842         if ( $success ) {
 843             # handle special packaging of *.dylib files for Mac OS X
 844             if ( $^O eq 'darwin' )
 845             {
 846                 if ( $to =~ /\.dylib/ ) {
 847                     system("macosx-create-bundle", $to);
 848                     my $bundlelib = $to;
 849                     $bundlelib =~ s/\.dylib$//;
 850                     $bundlelib .= ".jnilib";
 851                     if ( $opt_delete ) {
 852                         print "REMOVE: $bundlelib\n" if $opt_verbose;
 853                         unlink "$bundlelib" unless $opt_check;
 854                     } else {
 855                         push_on_ziplist($bundlelib) if $opt_zip;
 856                         push_on_loglist("LINK", basename($to), "$bundlelib") if $opt_log;
 857                     }
 858                 }
 859                 system("macosx-create-bundle", "$to=$from.app") if ( -d "$from.app" );
 860                 system("ranlib", "$to" ) if ( $to =~ /\.a/ );
 861             }
 862             if ( $try > 1 ) {
 863                 print_warning("File '$to' temporarily locked. Dependency bug?");
 864             }
 865             return 1;
 866         }
 867         else {
 868             print_error("can't rename temporary file to $to: $!",0);
 869         }
 870     }
 871     else {
 872         print_error("can't copy $from: $!",0);
 873         my $destdir = dirname($to);
 874         if ( ! -d $destdir ) {
 875             print_error("directory '$destdir' does not exist", 0);
 876         }
 877     }
 878     unlink($temp_file);
 879     return 0;
 880 }
 881
 882 sub is_newer
 883 {
 884         # returns whole stat buffer if newer
 885         my $from = shift;
 886         my $to = shift;
 887         my $touch = shift;
 888         my (@from_stat, @to_stat);
 889
 890         @from_stat = stat($from.$maybedot);
 891         if ( $opt_checkdlst ) {
 892             my $outtree = expand_macros("%__SRC%");
 893             my $commonouttree = expand_macros("%COMMON_OUTDIR%");
 894             if ( $from !~ /$outtree/ ) {
 895                 if ( $from !~ /$commonouttree/ ) {
 896                     print_warning("'$from' does not exist") unless -e _;
 897                 }
 898             }
 899         }
 900         return 0 unless -f _;
 901
 902         if ( $touch ) {
 903             $from_stat[9] = time();
 904         }
 905         # adjust timestamps to even seconds
 906         # this is necessary since NT platforms have a
 907         # 2s modified time granularity while the timestamps
 908         # on Samba volumes have a 1s granularity
 909
 910         $from_stat[9]-- if $from_stat[9] % 2;
 911
 912         if ( $to =~ /^\Q$dest\E/ ) {
 913             if ( $from_stat[9] > $logfiledate ) {
 914                 $logfiledate = $from_stat[9];
 915             }
 916         } elsif ( $common_build && ( $to =~ /^\Q$common_dest\E/ ) ) {
 917             if ( $from_stat[9] > $commonlogfiledate ) {
 918                 $commonlogfiledate = $from_stat[9];
 919             }
 920         }
 921
 922         @to_stat = stat($to.$maybedot);
 923         return \@from_stat unless -f _;
 924
 925         if ( $opt_force ) {
 926             return \@from_stat;
 927         }
 928         else {
 929             return ($from_stat[9] > $to_stat[9]) ? \@from_stat : 0;
 930         }
 931 }
 932
 933 sub filter_out
 934 {
 935     my $file = shift;
 936
 937     foreach my $pattern ( @copy_filter_patterns ) {
 938         if  ( $file =~ /$pattern/ ) {
 939            print "filter out: $file\n" if $is_debug;
 940            return 1;
 941         }
 942     }
 943
 944     return 0;
 945 }
 946
 947 sub fix_file_permissions
 948 {
 949     my $mode = shift;
 950     my $file = shift;
 951
 952     if ( ($mode >> 6) % 2 == 1 ) {
 953         $mode = 0777 & ~$umask;
 954     }
 955     else {
 956         $mode = 0666 & ~$umask;
 957     }
 958     chmod($mode, $file);
 959 }
 960
 961 sub get_latest_patchlevel
 962 {
 963     # note: feed only well formed library names to this function
 964     # of the form libfoo.so.x.y.z with x,y,z numbers
 965
 966     my @sorted_files = sort by_rev @_;
 967     return $sorted_files[-1];
 968
 969     sub by_rev {
 970     # comparison function for sorting
 971         my (@field_a, @field_b, $i);
 972
 973         $a =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)\.(\d+)\.(\d+)$/;
 974         @field_a = ($3, $4, $5);
 975         $b =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)\.(\d+)\.(\d+)$/;
 976         @field_b = ($3, $4, $5);
 977
 978         for ($i = 0; $i < 3; $i++)
 979           {
 980               if ( ($field_a[$i] < $field_b[$i]) ) {
 981                   return -1;
 982               }
 983               if ( ($field_a[$i] > $field_b[$i]) ) {
 984                   return 1;
 985               }
 986           }
 987
 988         # can't happen
 989         return 0;
 990     }
 991
 992 }
 993
 994 sub push_default_actions
 995 {
 996     # any default action (that is an action which must be done even without
 997     # a corresponding d.lst entry) should be pushed here on the
 998     # @action_data list.
 999     my $subdir;
1000     my @subdirs = (
1001                     'bin',
1002                     'doc',
1003                     'inc',
1004                     'lib',
1005                     'par',
1006                     'pck',
1007                     'rdb',
1008                     'res',
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
1057 sub 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
1075 sub 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
1120 sub 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 ( $opt_minor ){
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 ( $opt_minor ){
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
1144 sub 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] = $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
1182 sub 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         local $work_file = "";
1213         if ( $ext) {
1214             # We are delivering into a minor. Zip files must not contain the
1215             # minor extension, so we have to pre and post process it.
1216             #
1217             # Pre process: add minor extension to path, create working copy in
1218             # temp directory.
1219             $work_file = get_tempfilename() . ".zip";
1220             die "Error: temp file $work_file already exists" if ( -e $work_file);
1221             zipped_path_extension($zip_file, $work_file, $ext, 1) if ( -e $zip_file );
1222         } elsif ( $zip_file eq $common_zip_file) {
1223             # Zip file in common tree: work on uniq copy to avoid collisions
1224             $work_file = $zip_file;
1225             $work_file =~ s/\.zip$//;
1226             $work_file .= (sprintf('.%d-%d', $$, time())) . ".zip";
1227             die "Error: temp file $work_file already exists" if ( -e $work_file);
1228             if ( -e $zip_file ) {
1229                 if ( -z $zip_file) {
1230                     # sometimes there are files of 0 byte size - remove them
1231                     unlink $zip_file or print_error("can't remove empty file '$zip_file': $!",0);
1232                 } else {
1233                     if ( ! copy($zip_file, $work_file)) {
1234                         # give a warning, not an error:
1235                         # we can zip from scratch instead of just updating the old zip file
1236                         print_warning("can't copy'$zip_file' into '$work_file': $!", 0);
1237                         unlink $work_file;
1238                     }
1239                 }
1240             }
1241         } else {
1242             # No pre processing necessary, working directly on solver.
1243             $work_file = $zip_file;
1244         }
1245
1246         # zip content has to be relative to $dest_dir
1247         chdir($dest_dir{$zip_file}) or die "Error: cannot chdir into $dest_dir{$zip_file}";
1248         my $this_ref = $list_ref{$zip_file};
1249         if ( $opt_delete ) {
1250             if ( -e $work_file ) {
1251                 open(UNZIP, "unzip -t $work_file 2>&1 |") or die "error opening zip file";
1252                 if ( grep /empty/, (<UNZIP>)) {
1253                     close(UNZIP);
1254                     unlink $work_file;
1255                     next;
1256                 }
1257                 close(UNZIP);
1258                 open(ZIP, "| $zipexe -q -o -d -@ $work_file") or die "error opening zip file";
1259                 foreach $file ( @$this_ref ) {
1260                     print "ZIP: removing $file from $platform_zip_file\n" if $is_debug;
1261                     print ZIP "$file\n";
1262                 }
1263                 close(ZIP);
1264             }
1265         } else {
1266             open(ZIP, "| $zipexe -q -o -u -@ $work_file") or die "error opening zip file";
1267             foreach $file ( @$this_ref ) {
1268                 print "ZIP: adding $file to $zip_file\n" if $is_debug;
1269                 print ZIP "$file\n";
1270             }
1271             close(ZIP);
1272         }
1273         if ( $ext ) {
1274             # Post process: strip minor from stored path again
1275             zipped_path_extension($work_file, $zip_file, $ext, 0);
1276             if (( -e $work_file ) && ($work_file ne $zip_file)) {
1277                 unlink $work_file;
1278             }
1279         } elsif ( $zip_file eq $common_zip_file) {
1280             # rename work file back
1281             if ( -e $work_file ) {
1282                 if ( -e $zip_file) {
1283                     # do some tricks to be fast. otherwise we may disturb other platforms
1284                     # by unlinking a file which just gets copied -> stale file handle.
1285                     my $buffer_file=$work_file . '_rm';
1286                     rename($zip_file, $buffer_file) or warn "Warning: can't rename old zip file '$zip_file': $!";
1287                     if (! rename($work_file, $zip_file)) {
1288                         print_error("can't rename temporary file to $zip_file: $!",0);
1289                         unlink $work_file;
1290                     }
1291                     unlink $buffer_file;
1292                 } else {
1293                     if (! rename($work_file, $zip_file)) {
1294                         print_error("can't rename temporary file to $zip_file: $!",0);
1295                         unlink $work_file;
1296                     }
1297                 }
1298             }
1299         }
1300     }
1301 }
1302
1303 sub zipped_path_extension
1304 # add given extension to or strip it from stored path
1305 {
1306     require Archive::Zip; import Archive::Zip;
1307     my ($from, $to, $extension, $with_ext) = @_;
1308
1309     $zip = Archive::Zip->new();
1310     if ( -e $from) {
1311         die 'Error: zip read error' unless $zip->read( $from) == 0;
1312         my $name;
1313         my $newmember;
1314         my $DateTime = 0;
1315         foreach my $member ( $zip->members() ) {
1316             $name = $member->fileName();
1317             if ( $with_ext ) {
1318                 if ( $name !~ m#$extension/# ) {
1319                     $name =~ s#^(.*?)/#$1$extension/#o;
1320                 }
1321             } else {
1322                 $name =~ s#^(.*?)$extension/#$1/#o;
1323             }
1324             $member->fileName( $name );
1325             if ( $member->lastModTime() ) {
1326                 if ( $DateTime < $member->lastModTime() ) {
1327                     $DateTime = $member->lastModTime();
1328                 }
1329             }
1330         }
1331         if ( -e $to ) {
1332             die 'Error: zip write error' unless $zip->overwrite( ) == 0;
1333             File::Copy::move( $from, $to) or die "Error $!: cannot move $from $to";
1334         } else {
1335             die 'Error: zip write error' unless $zip->writeToFileNamed( $to ) == 0;
1336         }
1337         utime $DateTime, $DateTime, $to;
1338     } else {
1339         die "Error: file $from does not exist" if ( ! $opt_delete);
1340     }
1341     return;
1342 }
1343
1344 sub get_tempfilename
1345 {
1346     my $temp_dir = shift;
1347     $temp_dir = ( -d '/tmp' ? '/tmp' : $ENV{TMPDIR} || $ENV{TEMP} || '.' )
1348             unless defined($temp_dir);
1349      if ( ! -d $temp_dir ) {
1350         die "no temp directory $temp_dir\n";
1351     }
1352     my $base_name = sprintf( "%d-%di-%d", $$, time(), $tempcounter++ );
1353     return "$temp_dir/$base_name";
1354 }
1355
1356 sub write_log
1357 {
1358     my (%log_file, %file_date);
1359     $log_file{\@log_list} = "%_DEST%/inc%_EXT%/$module/deliver.log";
1360     $log_file{\@common_log_list} = "%COMMON_DEST%/inc%_EXT%/$module/deliver.log";
1361     $file_date{\@log_list} = $logfiledate;
1362     $file_date{\@common_log_list} = $commonlogfiledate;
1363
1364     my @logs = ( \@log_list );
1365     push @logs, ( \@common_log_list ) if ( $common_build );
1366     foreach my $log ( @logs ) {
1367         $log_file{$log} = expand_macros( $log_file{$log} );
1368         if ( $opt_delete ) {
1369             print "LOG: removing $log_file{$log}\n" if $opt_verbose;
1370             next if ( $opt_check );
1371             unlink $log_file{$log};
1372         } else {
1373             print "LOG: writing $log_file{$log}\n" if $opt_verbose;
1374             next if ( $opt_check );
1375             open( LOGFILE, "> $log_file{$log}" ) or warn "Error: could not open log file.";
1376             foreach my $item ( @$log ) {
1377                 print LOGFILE "@$item\n";
1378             }
1379             close( LOGFILE );
1380             utime($file_date{$log}, $file_date{$log}, $log_file{$log});
1381         }
1382         push_on_ziplist( $log_file{$log} ) if $opt_zip;
1383     }
1384     return;
1385 }
1386
1387 sub check_dlst
1388 {
1389     my %createddir;
1390     my %destdir;
1391     my %destfile;
1392     # get all checkable actions to perform
1393     foreach my $action ( @action_data ) {
1394         my $path = expand_macros( $$action[1] );
1395         if ( $$action[0] eq 'mkdir' ) {
1396             $createddir{$path} ++;
1397         } elsif (( $$action[0] eq 'copy' ) || ( $$action[0] eq 'addincpath' )) {
1398             my ($from, $to) = split(' ', $path);
1399             my ($to_fname, $to_dir);
1400             my $withwildcard = 0;
1401             if ( $from =~ /[\*\?\[\]]/ ) {
1402                 $withwildcard = 1;
1403             }
1404             ($to_fname, $to_dir) = fileparse($to);
1405             if ( $withwildcard ) {
1406                 if ( $to !~ /[\*\?\[\]]/ ) {
1407                     $to_dir = $to;
1408                     $to_fname ='';
1409                 }
1410             }
1411             $to_dir =~ s/[\\\/\s]$//;
1412             $destdir{$to_dir} ++;
1413             # Check: copy into non existing directory?
1414             if ( ! $createddir{$to_dir} ) {
1415                 # unfortunately it is not so easy: it's OK if a subdirectory of $to_dir
1416                 # gets created, because mkpath creates the whole tree
1417                 foreach my $directory ( keys %createddir ) {
1418                     if ( $directory =~ /^\Q$to_dir\E[\\\/]/ ) {
1419                         $createddir{$to_dir} ++;
1420                         last;
1421                     }
1422                 }
1423                 print_warning("Possibly copying into directory without creating in before: '$to_dir'")
1424                     unless $createddir{$to_dir};
1425             }
1426             # Check: overwrite file?
1427             if ( ! $to ) {
1428                 if ( $destfile{$to} ) {
1429                     print_warning("Multiple entries copying to '$to'");
1430                 }
1431                 $destfile{$to} ++;
1432             }
1433         }
1434     }
1435 }
1436
1437 sub cleanup
1438 {
1439     # remove empty directories
1440     foreach my $path ( @dirlist ) {
1441         $path = expand_macros($path);
1442         if ( $opt_check ) {
1443             print "RMDIR: $path\n" if $opt_verbose;
1444         } else {
1445             rmdir $path;
1446         }
1447     }
1448 }
1449
1450 sub delete_output
1451 {
1452     my $output_path = expand_macros("../%__SRC%");
1453     if ( "$output_path" ne "../" ) {
1454         if ( rmtree([$output_path], 0, 1) ) {
1455             print "Deleted output tree.\n" if $opt_verbose;
1456         }
1457         else {
1458             print_error("Error deleting output tree $output_path: $!",0);
1459         }
1460     }
1461     else {
1462         print_error("Output not deleted - INPATH is not set");
1463     }
1464 }
1465
1466 sub print_warning
1467 {
1468     my $message = shift;
1469     my $line = shift;
1470
1471     print STDERR "$script_name: ";
1472     if ( $dlst_file ) {
1473         print STDERR "$dlst_file: ";
1474     }
1475     if ( $line ) {
1476         print STDERR "line $line: ";
1477     }
1478     print STDERR "WARNING: $message\n";
1479 }
1480
1481 sub print_error
1482 {
1483     my $message = shift;
1484     my $line = shift;
1485
1486     print STDERR "$script_name: ";
1487     if ( $dlst_file ) {
1488         print STDERR "$dlst_file: ";
1489     }
1490     if ( $line ) {
1491         print STDERR "line $line: ";
1492     }
1493     print STDERR "ERROR: $message\n";
1494     $error ++;
1495 }
1496
1497 sub print_stats
1498 {
1499     print "Module '$module' delivered ";
1500     if ( $error ) {
1501         print "with errors\n";
1502     } else {
1503         print "successfully.";
1504         if ( $opt_delete ) {
1505             print " $files_copied files removed,";
1506         }
1507         else {
1508             print " $files_copied files copied,";
1509         }
1510         print " $files_unchanged files unchanged\n";
1511     }
1512 }
1513
1514 sub cleanup_and_die
1515 {
1516     # clean up on unexpected termination
1517     my $sig = shift;
1518     if ( defined($temp_file) && -e $temp_file ) {
1519         unlink($temp_file);
1520     }
1521     if ( defined($work_file) && -e $work_file ) {
1522         unlink($work_file);
1523         print STDERR "$work_file removed\n";
1524     }
1525
1526     die "caught unexpected signal $sig, terminating ...";
1527 }
1528
1529 sub usage
1530 {
1531     my $exit_code = shift;
1532     print STDERR "Usage:\ndeliver [OPTION]... [DESTINATION-PATH]\n";
1533     print STDERR "Options:\n";
1534     print STDERR "  -check       just print what would happen, no actual copying of files\n";
1535     print STDERR "  -checkdlst   be verbose about (possible) d.lst bugs\n";
1536     print STDERR "  -delete      delete files (undeliver), use with care\n";
1537     print STDERR "  -deloutput   remove the output tree after copying\n";
1538     print STDERR "  -force       copy even if not newer\n";
1539     print STDERR "  -dontdeletecommon do not delete common files (for -delete option)\n";
1540     print STDERR "  -help        print this message\n";
1541     if ( !defined($ENV{GUI}) || $ENV{GUI} ne 'WNT' ) {
1542         print STDERR "  -link        hard link files into the solver to save disk space\n";
1543     }
1544     print STDERR "  -minor       deliver into minor (milestone)\n";
1545     print STDERR "  -quiet       be quiet, only report errors\n";
1546     print STDERR "  -verbose     be verbose\n";
1547     print STDERR "  -zip         additionally create zip files of delivered content\n";
1548     print STDERR "Option '-zip' and a destination-path are mutually exclusive.\n";
1549     print STDERR "Options '-check' and '-quiet' are mutually exclusive.\n";
1550     exit($exit_code);
1551 }
1552
1553 # vim: set ts=4 shiftwidth=4 expandtab syntax=perl: