: eval 'exec perl -wS $0 ${1+"$@"}' if 0; #************************************************************************* # # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER. # # Copyright 2008 by Sun Microsystems, Inc. # # OpenOffice.org - a multi-platform office productivity suite # # $RCSfile: deliver.pl,v $ # # $Revision$ # # This file is part of OpenOffice.org. # # OpenOffice.org is free software: you can redistribute it and/or modify # it under the terms of the GNU Lesser General Public License version 3 # only, as published by the Free Software Foundation. # # OpenOffice.org is distributed in the hope that it will be useful, # but WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU Lesser General Public License version 3 for more details # (a copy is included in the LICENSE file that accompanied this code). # # You should have received a copy of the GNU Lesser General Public License # version 3 along with OpenOffice.org. If not, see # # for a copy of the LGPLv3 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$ '; $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 $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_minor = 0; # option deliver in minor $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 { $maybedot = '.'; } ($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(); 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(); } } init_globals(); 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 =~ /^-minor$/ and $opt_minor = 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, $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 $work_stamp = $ENV{'WORK_STAMP'}; # 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 ( ($opt_minor || $updminor) && !$dest ) { if ( $updminor ) { $ext = ".$updminor"; } else { print_error("can't determine UPDMINOR", 0); exit(3); } } # 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, $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 determine module"); exit(2); } else { return ($field[-1], $base, $dlst); } } sub parse_dlst { my $line_cnt = 0; open(DLST, "<$dlst_file") or die "can't open d.lst"; while() { $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 ) { my ($fname, $dir) = fileparse($file); my $copy = ($replace) ? $to_dir . $fname : $to . '/' . $fname; push(@globbed_files, [$file, $copy]); } } else { # no globbing but renaming possible 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 .= '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; # handle special packaging of *.dylib files for Mac OS X if ( $to =~ s/\.dylib$/.jnilib/ ) { 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 ( $success ) { # handle special packaging of *.dylib files for Mac OS X if ( $^O eq 'darwin' ) { if ( $to =~ /\.dylib/ ) { system("macosx-create-bundle", $to); my $bundlelib = $to; $bundlelib =~ s/\.dylib$//; $bundlelib .= ".jnilib"; if ( $opt_delete ) { print "REMOVE: $bundlelib\n" if $opt_verbose; unlink "$bundlelib" unless $opt_check; } else { push_on_ziplist($bundlelib) if $opt_zip; push_on_loglist("LINK", basename($to), "$bundlelib") if $opt_log; } } 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 = ; 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 ( $opt_minor ){ # 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 ( $opt_minor ){ # 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] = $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 ); local $work_file = ""; if ( $ext) { # We are delivering into a minor. Zip files must not contain the # minor extension, so we have to pre and post process it. # # Pre process: add minor extension to path, create working copy in # temp directory. $work_file = get_tempfilename() . ".zip"; die "Error: temp file $work_file already exists" if ( -e $work_file); zipped_path_extension($zip_file, $work_file, $ext, 1) if ( -e $zip_file ); } elsif ( $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}; if ( $opt_delete ) { if ( -e $work_file ) { open(UNZIP, "unzip -t $work_file 2>&1 |") or die "error opening zip file"; if ( grep /empty/, ()) { close(UNZIP); unlink $work_file; next; } close(UNZIP); open(ZIP, "| $zipexe -q -o -d -@ $work_file") or die "error opening zip file"; foreach $file ( @$this_ref ) { print "ZIP: removing $file from $platform_zip_file\n" if $is_debug; print ZIP "$file\n"; } close(ZIP); } } else { 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); } if ( $ext ) { # Post process: strip minor from stored path again zipped_path_extension($work_file, $zip_file, $ext, 0); if (( -e $work_file ) && ($work_file ne $zip_file)) { unlink $work_file; } } elsif ( $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 zipped_path_extension # add given extension to or strip it from stored path { require Archive::Zip; import Archive::Zip; my ($from, $to, $extension, $with_ext) = @_; $zip = Archive::Zip->new(); if ( -e $from) { die 'Error: zip read error' unless $zip->read( $from) == 0; my $name; my $newmember; my $DateTime = 0; foreach my $member ( $zip->members() ) { $name = $member->fileName(); if ( $with_ext ) { if ( $name !~ m#$extension/# ) { $name =~ s#^(.*?)/#$1$extension/#o; } } else { $name =~ s#^(.*?)$extension/#$1/#o; } $member->fileName( $name ); if ( $member->lastModTime() ) { if ( $DateTime < $member->lastModTime() ) { $DateTime = $member->lastModTime(); } } } if ( -e $to ) { die 'Error: zip write error' unless $zip->overwrite( ) == 0; File::Copy::move( $from, $to) or die "Error $!: cannot move $from $to"; } else { die 'Error: zip write error' unless $zip->writeToFileNamed( $to ) == 0; } utime $DateTime, $DateTime, $to; } else { die "Error: file $from does not exist" if ( ! $opt_delete); } return; } 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 [OPTION]... [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 " -force copy even if not newer\n"; print STDERR " -dontdeletecommon do not delete common files (for -delete option)\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 " -minor deliver into minor (milestone)\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 "Option '-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: