xref: /trunk/main/postprocess/packconfig/packconfig.pl (revision b9fd132d)

:
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.
#
#**************************************************************



#
# packconfig.pl - pack xml configuration into archives
#

use strict;
use Getopt::Long;
use File::Find;
use File::Basename;
use Archive::Zip qw(:ERROR_CODES :CONSTANTS);

#### globals ####

my $out_file;                # path to output archive
my $tmp_out_file;            # path to temporary output file
my $files_path;              # path to look for desired files
my $verbose;                 # be verbose
my $extra_verbose;           # be extra verbose
my $do_rebuild = 0;          # is rebuilding zipfile required?

#### script id #####

( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;

my $script_rev;
my $id_str = ' $Revision$ ';
$id_str =~ /Revision:\s+(\S+)\s+\$/
  ? ($script_rev = $1) : ($script_rev = "-");

#print "$script_name -- version: $script_rev\n";

#### main #####

parse_options();
my %files_hash;
my $file_ref = get_files();

$do_rebuild = is_file_newer(\%files_hash) if $do_rebuild == 0;

if ( $do_rebuild == 1 ) {
    create_zip_archive(\%files_hash);
    replace_file($tmp_out_file, $out_file);
    print_message("packing  $out_file finished.");
} else {
    print_message("$out_file up to date. nothing to do.");
}

exit(0);

#### subroutines ####

sub parse_options
{
    my $opt_help;
    my $p = Getopt::Long::Parser->new();
    my $success =$p->getoptions(
                             '-h' => \$opt_help,
                             '-o=s' => \$out_file,
                             '-i=s' => \$files_path,
                             '-v'   => \$verbose,
                             '-vv'  => \$extra_verbose
                            );

    if ( $opt_help || !$success || !$out_file || !$files_path )
    {
        usage();
        exit(1);
    }

    #define intermediate output file
    $tmp_out_file="$out_file"."$$".$ENV{INPATH};
    # Sanity checks.

    # Check if out_file can be written.
    my $out_dir = dirname($out_file);
    print_error("no such directory: '$out_dir'", 2) if ! -d $out_dir;
    print_error("can't search directory: '$out_dir'", 2) if ! -x $out_dir;
    print_error("directory is not writable: '$out_dir'", 2) if ! -w $out_dir;

    # Check paths.
    foreach ($files_path) {
        print_error("no such directory: '$_'", 2) if ! -d $_;
        print_error("can't search directory: '$_'", 2) if ! -x $_;
    }
}

sub get_files
{
    local @main::file_list;

    find_files(\%files_hash);

    if ( !keys %files_hash ) {
        print_error("can't find any image lists in '$files_path'", 3);
    }

    return wantarray ? @main::file_list : \@main::file_list;
}

sub find_files
{
    my $files_hash_ref = shift;
    find({ wanted => \&wanted, no_chdir => 0 }, "$files_path");
    foreach ( @main::file_list ) {
        /^\Q$files_path\E\/(.*)$/o;
        $files_hash_ref->{$1}++;
    }
}

sub wanted
{
    my $file = $_;

    if ( $file =~ /.*\.xml$/ && -f $file ) {
        push @main::file_list, $File::Find::name;
    }
}

sub is_file_newer
{
    my $test_hash_ref = shift;
    my $reference_stamp = 0;

    print_message("checking timestamps ...") if $verbose;
    if ( -e $out_file ) {
        $reference_stamp = (stat($out_file))[9];
        print_message("found $out_file with $reference_stamp ...") if $verbose;
    }
    return 1 if $reference_stamp == 0;

    foreach ( sort keys %{$test_hash_ref} ) {
        my $path = $files_path;
        $path .= "/" if "$path" ne "";
        $path .= "$_";
        print_message("checking '$path' ...") if $extra_verbose;
        my $mtime = (stat($path))[9];
        return 1 if $reference_stamp < $mtime;
    }
    return 0;
}

sub create_zip_archive
{
    my $zip_hash_ref = shift;
    print_message("creating config archive ...") if $verbose;
    my $zip = Archive::Zip->new();

    # on Mac OS X Intel we have unxmacxi.pro, on Mac OS X PowerPC unxmacxp.pro .. and so on
    my $platform = $ENV{INPATH};

    foreach ( sort keys %{$zip_hash_ref} ) {
        my $path = "$files_path/$_";
	# only Mac OS X Aqua is concerned here
	# but changes for other platforms can easely be added following the same principle
	if ( ( $platform =~ /^.*macx*/) && ($path =~ /^.*menubar.xml/ ) ) {
	    $path = modify_mac_menus($path);
	}
	print_message("zipping '$path' ...") if $extra_verbose;
	if ( !$zip->addFile($path, $_) ) {
	    print_error("can't add file '$path' to config zip archive: $!", 5);
	}
    }
    my $status = $zip->writeToFileNamed($tmp_out_file);
    if ( $status != AZ_OK ) {
        print_error("write image zip archive '$tmp_out_file' failed. Reason: $status", 6);
    }
    return;
}

sub modify_mac_menus
{
    my $path_base = "$ENV{'SOLARENV'}";
    $path_base =~ s/solenv//;

    my $new_file_name = "$path_base"."postprocess"."\/"."$ENV{INPATH}"."\/"."misc"."\/"."$_";

    my $new_directory = $new_file_name;
    $new_directory =~ s/\/menubar.xml//;
    if ( ! -e $new_directory) {
	`mkdir -p "$new_directory"`;
    }

    my $old_file_name = "$files_path/$_";

    `cp $old_file_name $new_file_name`;

    my $temp_file_name = "$new_file_name"."_tmp";
    my $xsl_file = "macosx/macosx_menubar_modification.xsl";

    my $result = `xsltproc $xsl_file $new_file_name > $temp_file_name`;

    if ( $result != 0) {
	print_error("xsltproc '$xsl_file' '$new_file_name'> '$temp_file_name' failed",1)
    }

    replace_file( $temp_file_name, $new_file_name );
    return $new_file_name;
}

sub replace_file
{
    my $source_file = shift;
    my $dest_file = shift;
    my $result = 0;

    $result = unlink($dest_file) if -f $dest_file;
    if ( $result != 1 && -f $dest_file ) {
        unlink $source_file;
        print_error("couldn't remove '$dest_file'",1);
    }  else {
        if ( !rename($source_file, $dest_file)) {
            unlink $source_file;
            print_error("couldn't rename '$source_file'",1);
        }
    }
    return;
}

sub usage
{
    print STDERR "Usage: packimages.pl [-h] -o out_file -i file_path\n";
    print STDERR "Creates archive of images\n";
    print STDERR "Options:\n";
    print STDERR "    -h                 print this help\n";
    print STDERR "    -o out_file        path to output archive\n";
    print STDERR "    -i file_path       path to directory containing the config files\n";
    print STDERR "    -v                 verbose\n";
    print STDERR "    -vv                very verbose\n";
}

sub print_message
{
    my $message     = shift;

    print "$script_name: ";
    print "$message\n";
    return;
}

sub print_warning
{
    my $message     = shift;

    print STDERR "$script_name: ";
    print STDERR "WARNING $message\n";
    return;
}

sub print_error
{
    my $message     = shift;
    my $error_code  = shift;

    print STDERR "$script_name: ";
    print STDERR "ERROR: $message\n";

    if ( $error_code ) {
        print STDERR "\nFAILURE: $script_name aborted.\n";
        exit($error_code);
    }
    return;
}