postprocess/packconfig/packconfig.pl

   1 :
   2 eval 'exec perl -wS $0 ${1+"$@"}'
   3     if 0;
   4 #*************************************************************************
   5 #
   6 # DO NOT ALTER OR REMOVE COPYRIGHT NOTICES OR THIS FILE HEADER.
   7 #
   8 # Copyright 2000, 2010 Oracle and/or its affiliates.
   9 #
  10 # OpenOffice.org - a multi-platform office productivity suite
  11 #
  12 # This file is part of OpenOffice.org.
  13 #
  14 # OpenOffice.org is free software: you can redistribute it and/or modify
  15 # it under the terms of the GNU Lesser General Public License version 3
  16 # only, as published by the Free Software Foundation.
  17 #
  18 # OpenOffice.org is distributed in the hope that it will be useful,
  19 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  21 # GNU Lesser General Public License version 3 for more details
  22 # (a copy is included in the LICENSE file that accompanied this code).
  23 #
  24 # You should have received a copy of the GNU Lesser General Public License
  25 # version 3 along with OpenOffice.org.  If not, see
  26 # <http://www.openoffice.org/license.html>
  27 # for a copy of the LGPLv3 License.
  28 #
  29 #*************************************************************************
  30
  31 #
  32 # packconfig.pl - pack xml configuration into archives
  33 #
  34
  35 use strict;
  36 use Getopt::Long;
  37 use File::Find;
  38 use File::Basename;
  39 use Archive::Zip qw(:ERROR_CODES :CONSTANTS);
  40
  41 #### globals ####
  42
  43 my $out_file;                # path to output archive
  44 my $tmp_out_file;            # path to temporary output file
  45 my $files_path;              # path to look for desired files
  46 my $verbose;                 # be verbose
  47 my $extra_verbose;           # be extra verbose
  48 my $do_rebuild = 0;          # is rebuilding zipfile required?
  49
  50 #### script id #####
  51
  52 ( my $script_name = $0 ) =~ s/^.*\b(\w+)\.pl$/$1/;
  53
  54 my $script_rev;
  55 my $id_str = ' $Revision: 1.3.24.2 $ ';
  56 $id_str =~ /Revision:\s+(\S+)\s+\$/
  57   ? ($script_rev = $1) : ($script_rev = "-");
  58
  59 #print "$script_name -- version: $script_rev\n";
  60
  61 #### main #####
  62
  63 parse_options();
  64 my %files_hash;
  65 my $file_ref = get_files();
  66
  67 $do_rebuild = is_file_newer(\%files_hash) if $do_rebuild == 0;
  68
  69 if ( $do_rebuild == 1 ) {
  70     create_zip_archive(\%files_hash);
  71     replace_file($tmp_out_file, $out_file);
  72     print_message("packing  $out_file finished.");
  73 } else {
  74     print_message("$out_file up to date. nothing to do.");
  75 }
  76
  77 exit(0);
  78
  79 #### subroutines ####
  80
  81 sub parse_options
  82 {
  83     my $opt_help;
  84     my $p = Getopt::Long::Parser->new();
  85     my $success =$p->getoptions(
  86                              '-h' => \$opt_help,
  87                              '-o=s' => \$out_file,
  88                              '-i=s' => \$files_path,
  89                              '-v'   => \$verbose,
  90                              '-vv'  => \$extra_verbose
  91                             );
  92
  93     if ( $opt_help || !$success || !$out_file || !$files_path )
  94     {
  95         usage();
  96         exit(1);
  97     }
  98
  99     #define intermediate output file
 100     $tmp_out_file="$out_file"."$$".$ENV{INPATH};
 101     # Sanity checks.
 102
 103     # Check if out_file can be written.
 104     my $out_dir = dirname($out_file);
 105     print_error("no such directory: '$out_dir'", 2) if ! -d $out_dir;
 106     print_error("can't search directory: '$out_dir'", 2) if ! -x $out_dir;
 107     print_error("directory is not writable: '$out_dir'", 2) if ! -w $out_dir;
 108
 109     # Check paths.
 110     foreach ($files_path) {
 111         print_error("no such directory: '$_'", 2) if ! -d $_;
 112         print_error("can't search directory: '$_'", 2) if ! -x $_;
 113     }
 114 }
 115
 116 sub get_files
 117 {
 118     local @main::file_list;
 119
 120     find_files(\%files_hash);
 121
 122     if ( !keys %files_hash ) {
 123         print_error("can't find any image lists in '$files_path'", 3);
 124     }
 125
 126     return wantarray ? @main::file_list : \@main::file_list;
 127 }
 128
 129 sub find_files
 130 {
 131     my $files_hash_ref = shift;
 132     find({ wanted => \&wanted, no_chdir => 0 }, "$files_path");
 133     foreach ( @main::file_list ) {
 134         /^\Q$files_path\E\/(.*)$/o;
 135         $files_hash_ref->{$1}++;
 136     }
 137 }
 138
 139 sub wanted
 140 {
 141     my $file = $_;
 142
 143     if ( $file =~ /.*\.xml$/ && -f $file ) {
 144         push @main::file_list, $File::Find::name;
 145     }
 146 }
 147
 148 sub is_file_newer
 149 {
 150     my $test_hash_ref = shift;
 151     my $reference_stamp = 0;
 152
 153     print_message("checking timestamps ...") if $verbose;
 154     if ( -e $out_file ) {
 155         $reference_stamp = (stat($out_file))[9];
 156         print_message("found $out_file with $reference_stamp ...") if $verbose;
 157     }
 158     return 1 if $reference_stamp == 0;
 159
 160     foreach ( sort keys %{$test_hash_ref} ) {
 161         my $path = $files_path;
 162         $path .= "/" if "$path" ne "";
 163         $path .= "$_";
 164         print_message("checking '$path' ...") if $extra_verbose;
 165         my $mtime = (stat($path))[9];
 166         return 1 if $reference_stamp < $mtime;
 167     }
 168     return 0;
 169 }
 170
 171 sub create_zip_archive
 172 {
 173     my $zip_hash_ref = shift;
 174     print_message("creating config archive ...") if $verbose;
 175     my $zip = Archive::Zip->new();
 176
 177     # on Mac OS X Intel we have unxmacxi.pro, on Mac OS X PowerPC unxmacxp.pro .. and so on
 178     my $platform = $ENV{INPATH};
 179
 180     foreach ( sort keys %{$zip_hash_ref} ) {
 181         my $path = "$files_path/$_";
 182     # only Mac OS X Aqua is concerned here
 183     # but changes for other platforms can easely be added following the same principle
 184     if ( ( $platform =~ /^.*macx*/) && ($path =~ /^.*menubar.xml/ ) ) {
 185         $path = modify_mac_menus($path);
 186     }
 187     print_message("zipping '$path' ...") if $extra_verbose;
 188     if ( !$zip->addFile($path, $_) ) {
 189         print_error("can't add file '$path' to config zip archive: $!", 5);
 190     }
 191     }
 192     my $status = $zip->writeToFileNamed($tmp_out_file);
 193     if ( $status != AZ_OK ) {
 194         print_error("write image zip archive '$tmp_out_file' failed. Reason: $status", 6);
 195     }
 196     return;
 197 }
 198
 199 sub modify_mac_menus
 200 {
 201     my $path_base = "$ENV{'SOLARENV'}";
 202     $path_base =~ s/solenv//;
 203
 204     my $new_file_name = "$path_base"."postprocess"."\/"."$ENV{INPATH}"."\/"."misc"."\/"."$_";
 205
 206     my $new_directory = $new_file_name;
 207     $new_directory =~ s/\/menubar.xml//;
 208     if ( ! -e $new_directory) {
 209     `mkdir -p "$new_directory"`;
 210     }
 211
 212     my $old_file_name = "$files_path/$_";
 213
 214     `cp $old_file_name $new_file_name`;
 215
 216     my $temp_file_name = "$new_file_name"."_tmp";
 217     my $xsl_file = "macosx/macosx_menubar_modification.xsl";
 218
 219     my $result = `xsltproc $xsl_file $new_file_name > $temp_file_name`;
 220
 221     if ( $result != 0) {
 222     print_error("xsltproc '$xsl_file' '$new_file_name'> '$temp_file_name' failed",1)
 223     }
 224
 225     replace_file( $temp_file_name, $new_file_name );
 226     return $new_file_name;
 227 }
 228
 229 sub replace_file
 230 {
 231     my $source_file = shift;
 232     my $dest_file = shift;
 233     my $result = 0;
 234
 235     $result = unlink($dest_file) if -f $dest_file;
 236     if ( $result != 1 && -f $dest_file ) {
 237         unlink $source_file;
 238         print_error("couldn't remove '$dest_file'",1);
 239     }  else {
 240         if ( !rename($source_file, $dest_file)) {
 241             unlink $source_file;
 242             print_error("couldn't rename '$source_file'",1);
 243         }
 244     }
 245     return;
 246 }
 247
 248 sub usage
 249 {
 250     print STDERR "Usage: packimages.pl [-h] -o out_file -i file_path\n";
 251     print STDERR "Creates archive of images\n";
 252     print STDERR "Options:\n";
 253     print STDERR "    -h                 print this help\n";
 254     print STDERR "    -o out_file        path to output archive\n";
 255     print STDERR "    -i file_path       path to directory containing the config files\n";
 256     print STDERR "    -v                 verbose\n";
 257     print STDERR "    -vv                very verbose\n";
 258 }
 259
 260 sub print_message
 261 {
 262     my $message     = shift;
 263
 264     print "$script_name: ";
 265     print "$message\n";
 266     return;
 267 }
 268
 269 sub print_warning
 270 {
 271     my $message     = shift;
 272
 273     print STDERR "$script_name: ";
 274     print STDERR "WARNING $message\n";
 275     return;
 276 }
 277
 278 sub print_error
 279 {
 280     my $message     = shift;
 281     my $error_code  = shift;
 282
 283     print STDERR "$script_name: ";
 284     print STDERR "ERROR: $message\n";
 285
 286     if ( $error_code ) {
 287         print STDERR "\nFAILURE: $script_name aborted.\n";
 288         exit($error_code);
 289     }
 290     return;
 291 }