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