| : |
| eval 'exec perl -wS $0 ${1+"$@"}' |
| if 0; |
| #************************************************************** |
| # |
| # Licensed to the Apache Software Foundation (ASF) under one |
| # or more contributor license agreements. See the NOTICE file |
| # distributed with this work for additional information |
| # regarding copyright ownership. The ASF licenses this file |
| # to you under the Apache License, Version 2.0 (the |
| # "License"); you may not use this file except in compliance |
| # with the License. You may obtain a copy of the License at |
| # |
| # http://www.apache.org/licenses/LICENSE-2.0 |
| # |
| # Unless required by applicable law or agreed to in writing, |
| # software distributed under the License is distributed on an |
| # "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY |
| # KIND, either express or implied. See the License for the |
| # specific language governing permissions and limitations |
| # under the License. |
| # |
| #************************************************************** |
| |
| |
| |
| # |
| # deliver.pl - copy from module output tree to solver |
| # |
| |
| use Cwd; |
| use File::Basename; |
| use File::Copy; |
| use File::DosGlob 'glob'; |
| use File::Path; |
| use File::Spec; |
| |
| #### script id ##### |
| |
| ( $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/; |
| |
| $id_str = ' $Revision: 275594 $ '; |
| $id_str =~ /Revision:\s+(\S+)\s+\$/ |
| ? ($script_rev = $1) : ($script_rev = "-"); |
| |
| |
| #### globals #### |
| |
| ### valid actions ### |
| # if you add a action 'foo', than add 'foo' to this list and |
| # implement 'do_foo()' in the implemented actions area |
| @action_list = ( # valid actions |
| 'copy', |
| 'dos', |
| 'addincpath', |
| 'linklib', |
| 'mkdir', |
| 'symlink', |
| 'touch' |
| ); |
| |
| # copy filter: files matching these patterns won't be copied by |
| # the copy action |
| @copy_filter_patterns = ( |
| ); |
| |
| $strip = ''; |
| $is_debug = 0; |
| |
| $error = 0; |
| $module = 0; # module name |
| $repository = 0; # parent directory of this module |
| $base_dir = 0; # path to module base directory |
| $dlst_file = 0; # path to d.lst |
| $ilst_ext = 'ilst'; # extension of image lists |
| $umask = 22; # default file/directory creation mask |
| $dest = 0; # optional destination path |
| $common_build = 0; # do we have common trees? |
| $common_dest = 0; # common tree on solver |
| |
| @action_data = (); # LoL with all action data |
| @macros = (); # d.lst macros |
| @addincpath_list = (); # files which have to be filtered through addincpath |
| @dirlist = (); # List of 'mkdir' targets |
| @zip_list = (); # files which have to be zipped |
| @common_zip_list = (); # common files which have to be zipped |
| @log_list = (); # LoL for logging all copy and link actions |
| @common_log_list = (); # LoL for logging all copy and link actions in common_dest |
| $logfiledate = 0; # Make log file as old as newest delivered file |
| $commonlogfiledate = 0; # Make log file as old as newest delivered file |
| |
| $files_copied = 0; # statistics |
| $files_unchanged = 0; # statistics |
| |
| $opt_force = 0; # option force copy |
| $opt_check = 0; # do actually execute any action |
| $opt_zip = 0; # create an additional zip file |
| $opt_silent = 0; # be silent, only report errors |
| $opt_verbose = 0; # be verbose (former default behaviour) |
| $opt_log = 1; # create an additional log file |
| $opt_link = 0; # hard link files into the solver to save disk space |
| $opt_deloutput = 0; # delete the output tree for the project once successfully delivered |
| $opt_checkdlst = 0; |
| $delete_common = 1; # for "-delete": if defined delete files from common tree also |
| |
| if ($^O ne 'cygwin') { # iz59477 - cygwin needes a dot "." at the end of filenames to disable |
| $maybedot = ''; # some .exe transformation magic. |
| } else { |
| my $cygvernum = `uname -r`; |
| my @cygvernum = split( /\./, $cygvernum); |
| $cygvernum = shift @cygvernum; |
| $cygvernum .= shift @cygvernum; |
| if ( $cygvernum < 17 ) { |
| $maybedot = '.'; |
| } else { |
| $maybedot = ''; # no longer works with cygwin 1.7. other magic below. |
| } |
| } |
| |
| ($gui = lc($ENV{GUI})) || die "Can't determine 'GUI'. Please set environment.\n"; |
| $tempcounter = 0; |
| |
| # zip is default for RE master builds |
| $opt_zip = 1 if ( defined($ENV{DELIVER_TO_ZIP}) && uc($ENV{DELIVER_TO_ZIP}) eq 'TRUE' && ! defined($ENV{CWS_WORK_STAMP})); |
| |
| $has_symlinks = 0; # system supports symlinks |
| |
| for (@action_list) { |
| $action_hash{$_}++; |
| } |
| |
| # trap normal signals (HUP, INT, PIPE, TERM) |
| # for clean up on unexpected termination |
| use sigtrap 'handler' => \&cleanup_and_die, 'normal-signals'; |
| |
| #### main #### |
| |
| parse_options(); |
| init_globals(); |
| |
| print "$script_name -- version: $script_rev\n" if !$opt_silent; |
| |
| if ( ! $opt_delete ) { |
| if ( $ENV{GUI} eq 'WNT' ) { |
| if ($ENV{COM} eq 'GCC') { |
| initialize_strip() ; |
| }; |
| } else { |
| initialize_strip(); |
| } |
| } |
| |
| push_default_actions(); |
| parse_dlst(); |
| check_dlst() if $opt_checkdlst; |
| walk_action_data(); |
| walk_addincpath_list(); |
| write_log() if $opt_log; |
| zip_files() if $opt_zip; |
| cleanup() if $opt_delete; |
| delete_output() if $opt_deloutput; |
| print_stats(); |
| |
| exit($error); |
| |
| #### implemented actions ##### |
| |
| sub do_copy |
| { |
| # We need to copy two times: |
| # from the platform dependent output tree |
| # and from the common output tree |
| my ($dependent, $common, $from, $to, $file_list); |
| my $line = shift; |
| my $touch = 0; |
| |
| $dependent = expand_macros($line); |
| ($from, $to) = split(' ', $dependent); |
| print "copy dependent: from: $from, to: $to\n" if $is_debug; |
| glob_and_copy($from, $to, $touch); |
| |
| if ($delete_common && $common_build && ( $line !~ /%COMMON_OUTDIR%/ ) ) { |
| $line =~ s/%__SRC%/%COMMON_OUTDIR%/ig; |
| if ( $line =~ /%COMMON_OUTDIR%/ ) { |
| $line =~ s/%_DEST%/%COMMON_DEST%/ig; |
| $common = expand_macros($line); |
| ($from, $to) = split(' ', $common); |
| print "copy common: from: $from, to: $to\n" if $is_debug; |
| glob_and_copy($from, $to, $touch); |
| } |
| } |
| } |
| |
| sub do_dos |
| { |
| my $line = shift; |
| |
| my $command = expand_macros($line); |
| if ( $opt_check ) { |
| print "DOS: $command\n"; |
| } |
| else { |
| # HACK: remove MACOSX stuff which is wrongly labled with dos |
| # better: fix broken d.lst |
| return if ( $command =~ /MACOSX/ ); |
| $command =~ s#/#\\#g if $^O eq 'MSWin32'; |
| system($command); |
| } |
| } |
| |
| sub do_addincpath |
| { |
| # just collect all addincpath files, actual filtering is done later |
| my $line = shift; |
| my ($from, $to); |
| my @globbed_files = (); |
| |
| $line = expand_macros($line); |
| ($from, $to) = split(' ', $line); |
| |
| push( @addincpath_list, @{glob_line($from, $to)}); |
| } |
| |
| sub do_linklib |
| { |
| my ($lib_base, $lib_major,$from_dir, $to_dir); |
| my $lib = shift; |
| my @globbed_files = (); |
| my %globbed_hash = (); |
| |
| print "linklib: $lib\n" if $is_debug; |
| print "has symlinks\n" if ( $has_symlinks && $is_debug ); |
| |
| return unless $has_symlinks; |
| |
| $from_dir = expand_macros('../%__SRC%/lib'); |
| $to_dir = expand_macros('%_DEST%/lib%_EXT%'); |
| |
| @globbed_files = glob("$from_dir/$lib"); |
| |
| if ( $#globbed_files == -1 ) { |
| return; |
| } |
| |
| foreach $lib (@globbed_files) { |
| $lib = basename($lib); |
| if ( $lib =~ /^(lib\S+(\.so|\.dylib))\.(\d+)\.(\d+)(\.(\d+))?$/ |
| || $lib =~ /^(lib\S+(\.so|\.dylib))\.(\d+)$/ ) |
| { |
| push(@{$globbed_hash{$1}}, $lib); |
| } |
| else { |
| print_warning("invalid library name: $lib"); |
| } |
| } |
| |
| foreach $lib_base ( sort keys %globbed_hash ) { |
| $lib = get_latest_patchlevel(@{$globbed_hash{$lib_base}}); |
| |
| if ( $lib =~ /^(lib\S+(\.so|\.dylib))\.(\d+)\.(\d+)(\.(\d+))?$/ ) |
| { |
| $lib_major = "$lib_base.$3"; |
| $long = 1; |
| } |
| else |
| { |
| # $lib =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)$/; |
| $long = 0; |
| } |
| |
| if ( $opt_check ) { |
| if ( $opt_delete ) { |
| print "REMOVE: $to_dir/$lib_major\n" if $long; |
| print "REMOVE: $to_dir/$lib_base\n"; |
| } |
| else { |
| print "LINKLIB: $to_dir/$lib -> $to_dir/$lib_major\n" if $long; |
| print "LINKLIB: $to_dir/$lib -> $to_dir/$lib_base\n"; |
| } |
| } |
| else { |
| if ( $opt_delete ) { |
| print "REMOVE: $to_dir/$lib_major\n" if ($long && $opt_verbose); |
| print "REMOVE: $to_dir/$lib_base\n" if $opt_verbose; |
| unlink "$to_dir/$lib_major" if $long; |
| unlink "$to_dir/$lib_base"; |
| if ( $opt_zip ) { |
| push_on_ziplist("$to_dir/$lib_major") if $long; |
| push_on_ziplist("$to_dir/$lib_base"); |
| } |
| return; |
| } |
| my $symlib; |
| my @symlibs; |
| if ($long) |
| { |
| @symlibs = ("$to_dir/$lib_major", "$to_dir/$lib_base"); |
| } |
| else |
| { |
| @symlibs = ("$to_dir/$lib_base"); |
| } |
| # remove old symlinks |
| unlink(@symlibs); |
| foreach $symlib (@symlibs) { |
| print "LINKLIB: $lib -> $symlib\n" if $opt_verbose; |
| if ( !symlink("$lib", "$symlib") ) { |
| print_error("can't symlink $lib -> $symlib: $!",0); |
| } |
| else { |
| push_on_ziplist($symlib) if $opt_zip; |
| push_on_loglist("LINK", "$lib", "$symlib") if $opt_log; |
| } |
| } |
| } |
| } |
| } |
| |
| sub do_mkdir |
| { |
| my $path = expand_macros(shift); |
| # strip whitespaces from path name |
| $path =~ s/\s$//; |
| if (( ! $opt_delete ) && ( ! -d $path )) { |
| if ( $opt_check ) { |
| print "MKDIR: $path\n"; |
| } else { |
| mkpath($path, 0, 0777-$umask); |
| if ( ! -d $path ) { |
| print_error("mkdir: could not create directory '$path'", 0); |
| } |
| } |
| } |
| } |
| |
| sub do_symlink |
| { |
| my $line = shift; |
| |
| $line = expand_macros($line); |
| ($from, $to) = split(' ',$line); |
| my $fullfrom = $from; |
| if ( dirname($from) eq dirname($to) ) { |
| $from = basename($from); |
| } |
| elsif ( dirname($from) eq '.' ) { |
| # nothing to do |
| } |
| else { |
| print_error("symlink: link must be in the same directory as file",0); |
| return 0; |
| } |
| |
| print "symlink: $from, to: $to\n" if $is_debug; |
| |
| return unless $has_symlinks; |
| |
| if ( $opt_check ) { |
| if ( $opt_delete ) { |
| print "REMOVE: $to\n"; |
| } |
| else { |
| print "SYMLINK $from -> $to\n"; |
| } |
| } |
| else { |
| print "REMOVE: $to\n" if $opt_verbose; |
| unlink $to; |
| if ( $opt_delete ) { |
| push_on_ziplist($to) if $opt_zip; |
| return; |
| } |
| return unless -e $fullfrom; |
| print "SYMLIB: $from -> $to\n" if $opt_verbose; |
| if ( !symlink("$from", "$to") ) { |
| print_error("can't symlink $from -> $to: $!",0); |
| } |
| else { |
| push_on_ziplist($to) if $opt_zip; |
| push_on_loglist("LINK", "$from", "$to") if $opt_log; |
| } |
| } |
| } |
| |
| sub do_touch |
| { |
| my ($from, $to); |
| my $line = shift; |
| my $touch = 1; |
| |
| $line = expand_macros($line); |
| ($from, $to) = split(' ', $line); |
| print "touch: $from, to: $to\n" if $is_debug; |
| glob_and_copy($from, $to, $touch); |
| } |
| |
| #### subroutines ##### |
| |
| sub parse_options |
| { |
| my $arg; |
| my $dontdeletecommon = 0; |
| $opt_silent = 1 if ( defined $ENV{VERBOSE} && $ENV{VERBOSE} eq 'FALSE'); |
| $opt_verbose = 1 if ( defined $ENV{VERBOSE} && $ENV{VERBOSE} eq 'TRUE'); |
| while ( $arg = shift @ARGV ) { |
| $arg =~ /^-force$/ and $opt_force = 1 and next; |
| $arg =~ /^-check$/ and $opt_check = 1 and $opt_verbose = 1 and next; |
| $arg =~ /^-quiet$/ and $opt_silent = 1 and next; |
| $arg =~ /^-verbose$/ and $opt_verbose = 1 and next; |
| $arg =~ /^-zip$/ and $opt_zip = 1 and next; |
| $arg =~ /^-delete$/ and $opt_delete = 1 and next; |
| $arg =~ /^-dontdeletecommon$/ and $dontdeletecommon = 1 and next; |
| $arg =~ /^-help$/ and $opt_help = 1 and $arg = ''; |
| $arg =~ /^-link$/ and $ENV{GUI} ne 'WNT' and $opt_link = 1 and next; |
| $arg =~ /^-deloutput$/ and $opt_deloutput = 1 and next; |
| $arg =~ /^-debug$/ and $is_debug = 1 and next; |
| $arg =~ /^-checkdlst$/ and $opt_checkdlst = 1 and next; |
| print_error("invalid option $arg") if ( $arg =~ /^-/ ); |
| if ( $arg =~ /^-/ || $opt_help || $#ARGV > -1 ) { |
| usage(1); |
| } |
| $dest = $arg; |
| } |
| # $dest and $opt_zip or $opt_delete are mutually exclusive |
| if ( $dest and ($opt_zip || $opt_delete) ) { |
| usage(1); |
| } |
| # $opt_silent and $opt_check or $opt_verbose are mutually exclusive |
| if ( ($opt_check or $opt_verbose) and $opt_silent ) { |
| print STDERR "Error on command line: options '-check' and '-quiet' are mutually exclusive.\n"; |
| usage(1); |
| } |
| if ($dontdeletecommon) { |
| if (!$opt_delete) { |
| usage(1); |
| } |
| $delete_common = 0; |
| }; |
| # $opt_delete implies $opt_force |
| $opt_force = 1 if $opt_delete; |
| } |
| |
| sub init_globals |
| { |
| my $ext; |
| ($module, $repository, $base_dir, $dlst_file) = get_base(); |
| |
| # for CWS: |
| $module =~ s/\.lnk$//; |
| |
| print "Module=$module, Base_Dir=$base_dir, d.lst=$dlst_file\n" if $is_debug; |
| |
| $umask = umask(); |
| if ( !defined($umask) ) { |
| $umask = 22; |
| } |
| |
| my $build_sosl = $ENV{'BUILD_SOSL'}; |
| my $common_outdir = $ENV{'COMMON_OUTDIR'}; |
| my $inpath = $ENV{'INPATH'}; |
| my $solarversion = $ENV{'SOLARVERSION'}; |
| my $updater = $ENV{'UPDATER'}; |
| my $updminor = $ENV{'UPDMINOR'}; |
| my $updminorext = $ENV{'UPDMINOREXT'}; |
| my $work_stamp = $ENV{'WORK_STAMP'}; |
| |
| $::CC_PATH=(fileparse( $ENV{"CC"}))[1]; |
| |
| # special security check for release engineers |
| if ( defined($updater) && !defined($build_sosl) && !$opt_force) { |
| my $path = getcwd(); |
| if ( $path !~ /$work_stamp/io ) { |
| print_error("can't deliver from local directory to SOLARVERSION"); |
| print STDERR "\nDANGER! Release Engineer:\n"; |
| print STDERR "do you really want to deliver from $path to SOLARVERSION?\n"; |
| print STDERR "If so, please use the -force switch\n\n"; |
| exit(7); |
| } |
| } |
| |
| # do we have a valid environment? |
| if ( !defined($inpath) ) { |
| print_error("no environment", 0); |
| exit(3); |
| } |
| |
| $ext = ""; |
| if ( ($updminor) && !$dest ) { |
| $ext = "$updminorext"; |
| } |
| |
| # Do we have common trees? |
| if ( defined($ENV{'common_build'}) && $ENV{'common_build'} eq 'TRUE' ) { |
| $common_build = 1; |
| if ((defined $common_outdir) && ($common_outdir ne "")) { |
| $common_outdir = $common_outdir . ".pro" if $inpath =~ /\.pro$/; |
| if ( $dest ) { |
| $common_dest = $dest; |
| } else { |
| $common_dest = "$solarversion/$common_outdir"; |
| $dest = "$solarversion/$inpath"; |
| } |
| } else { |
| print_error("common_build defined without common_outdir", 0); |
| exit(6); |
| } |
| } else { |
| $common_outdir = $inpath; |
| $dest = "$solarversion/$inpath" if ( !$dest ); |
| $common_dest = $dest; |
| } |
| $dest =~ s#\\#/#g; |
| $common_dest =~ s#\\#/#g; |
| |
| # the following macros are obsolete, will be flagged as error |
| # %__WORKSTAMP% |
| # %GUIBASE% |
| # %SDK% |
| # %SOLARVER% |
| # %__OFFENV% |
| # %DLLSUFFIX%' |
| # %OUTPATH% |
| # %L10N_FRAMEWORK% |
| # %UPD% |
| |
| # valid macros |
| @macros = ( |
| [ '%__PRJROOT%', $base_dir ], |
| [ '%__SRC%', $inpath ], |
| [ '%_DEST%', $dest ], |
| [ '%_EXT%', $ext ], |
| [ '%COMMON_OUTDIR%', $common_outdir ], |
| [ '%COMMON_DEST%', $common_dest ], |
| [ '%GUI%', $gui ] |
| ); |
| |
| # find out if the system supports symlinks |
| $has_symlinks = eval { symlink("",""); 1 }; |
| } |
| |
| sub get_base |
| { |
| # a module base dir contains a subdir 'prj' |
| # which in turn contains a file 'd.lst' |
| my (@field, $repo, $base, $dlst); |
| my $path = getcwd(); |
| |
| @field = split(/\//, $path); |
| |
| while ( $#field != -1 ) { |
| $base = join('/', @field); |
| $dlst = $base . '/prj/d.lst'; |
| last if -e $dlst; |
| pop @field; |
| } |
| |
| if ( $#field == -1 ) { |
| print_error("can't find d.lst"); |
| exit(2); |
| } |
| else { |
| if ( defined $field[-2] ) { |
| $repo = $field[-2]; |
| } else { |
| print_error("Internal error: cannot determine module's parent directory"); |
| } |
| return ($field[-1], $repo, $base, $dlst); |
| } |
| } |
| |
| sub parse_dlst |
| { |
| my $line_cnt = 0; |
| open(DLST, "<$dlst_file") or die "can't open d.lst"; |
| while(<DLST>) { |
| $line_cnt++; |
| tr/\r\n//d; |
| next if /^#/; |
| next if /^\s*$/; |
| if (!$delete_common && /%COMMON_DEST%/) { |
| # Just ignore all lines with %COMMON_DEST% |
| next; |
| }; |
| if ( /^\s*(\w+?):\s+(.*)$/ ) { |
| if ( !exists $action_hash{$1} ) { |
| print_error("unknown action: \'$1\'", $line_cnt); |
| exit(4); |
| } |
| push(@action_data, [$1, $2]); |
| } |
| else { |
| if ( /^\s*%(COMMON)?_DEST%\\/ ) { |
| # only copy from source dir to solver, not from solver to solver |
| print_warning("illegal copy action, ignored: \'$_\'", $line_cnt); |
| next; |
| } |
| push(@action_data, ['copy', $_]); |
| # for each ressource file (.res) copy its image list (.ilst) |
| if ( /\.res\s/ ) { |
| my $imagelist = $_; |
| $imagelist =~ s/\.res/\.$ilst_ext/g; |
| $imagelist =~ s/\\bin%_EXT%\\/\\res%_EXT%\\img\\/; |
| push(@action_data, ['copy', $imagelist]); |
| } |
| } |
| # call expand_macros()just to find any undefined macros early |
| # real expansion is done later |
| expand_macros($_, $line_cnt); |
| } |
| close(DLST); |
| } |
| |
| sub expand_macros |
| { |
| # expand all macros and change backslashes to slashes |
| my $line = shift; |
| my $line_cnt = shift; |
| my $i; |
| |
| for ($i=0; $i<=$#macros; $i++) { |
| $line =~ s/$macros[$i][0]/$macros[$i][1]/gi |
| } |
| if ( $line =~ /(%\w+%)/ ) { |
| if ( $1 ne '%OS%' ) { # %OS% looks like a macro but is not ... |
| print_error("unknown/obsolete macro: \'$1\'", $line_cnt); |
| } |
| } |
| $line =~ s#\\#/#g; |
| return $line; |
| } |
| |
| sub walk_action_data |
| { |
| # all actions have to be excuted relative to the prj directory |
| chdir("$base_dir/prj"); |
| # dispatch depending on action type |
| for (my $i=0; $i <= $#action_data; $i++) { |
| &{"do_".$action_data[$i][0]}($action_data[$i][1]); |
| if ( $action_data[$i][0] eq 'mkdir' ) { |
| # fill array with (possibly) created directories in |
| # revers order for removal in 'cleanup' |
| unshift @dirlist, $action_data[$i][1]; |
| } |
| } |
| } |
| |
| sub glob_line |
| { |
| my $from = shift; |
| my $to = shift; |
| my $to_dir = shift; |
| my $replace = 0; |
| my @globbed_files = (); |
| |
| if ( ! ( $from && $to ) ) { |
| print_warning("Error in d.lst? source: '$from' destination: '$to'"); |
| return \@globbed_files; |
| } |
| |
| if ( $to =~ /[\*\?\[\]]/ ) { |
| my $to_fname; |
| ($to_fname, $to_dir) = fileparse($to); |
| $replace = 1; |
| } |
| |
| if ( $from =~ /[\*\?\[\]]/ ) { |
| # globbing necessary, no renaming possible |
| my $file; |
| my @file_list = glob($from); |
| |
| foreach $file ( @file_list ) { |
| next if ( -d $file); # we only copy files, not directories |
| my ($fname, $dir) = fileparse($file); |
| my $copy = ($replace) ? $to_dir . $fname : $to . '/' . $fname; |
| push(@globbed_files, [$file, $copy]); |
| } |
| } |
| else { |
| # no globbing but renaming possible |
| # #i89066# |
| if (-d $to && -f $from) { |
| my $filename = File::Basename::basename($from); |
| $to .= '/' if ($to !~ /[\\|\/]$/); |
| $to .= $filename; |
| }; |
| push(@globbed_files, [$from, $to]); |
| } |
| if ( $opt_checkdlst ) { |
| my $outtree = expand_macros("%__SRC%"); |
| my $commonouttree = expand_macros("%COMMON_OUTDIR%"); |
| if (( $from !~ /\Q$outtree\E/ ) && ( $from !~ /\Q$commonouttree\E/ )) { |
| print_warning("'$from' does not match any file") if ( $#globbed_files == -1 ); |
| } |
| } |
| return \@globbed_files; |
| } |
| |
| |
| sub glob_and_copy |
| { |
| my $from = shift; |
| my $to = shift; |
| my $touch = shift; |
| |
| my @copy_files = @{glob_line($from, $to)}; |
| |
| for (my $i = 0; $i <= $#copy_files; $i++) { |
| next if filter_out($copy_files[$i][0]); # apply copy filter |
| copy_if_newer($copy_files[$i][0], $copy_files[$i][1], $touch) |
| ? $files_copied++ : $files_unchanged++; |
| } |
| } |
| |
| sub is_unstripped { |
| my $file_name = shift; |
| my $nm_output; |
| |
| if (-f $file_name.$maybedot) { |
| my $file_type = `file $file_name`; |
| # OS X file command doesn't know if a file is stripped or not |
| if (($file_type =~ /not stripped/o) || ($file_type =~ /Mach-O/o) || |
| (($file_type =~ /PE/o) && ($ENV{GUI} eq 'WNT') && |
| ($nm_output = `nm $file_name 2>&1`) && $nm_output && |
| !($nm_output =~ /no symbols/i) && !($nm_output =~ /not recognized/i))) { |
| return '1' if ($file_name =~ /\.bin$/o); |
| return '1' if ($file_name =~ /\.so\.*/o); |
| return '1' if ($file_name =~ /\.dylib\.*/o); |
| return '1' if ($file_name =~ /\.com\.*/o); |
| return '1' if ($file_name =~ /\.dll\.*/o); |
| return '1' if ($file_name =~ /\.exe\.*/o); |
| return '1' if (basename($file_name) !~ /\./o); |
| } |
| }; |
| return ''; |
| } |
| |
| sub initialize_strip { |
| if ((!defined $ENV{DISABLE_STRIP}) || ($ENV{DISABLE_STRIP} eq "")) { |
| $strip .= 'guw ' if ($^O eq 'cygwin'); |
| $strip .= $::CC_PATH if (-e $::CC_PATH.'/strip'); |
| $strip .= 'strip'; |
| $strip .= " -x" if ($ENV{OS} eq 'MACOSX'); |
| $strip .= " -R '.comment' -s" if ($ENV{OS} eq 'LINUX'); |
| }; |
| }; |
| |
| sub is_jar { |
| my $file_name = shift; |
| |
| if (-f $file_name && (( `file $file_name` ) =~ /Zip archive/o)) { |
| return '1' if ($file_name =~ /\.jar\.*/o); |
| }; |
| return ''; |
| } |
| |
| sub execute_system { |
| my $command = shift; |
| if (system($command)) { |
| print_error("Failed to execute $command"); |
| exit($?); |
| }; |
| }; |
| |
| sub strip_target { |
| my $file = shift; |
| my $temp_file = shift; |
| $temp_file =~ s/\/{2,}/\//g; |
| my $rc = copy($file, $temp_file); |
| execute_system("$strip $temp_file"); |
| return $rc; |
| }; |
| |
| sub copy_if_newer |
| { |
| # return 0 if file is unchanged ( for whatever reason ) |
| # return 1 if file has been copied |
| my $from = shift; |
| my $to = shift; |
| my $touch = shift; |
| my $from_stat_ref; |
| my $rc = 0; |
| |
| print "testing $from, $to\n" if $is_debug; |
| push_on_ziplist($to) if $opt_zip; |
| push_on_loglist("COPY", "$from", "$to") if $opt_log; |
| return 0 unless ($from_stat_ref = is_newer($from, $to, $touch)); |
| |
| if ( $opt_delete ) { |
| print "REMOVE: $to\n" if $opt_verbose; |
| $rc = unlink($to) unless $opt_check; |
| return 1 if $opt_check; |
| return $rc; |
| } |
| |
| if( !$opt_check && $opt_link ) { |
| # hard link if possible |
| if( link($from, $to) ){ |
| print "LINK: $from -> $to\n" if $opt_verbose; |
| return 1; |
| } |
| } |
| |
| if( $touch ) { |
| print "TOUCH: $from -> $to\n" if $opt_verbose; |
| } |
| else { |
| print "COPY: $from -> $to\n" if $opt_verbose; |
| } |
| |
| return 1 if( $opt_check ); |
| |
| # |
| # copy to temporary file first and rename later |
| # to minimize the possibility for race conditions |
| local $temp_file = sprintf('%s.%d-%d', $to, $$, time()); |
| $rc = ''; |
| if (($strip ne '') && (defined $ENV{PROEXT}) && (is_unstripped($from))) { |
| $rc = strip_target($from, $temp_file); |
| } else { |
| $rc = copy($from, $temp_file); |
| }; |
| if ( $rc) { |
| if ( is_newer($temp_file, $from, 0) ) { |
| $rc = utime($$from_stat_ref[9], $$from_stat_ref[9], $temp_file); |
| if ( !$rc ) { |
| print_warning("can't update temporary file modification time '$temp_file': $!\n |
| Check file permissions of '$from'.",0); |
| } |
| } |
| fix_file_permissions($$from_stat_ref[2], $temp_file); |
| if ( $^O eq 'os2' ) |
| { |
| $rc = unlink($to); # YD OS/2 can't rename if $to exists! |
| } |
| # Ugly hack: on windows file locking(?) sometimes prevents renaming. |
| # Until we've found and fixed the real reason try it repeatedly :-( |
| my $try = 0; |
| my $maxtries = 1; |
| $maxtries = 5 if ( $^O eq 'MSWin32' ); |
| my $success = 0; |
| while ( $try < $maxtries && ! $success ) { |
| sleep $try; |
| $try ++; |
| $success = rename($temp_file, $to); |
| if ( $^O eq 'cygwin' && $to =~ /\.bin$/) { |
| # hack to survive automatically added .exe for executables renamed to |
| # *.bin - will break if there is intentionally a .bin _and_ .bin.exe file. |
| $success = rename( "$to.exe", $to ) if -f "$to.exe"; |
| } |
| } |
| if ( $success ) { |
| # handle special packaging of *.dylib files for Mac OS X |
| if ( $^O eq 'darwin' ) |
| { |
| system("macosx-create-bundle", "$to=$from.app") if ( -d "$from.app" ); |
| system("ranlib", "$to" ) if ( $to =~ /\.a/ ); |
| } |
| if ( $try > 1 ) { |
| print_warning("File '$to' temporarily locked. Dependency bug?"); |
| } |
| return 1; |
| } |
| else { |
| print_error("can't rename temporary file to $to: $!",0); |
| } |
| } |
| else { |
| print_error("can't copy $from: $!",0); |
| my $destdir = dirname($to); |
| if ( ! -d $destdir ) { |
| print_error("directory '$destdir' does not exist", 0); |
| } |
| } |
| unlink($temp_file); |
| return 0; |
| } |
| |
| sub is_newer |
| { |
| # returns whole stat buffer if newer |
| my $from = shift; |
| my $to = shift; |
| my $touch = shift; |
| my (@from_stat, @to_stat); |
| |
| @from_stat = stat($from.$maybedot); |
| if ( $opt_checkdlst ) { |
| my $outtree = expand_macros("%__SRC%"); |
| my $commonouttree = expand_macros("%COMMON_OUTDIR%"); |
| if ( $from !~ /$outtree/ ) { |
| if ( $from !~ /$commonouttree/ ) { |
| print_warning("'$from' does not exist") unless -e _; |
| } |
| } |
| } |
| return 0 unless -f _; |
| |
| if ( $touch ) { |
| $from_stat[9] = time(); |
| } |
| # adjust timestamps to even seconds |
| # this is necessary since NT platforms have a |
| # 2s modified time granularity while the timestamps |
| # on Samba volumes have a 1s granularity |
| |
| $from_stat[9]-- if $from_stat[9] % 2; |
| |
| if ( $to =~ /^\Q$dest\E/ ) { |
| if ( $from_stat[9] > $logfiledate ) { |
| $logfiledate = $from_stat[9]; |
| } |
| } elsif ( $common_build && ( $to =~ /^\Q$common_dest\E/ ) ) { |
| if ( $from_stat[9] > $commonlogfiledate ) { |
| $commonlogfiledate = $from_stat[9]; |
| } |
| } |
| |
| @to_stat = stat($to.$maybedot); |
| return \@from_stat unless -f _; |
| |
| if ( $opt_force ) { |
| return \@from_stat; |
| } |
| else { |
| return ($from_stat[9] > $to_stat[9]) ? \@from_stat : 0; |
| } |
| } |
| |
| sub filter_out |
| { |
| my $file = shift; |
| |
| foreach my $pattern ( @copy_filter_patterns ) { |
| if ( $file =~ /$pattern/ ) { |
| print "filter out: $file\n" if $is_debug; |
| return 1; |
| } |
| } |
| |
| return 0; |
| } |
| |
| sub fix_file_permissions |
| { |
| my $mode = shift; |
| my $file = shift; |
| |
| if ( ($mode >> 6) % 2 == 1 ) { |
| $mode = 0777 & ~$umask; |
| } |
| else { |
| $mode = 0666 & ~$umask; |
| } |
| chmod($mode, $file); |
| } |
| |
| sub get_latest_patchlevel |
| { |
| # note: feed only well formed library names to this function |
| # of the form libfoo.so.x.y.z with x,y,z numbers |
| |
| my @sorted_files = sort by_rev @_; |
| return $sorted_files[-1]; |
| |
| sub by_rev { |
| # comparison function for sorting |
| my (@field_a, @field_b, $i); |
| |
| $a =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)\.(\d+)\.(\d+)$/; |
| @field_a = ($3, $4, $5); |
| $b =~ /^(lib[\w-]+(\.so|\.dylib))\.(\d+)\.(\d+)\.(\d+)$/; |
| @field_b = ($3, $4, $5); |
| |
| for ($i = 0; $i < 3; $i++) |
| { |
| if ( ($field_a[$i] < $field_b[$i]) ) { |
| return -1; |
| } |
| if ( ($field_a[$i] > $field_b[$i]) ) { |
| return 1; |
| } |
| } |
| |
| # can't happen |
| return 0; |
| } |
| |
| } |
| |
| sub push_default_actions |
| { |
| # any default action (that is an action which must be done even without |
| # a corresponding d.lst entry) should be pushed here on the |
| # @action_data list. |
| my $subdir; |
| my @subdirs = ( |
| 'bin', |
| 'doc', |
| 'inc', |
| 'lib', |
| 'par', |
| 'pck', |
| 'rdb', |
| 'res', |
| 'xml' |
| ); |
| push(@subdirs, 'zip') if $opt_zip; |
| push(@subdirs, 'idl') if ! $common_build; |
| push(@subdirs, 'pus') if ! $common_build; |
| my @common_subdirs = ( |
| 'bin', |
| 'idl', |
| 'inc', |
| 'pck', |
| 'pus', |
| 'res' |
| ); |
| push(@common_subdirs, 'zip') if $opt_zip; |
| |
| if ( ! $opt_delete ) { |
| # create all the subdirectories on solver |
| foreach $subdir (@subdirs) { |
| push(@action_data, ['mkdir', "%_DEST%/$subdir%_EXT%"]); |
| } |
| if ( $common_build ) { |
| foreach $subdir (@common_subdirs) { |
| push(@action_data, ['mkdir', "%COMMON_DEST%/$subdir%_EXT%"]); |
| } |
| } |
| } |
| push(@action_data, ['mkdir', "%_DEST%/inc%_EXT%/$module"]); |
| if ( $common_build ) { |
| push(@action_data, ['mkdir', "%COMMON_DEST%/inc%_EXT%/$module"]); |
| push(@action_data, ['mkdir', "%COMMON_DEST%/res%_EXT%/img"]); |
| } else { |
| push(@action_data, ['mkdir', "%_DEST%/res%_EXT%/img"]); |
| } |
| |
| # deliver build.lst to $dest/inc/$module |
| push(@action_data, ['copy', "build.lst %_DEST%/inc%_EXT%/$module/build.lst"]); |
| if ( $common_build ) { |
| # ... and to $common_dest/inc/$module |
| push(@action_data, ['copy', "build.lst %COMMON_DEST%/inc%_EXT%/$module/build.lst"]); |
| } |
| |
| # need to copy libstaticmxp.dylib for Mac OS X |
| if ( $^O eq 'darwin' ) |
| { |
| push(@action_data, ['copy', "../%__SRC%/lib/lib*static*.dylib %_DEST%/lib%_EXT%/lib*static*.dylib"]); |
| } |
| } |
| |
| sub walk_addincpath_list |
| { |
| my (@addincpath_headers); |
| return if $#addincpath_list == -1; |
| |
| # create hash with all addincpath header names |
| for (my $i = 0; $i <= $#addincpath_list; $i++) { |
| my @field = split('/', $addincpath_list[$i][0]); |
| push (@addincpath_headers, $field[-1]); |
| } |
| |
| # now stream all addincpath headers through addincpath filter |
| for (my $i = 0; $i <= $#addincpath_list; $i++) { |
| add_incpath_if_newer($addincpath_list[$i][0], $addincpath_list[$i][1], \@addincpath_headers) |
| ? $files_copied++ : $files_unchanged++; |
| } |
| } |
| |
| sub add_incpath_if_newer |
| { |
| my $from = shift; |
| my $to = shift; |
| my $modify_headers_ref = shift; |
| my ($from_stat_ref, $header); |
| |
| push_on_ziplist($to) if $opt_zip; |
| push_on_loglist("ADDINCPATH", "$from", "$to") if $opt_log; |
| |
| if ( $opt_delete ) { |
| print "REMOVE: $to\n" if $opt_verbose; |
| my $rc = unlink($to); |
| return 1 if $rc; |
| return 0; |
| } |
| |
| if ( $from_stat_ref = is_newer($from, $to) ) { |
| print "ADDINCPATH: $from -> $to\n" if $opt_verbose; |
| |
| return 1 if $opt_check; |
| |
| my $save = $/; |
| undef $/; |
| open(FROM, "<$from"); |
| # slurp whole file in one big string |
| my $content = <FROM>; |
| close(FROM); |
| $/ = $save; |
| |
| foreach $header (@$modify_headers_ref) { |
| $content =~ s/#include [<"]$header[>"]/#include <$module\/$header>/g; |
| } |
| |
| open(TO, ">$to"); |
| print TO $content; |
| close(TO); |
| |
| utime($$from_stat_ref[9], $$from_stat_ref[9], $to); |
| fix_file_permissions($$from_stat_ref[2], $to); |
| return 1; |
| } |
| return 0; |
| } |
| |
| sub push_on_ziplist |
| { |
| my $file = shift; |
| return if ( $opt_check ); |
| # strip $dest from path since we don't want to record it in zip file |
| if ( $file =~ s#^\Q$dest\E/##o ) { |
| if ( $updminor ){ |
| # strip minor from path |
| my $ext = "%_EXT%"; |
| $ext = expand_macros($ext); |
| $file =~ s#^$ext##o; |
| } |
| push(@zip_list, $file); |
| } elsif ( $file =~ s#^\Q$common_dest\E/##o ) { |
| if ( $updminor ){ |
| # strip minor from path |
| my $ext = "%_EXT%"; |
| $ext = expand_macros($ext); |
| $file =~ s#^$ext##o; |
| } |
| push(@common_zip_list, $file); |
| } |
| } |
| |
| sub push_on_loglist |
| { |
| my @entry = @_; |
| return 0 if ( $opt_check ); |
| return -1 if ( $#entry != 2 ); |
| if (( $entry[0] eq "COPY" ) || ( $entry[0] eq "ADDINCPATH" )) { |
| return 0 if ( ! -e $entry[1].$maybedot ); |
| # make 'from' relative to source root |
| $entry[1] = $repository ."/" . $module . "/prj/" . $entry[1]; |
| $entry[1] =~ s/$module\/prj\/\.\./$module/; |
| } |
| # platform or common tree? |
| my $common; |
| if ( $entry[2] =~ /^\Q$dest\E/ ) { |
| $common = 0; |
| } elsif ( $common_build && ( $entry[2] =~ /^\Q$common_dest\E/ )) { |
| $common = 1; |
| } else { |
| warn "Neither common nor platform tree?"; |
| return; |
| } |
| # make 'to' relative to SOLARVERSION |
| my $solarversion = $ENV{'SOLARVERSION'}; |
| $solarversion =~ s#\\#/#g; |
| $entry[2] =~ s/^\Q$solarversion\E\///; |
| # strip minor from 'to' |
| my $ext = "%_EXT%"; |
| $ext = expand_macros($ext); |
| $entry[2] =~ s#$ext([\\\/])#$1#o; |
| |
| if ( $common ) { |
| push @common_log_list, [@entry]; |
| } else { |
| push @log_list, [@entry]; |
| } |
| return 1; |
| } |
| |
| sub zip_files |
| { |
| my $zipexe = 'zip'; |
| $zipexe .= ' -y' unless $^O eq 'MSWin32'; |
| |
| my ($platform_zip_file, $common_zip_file); |
| $platform_zip_file = "%_DEST%/zip%_EXT%/$module.zip"; |
| $platform_zip_file = expand_macros($platform_zip_file); |
| my (%dest_dir, %list_ref); |
| $dest_dir{$platform_zip_file} = $dest; |
| $list_ref{$platform_zip_file} = \@zip_list; |
| if ( $common_build ) { |
| $common_zip_file = "%COMMON_DEST%/zip%_EXT%/$module.zip"; |
| $common_zip_file = expand_macros($common_zip_file); |
| $dest_dir{$common_zip_file} = $common_dest; |
| $list_ref{$common_zip_file} = \@common_zip_list; |
| } |
| |
| my $ext = "%_EXT%"; |
| $ext = expand_macros($ext); |
| |
| my @zipfiles; |
| $zipfiles[0] = $platform_zip_file; |
| if ( $common_build ) { |
| push @zipfiles, ($common_zip_file); |
| } |
| foreach my $zip_file ( @zipfiles ) { |
| print "ZIP: updating $zip_file\n" if $opt_verbose; |
| next if ( $opt_check ); |
| |
| if ( $opt_delete ) { |
| if ( -e $zip_file ) { |
| unlink $zip_file or die "Error: can't remove file '$zip_file': $!"; |
| } |
| next; |
| } |
| |
| local $work_file = ""; |
| if ( $zip_file eq $common_zip_file) { |
| # Zip file in common tree: work on uniq copy to avoid collisions |
| $work_file = $zip_file; |
| $work_file =~ s/\.zip$//; |
| $work_file .= (sprintf('.%d-%d', $$, time())) . ".zip"; |
| die "Error: temp file $work_file already exists" if ( -e $work_file); |
| if ( -e $zip_file ) { |
| if ( -z $zip_file) { |
| # sometimes there are files of 0 byte size - remove them |
| unlink $zip_file or print_error("can't remove empty file '$zip_file': $!",0); |
| } else { |
| if ( ! copy($zip_file, $work_file)) { |
| # give a warning, not an error: |
| # we can zip from scratch instead of just updating the old zip file |
| print_warning("can't copy'$zip_file' into '$work_file': $!", 0); |
| unlink $work_file; |
| } |
| } |
| } |
| } else { |
| # No pre processing necessary, working directly on solver. |
| $work_file = $zip_file; |
| } |
| |
| # zip content has to be relative to $dest_dir |
| chdir($dest_dir{$zip_file}) or die "Error: cannot chdir into $dest_dir{$zip_file}"; |
| my $this_ref = $list_ref{$zip_file}; |
| open(ZIP, "| $zipexe -q -o -u -@ $work_file") or die "error opening zip file"; |
| foreach $file ( @$this_ref ) { |
| print "ZIP: adding $file to $zip_file\n" if $is_debug; |
| print ZIP "$file\n"; |
| } |
| close(ZIP); |
| fix_broken_cygwin_created_zips($work_file) if $^O eq "cygwin"; |
| |
| if ( $zip_file eq $common_zip_file) { |
| # rename work file back |
| if ( -e $work_file ) { |
| if ( -e $zip_file) { |
| # do some tricks to be fast. otherwise we may disturb other platforms |
| # by unlinking a file which just gets copied -> stale file handle. |
| my $buffer_file=$work_file . '_rm'; |
| rename($zip_file, $buffer_file) or warn "Warning: can't rename old zip file '$zip_file': $!"; |
| if (! rename($work_file, $zip_file)) { |
| print_error("can't rename temporary file to $zip_file: $!",0); |
| unlink $work_file; |
| } |
| unlink $buffer_file; |
| } else { |
| if (! rename($work_file, $zip_file)) { |
| print_error("can't rename temporary file to $zip_file: $!",0); |
| unlink $work_file; |
| } |
| } |
| } |
| } |
| } |
| } |
| |
| sub fix_broken_cygwin_created_zips |
| # add given extension to or strip it from stored path |
| { |
| require Archive::Zip; import Archive::Zip; |
| my $zip_file = shift; |
| |
| $zip = Archive::Zip->new(); |
| unless ( $zip->read($work_file) == AZ_OK ) { |
| die "Error: can't open zip file '$zip_file' to fix broken cygwin file permissions"; |
| } |
| my $latest_member_mod_time = 0; |
| foreach $member ( $zip->members() ) { |
| my $attributes = $member->unixFileAttributes(); |
| $attributes &= ~0xFE00; |
| print $member->fileName() . ": " . sprintf("%lo", $attributes) if $is_debug; |
| $attributes |= 0x10; # add group write permission |
| print "-> " . sprintf("%lo", $attributes) . "\n" if $is_debug; |
| $member->unixFileAttributes($attributes); |
| if ( $latest_member_mod_time < $member->lastModTime() ) { |
| $latest_member_mod_time = $member->lastModTime(); |
| } |
| } |
| die "Error: can't overwrite zip file '$zip_file' for fixing permissions" unless $zip->overwrite() == AZ_OK; |
| utime($latest_member_mod_time, $latest_member_mod_time, $zip_file); |
| } |
| |
| sub get_tempfilename |
| { |
| my $temp_dir = shift; |
| $temp_dir = ( -d '/tmp' ? '/tmp' : $ENV{TMPDIR} || $ENV{TEMP} || '.' ) |
| unless defined($temp_dir); |
| if ( ! -d $temp_dir ) { |
| die "no temp directory $temp_dir\n"; |
| } |
| my $base_name = sprintf( "%d-%di-%d", $$, time(), $tempcounter++ ); |
| return "$temp_dir/$base_name"; |
| } |
| |
| sub write_log |
| { |
| my (%log_file, %file_date); |
| $log_file{\@log_list} = "%_DEST%/inc%_EXT%/$module/deliver.log"; |
| $log_file{\@common_log_list} = "%COMMON_DEST%/inc%_EXT%/$module/deliver.log"; |
| $file_date{\@log_list} = $logfiledate; |
| $file_date{\@common_log_list} = $commonlogfiledate; |
| |
| my @logs = ( \@log_list ); |
| push @logs, ( \@common_log_list ) if ( $common_build ); |
| foreach my $log ( @logs ) { |
| $log_file{$log} = expand_macros( $log_file{$log} ); |
| if ( $opt_delete ) { |
| print "LOG: removing $log_file{$log}\n" if $opt_verbose; |
| next if ( $opt_check ); |
| unlink $log_file{$log}; |
| } else { |
| print "LOG: writing $log_file{$log}\n" if $opt_verbose; |
| next if ( $opt_check ); |
| open( LOGFILE, "> $log_file{$log}" ) or warn "Error: could not open log file."; |
| foreach my $item ( @$log ) { |
| print LOGFILE "@$item\n"; |
| } |
| close( LOGFILE ); |
| utime($file_date{$log}, $file_date{$log}, $log_file{$log}); |
| } |
| push_on_ziplist( $log_file{$log} ) if $opt_zip; |
| } |
| return; |
| } |
| |
| sub check_dlst |
| { |
| my %createddir; |
| my %destdir; |
| my %destfile; |
| # get all checkable actions to perform |
| foreach my $action ( @action_data ) { |
| my $path = expand_macros( $$action[1] ); |
| if ( $$action[0] eq 'mkdir' ) { |
| $createddir{$path} ++; |
| } elsif (( $$action[0] eq 'copy' ) || ( $$action[0] eq 'addincpath' )) { |
| my ($from, $to) = split(' ', $path); |
| my ($to_fname, $to_dir); |
| my $withwildcard = 0; |
| if ( $from =~ /[\*\?\[\]]/ ) { |
| $withwildcard = 1; |
| } |
| ($to_fname, $to_dir) = fileparse($to); |
| if ( $withwildcard ) { |
| if ( $to !~ /[\*\?\[\]]/ ) { |
| $to_dir = $to; |
| $to_fname =''; |
| } |
| } |
| $to_dir =~ s/[\\\/\s]$//; |
| $destdir{$to_dir} ++; |
| # Check: copy into non existing directory? |
| if ( ! $createddir{$to_dir} ) { |
| # unfortunately it is not so easy: it's OK if a subdirectory of $to_dir |
| # gets created, because mkpath creates the whole tree |
| foreach my $directory ( keys %createddir ) { |
| if ( $directory =~ /^\Q$to_dir\E[\\\/]/ ) { |
| $createddir{$to_dir} ++; |
| last; |
| } |
| } |
| print_warning("Possibly copying into directory without creating in before: '$to_dir'") |
| unless $createddir{$to_dir}; |
| } |
| # Check: overwrite file? |
| if ( ! $to ) { |
| if ( $destfile{$to} ) { |
| print_warning("Multiple entries copying to '$to'"); |
| } |
| $destfile{$to} ++; |
| } |
| } |
| } |
| } |
| |
| sub cleanup |
| { |
| # remove empty directories |
| foreach my $path ( @dirlist ) { |
| $path = expand_macros($path); |
| if ( $opt_check ) { |
| print "RMDIR: $path\n" if $opt_verbose; |
| } else { |
| rmdir $path; |
| } |
| } |
| } |
| |
| sub delete_output |
| { |
| my $output_path = expand_macros("../%__SRC%"); |
| if ( "$output_path" ne "../" ) { |
| if ( rmtree([$output_path], 0, 1) ) { |
| print "Deleted output tree.\n" if $opt_verbose; |
| } |
| else { |
| print_error("Error deleting output tree $output_path: $!",0); |
| } |
| } |
| else { |
| print_error("Output not deleted - INPATH is not set"); |
| } |
| } |
| |
| sub print_warning |
| { |
| my $message = shift; |
| my $line = shift; |
| |
| print STDERR "$script_name: "; |
| if ( $dlst_file ) { |
| print STDERR "$dlst_file: "; |
| } |
| if ( $line ) { |
| print STDERR "line $line: "; |
| } |
| print STDERR "WARNING: $message\n"; |
| } |
| |
| sub print_error |
| { |
| my $message = shift; |
| my $line = shift; |
| |
| print STDERR "$script_name: "; |
| if ( $dlst_file ) { |
| print STDERR "$dlst_file: "; |
| } |
| if ( $line ) { |
| print STDERR "line $line: "; |
| } |
| print STDERR "ERROR: $message\n"; |
| $error ++; |
| } |
| |
| sub print_stats |
| { |
| print "Module '$module' delivered "; |
| if ( $error ) { |
| print "with errors\n"; |
| } else { |
| print "successfully."; |
| if ( $opt_delete ) { |
| print " $files_copied files removed,"; |
| } |
| else { |
| print " $files_copied files copied,"; |
| } |
| print " $files_unchanged files unchanged\n"; |
| } |
| } |
| |
| sub cleanup_and_die |
| { |
| # clean up on unexpected termination |
| my $sig = shift; |
| if ( defined($temp_file) && -e $temp_file ) { |
| unlink($temp_file); |
| } |
| if ( defined($work_file) && -e $work_file ) { |
| unlink($work_file); |
| print STDERR "$work_file removed\n"; |
| } |
| |
| die "caught unexpected signal $sig, terminating ..."; |
| } |
| |
| sub usage |
| { |
| my $exit_code = shift; |
| print STDERR "Usage:\ndeliver [OPTIONS] [DESTINATION-PATH]\n"; |
| print STDERR "Options:\n"; |
| print STDERR " -check just print what would happen, no actual copying of files\n"; |
| print STDERR " -checkdlst be verbose about (possible) d.lst bugs\n"; |
| print STDERR " -delete delete files (undeliver), use with care\n"; |
| print STDERR " -deloutput remove the output tree after copying\n"; |
| print STDERR " -dontdeletecommon do not delete common files (for -delete option)\n"; |
| print STDERR " -force copy even if not newer\n"; |
| print STDERR " -help print this message\n"; |
| if ( !defined($ENV{GUI}) || $ENV{GUI} ne 'WNT' ) { |
| print STDERR " -link hard link files into the solver to save disk space\n"; |
| } |
| print STDERR " -quiet be quiet, only report errors\n"; |
| print STDERR " -verbose be verbose\n"; |
| print STDERR " -zip additionally create zip files of delivered content\n"; |
| print STDERR "Options '-zip' and a destination-path are mutually exclusive.\n"; |
| print STDERR "Options '-check' and '-quiet' are mutually exclusive.\n"; |
| exit($exit_code); |
| } |
| |
| # vim: set ts=4 shiftwidth=4 expandtab syntax=perl: |
