| : |
| 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: 1.3.24.2 $ '; |
| $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; |
| } |