office-gobmx/solenv/bin/deliver.pl
Jens-Heiner Rechtien 01d83f66a4 again fix script_name
2001-04-19 15:20:05 +00:00

469 lines
13 KiB
Perl
Executable file

:
eval 'exec perl -wS $0 ${1+"$@"}'
if 0;
#*************************************************************************
#
# $RCSfile: deliver.pl,v $
#
# $Revision: 1.3 $
#
# last change: $Author: hr $ $Date: 2001-04-19 16:20:05 $
#
# The Contents of this file are made available subject to the terms of
# either of the following licenses
#
# - GNU Lesser General Public License Version 2.1
# - Sun Industry Standards Source License Version 1.1
#
# Sun Microsystems Inc., October, 2000
#
# GNU Lesser General Public License Version 2.1
# =============================================
# Copyright 2000 by Sun Microsystems, Inc.
# 901 San Antonio Road, Palo Alto, CA 94303, USA
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License version 2.1, as published by the Free Software Foundation.
#
# This library 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 for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston,
# MA 02111-1307 USA
#
#
# Sun Industry Standards Source License Version 1.1
# =================================================
# The contents of this file are subject to the Sun Industry Standards
# Source License Version 1.1 (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.openoffice.org/license.html.
#
# Software provided under this License is provided on an "AS IS" basis,
# WITHOUT WARRUNTY OF ANY KIND, EITHER EXPRESS OR IMPLIED, INCLUDING,
# WITHOUT LIMITATION, WARRUNTIES THAT THE SOFTWARE IS FREE OF DEFECTS,
# MERCHANTABLE, FIT FOR A PARTICULAR PURPOSE, OR NON-INFRINGING.
# See the License for the specific provisions governing your rights and
# obligations concerning the Software.
#
# The Initial Developer of the Original Code is: Sun Microsystems, Inc..
#
# Copyright: 2000 by Sun Microsystems, Inc.
#
# All Rights Reserved.
#
# Contributor(s): _______________________________________
#
#
#
#*************************************************************************
#
# deliver - copy from module output tree to solver
#
use Cwd;
use File::Basename;
use File::Copy;
use File::DosGlob 'glob';
use File::Path;
#### script id #####
( $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;
$id_str = ' $Revision: 1.3 $ ';
$id_str =~ /Revision:\s+(\S+)\s+\$/
? ($script_rev = $1) : ($script_rev = "-");
print "$script_name -- version: $script_rev\n";
#### 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',
'hedabu',
'ln',
'mkdir',
'touch'
);
$is_debug = 0;
$module = 0; # module name
$base_dir = 0; # path to module base directory
$dlst_file = 0; # path to d.lst
$dir_mode = 0755; # default directory creation mode
@action_data = (); # LoL with all action data
@macros = (); # d.lst macros
$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
for (@action_list) {
$action_hash{$_}++;
}
#### main ####
parse_options();
init_globals();
push_default_actions();
parse_dlst();
walk_action_data();
print_stats();
exit(0);
#### implemented actions #####
sub do_copy {
# we need to copy twice: once from the platform dependent output tree
# and once from the common output tree, in this order
my ($dependent, $common, $from, $to, $file_list);
my $line = shift;
$dependent = expand_macros($line);
($from, $to) = split(' ', $dependent);
print "copy dependant: from: $from, to: $to\n" if $is_debug;
glob_and_copy($from, $to);
$line =~ s/%__SRC%/%COMMON_OUTDIR%/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);
}
sub do_dos {
my $line = shift;
# no macro expansion, no slash conversion
if ( $opt_check ) {
print "DOS: $line\n";
}
else {
system($line);
}
}
sub do_hedabu {
# do_copy(shift);
print_error("action 'hedabu' not yet implemented");
}
sub do_ln {
print_error("action 'ln' not yet implemented");
}
sub do_mkdir {
my $path = expand_macros(shift);
if ( $opt_check ) {
print "MKDIR: $path\n";
}
else {
mkpath($path, 0, $dir_mode);
}
}
sub do_touch {
my $line = shift;
print_error("action 'touch' not yet implemented");
}
#### subroutines #####
sub parse_options {
foreach $arg (@ARGV) {
$arg =~ /^-force$/ and $opt_force = 1 and next;
$arg =~ /^-minor$/ and $opt_minor = 1 and next;
$arg =~ /^-check$/ and $opt_check = 1 and next;
print_error("invalid option $arg");
usage();
exit(1);
}
}
sub init_globals {
my ($dllsuffix, $gui, $inpath, $offenv, $outpath, $solarversion, $updminor);
my ($ext, $umask);
($module, $base_dir, $dlst_file) = get_base();
print "Module=$module, Base_Diri=$base_dir, d.lst=$dlst_file\n" if $is_debug;
$umask = umask();
if ( defined($umask) ) {
$dir_mode = 0777 - $umask;
}
$common_outdir = $ENV{COMMON_OUTDIR};
$dllsuffix = $ENV{DLLSUFFIX};
$gui = lc($ENV{GUI});
$inpath = $ENV{INPATH};
$offenv = $ENV{OFFENV_PATH};
$outpath = $ENV{OUTPATH};
$solarversion = $ENV{SOLARVERSION};
$updminor = $ENV{UPDMINOR} ? $ENV{UPDMINOR} : $ENV{DMAKE_MINOR};
# product build?
$common_outdir = $common_outdir . ".pro" if $inpath =~ /\.pro$/;
$ext = "";
if ( $opt_minor ) {
if ( $updminor ) {
$ext = ".$updminor";
}
else {
print_error("can't determine UPDMINOR", 0);
exit(3);
}
}
$dest = "$solarversion/$inpath";
# the following macros are obsolete, will be flagged as error
# %__WORKSTAMP%
# %GUIBASE%
# %SDK%
# %SOLARVER%
# %UPD%
# valid macros
@macros = (
[ '%__OFFENV%', $offenv ],
[ '%__PRJROOT%', $base_dir ],
[ '%__SRC%', $inpath ],
[ '%_DEST%', $dest ],
[ '%_EXT%', $ext ],
[ '%COMMON_OUTDIR%', $common_outdir ],
[ '%DLLSUFFIX%', $dllsuffix ],
[ '%GUI%', $gui ],
[ '%OUTPATH%', $outpath ]
);
}
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 = cwd();
@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(<DLST>) {
$line_cnt++;
tr/\r\n//d;
next if /^#/;
next if /^\s*$/;
if ( /^\s*(\w+?):\s+(.*)$/ ) {
if ( !exists $action_hash{$1} ) {
print_error("unknown action: \'$1\'", $line_cnt);
exit(4);
}
push(@action_data, [$1, $2]);
}
else {
push(@action_data, ['copy', $_]);
}
# 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]/i
}
if ( $line =~ /(%\w+%)/ ) {
if ( $1 ne '%OS%' ) { # %OS% looks like a macro but is not ...
print_error("unknown/obsolete macro: \'$1\'", $line_cnt);
}
# exit(5);
}
$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 ($i=0; $i <= $#action_data; $i++) {
&{"do_".$action_data[$i][0]}($action_data[$i][1]);
}
}
sub glob_and_copy {
my $from = shift;
my $to = shift;
my $to_dir;
my $replace = 0;
# if $to contains wildcards, replace wildcards with filename
# otherwise consider it as directory and attach filename
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;
copy_if_newer($file, $copy) ? $files_copied++ : $files_unchanged++;
}
}
else {
# no globbing but renaming possible
copy_if_newer($from, $to) ? $files_copied++ : $files_unchanged++;
}
}
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 $new_time;
print "testing $from, $to\n" if $is_debug;
return 0 unless ($new_time = is_newer($from, $to));
print "COPY: $from -> $to\n";
if ( $opt_check ) {
return 1;
}
else {
my $rc = copy($from, $to);
if ( $rc) {
utime($new_time, $new_time, $to);
return 1;
}
else {
print_error("can't copy $from: $!",0);
}
}
}
sub is_newer {
# returns new time if newer or zero if older
my $from = shift;
my $to = shift;
my (@from_stat, @to_stat);
@from_stat = stat($from);
return 0 unless -f _;
# 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;
@to_stat = stat($to);
return $from_stat[9] unless -f _;
if ( $opt_force ) {
return $from_stat[9];
}
else {
return ($from_stat[9] > $to_stat[9]) ? $from_stat[9] : 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. Currently we have just create the dfault solver
# directories
my $subdir;
my @subdirs = (
'bin/app',
'idl',
'inc',
'lib',
'rdb',
'res',
'xml'
);
# create all the subdirectories on solver
foreach $subdir (@subdirs) {
push(@action_data, ['mkdir', "%_DEST%/$subdir"]);
}
}
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";
}
sub print_stats {
print "Statistics:\n";
print "Files copied: $files_copied\n";
print "Files unchanged/not matching: $files_unchanged\n";
}
sub usage {
print STDERR "Usage:\ndeliver [-force] [-minor] [-check]\n";
print STDERR "Options:\n -force\tcopy even if not newer\n";
print STDERR " -minor\tdeliver into minor\n";
print STDERR " -check\tjust print what would happen, no actual copying of files\n";
}
# vim: set ts=4 shiftwidth=4 expandtab syntax=perl: