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