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