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