1 # Copyright (c) 2000-2009 Nokia Corporation and/or its subsidiary(-ies).

     2 # All rights reserved.

     3 # This component and the accompanying materials are made available

     4 # under the terms of the License "Eclipse Public License v1.0"

     5 # which accompanies this distribution, and is available

     6 # at the URL "http://www.eclipse.org/legal/epl-v10.html".

     7 #

     8 # Initial Contributors:

     9 # Nokia Corporation - initial contribution.

    10 #

    11 # Contributors:

    12 #

    13 # Description:

    14 

    15 package Utils;

    16 use base qw(Exporter);

    17 use strict;

    18 use Win32;

    19 use Win32::File;

    20 use Win32::Console;

    21 use File::stat;

    22 use File::Path;

    23 use File::Basename;

    24 use File::Find;

    25 use File::Temp;

    26 use File::Spec;

    27 use FindBin;

    28 use Archive::Zip qw( :ERROR_CODES :CONSTANTS );

    29 use Cwd 'abs_path';

    30 use Data::Dumper;

    31 use Time::Local;

    32 use IPC::Open2;

    33 use Cwd;

    34 use Symbian::IPR;

    35 

    36 $|++;

    37 

    38 #

    39 # Constants.

    40 #

    41 

    42 use constant EPOC_RELATIVE => 1;

    43 use constant SOURCE_RELATIVE => 2;

    44 use constant MAX_OS_PATH_LENGTH => 255;

    45 our @EXPORT = qw(EPOC_RELATIVE SOURCE_RELATIVE);

    46 

    47 #

    48 # Globals;

    49 #

    50 

    51 my $console; # Needs to be global because (for some reason) file descriptors get screwed up if it goes out of scope.

    52 my $tempDir;

    53 my $haveCheckedEpocRoot;

    54 my $haveCheckedSrcRoot;

    55 our %zipFileCache; # used to cache the Archive::Zip object of the last zip file used

    56 

    57 #

    58 # Subs.

    59 #

    60 

    61 sub StripWhiteSpace {

    62   my $a = shift;

    63   $$a =~ s/^\s*//;

    64   $$a =~ s/\s*$//;

    65 }

    66 

    67 sub TidyFileName {

    68   my $a = shift;

    69   $$a =~ s/\//\\/g;      # Change forward slashes to back slashes.

    70   $$a =~ s/\\\.\\/\\/g;  # Change "\.\" into "\".

    71 

    72   if ($$a =~ /^\\\\/) {  # Test for UNC paths.

    73     $$a =~ s/\\\\/\\/g;  # Change "\\" into "\".

    74     $$a =~ s/^\\/\\\\/;  # Add back a "\\" at the start so that it remains a UNC path.

    75   }

    76   else {

    77     $$a =~ s/\\\\/\\/g;  # Change "\\" into "\".

    78   }

    79 

    80   # Colapse '\..\' sequences.

    81   my $hasLeadingSlash = $$a =~ s/^\\//;

    82   my $hasTrailingSlash = $$a =~ s/\\$//;

    83   my @elements = split (/\\/, $$a);

    84   my @result; # An array to store the colapsed result in.

    85   foreach my $element (@elements) {

    86     if ($element eq '..') {

    87       my $last = pop @result;

    88       if ($last) {

    89 	if ($last eq '..') { # Throw away the previous element, unless it's another '..'.

    90 	  push (@result, $last);

    91 	  push (@result, $element);

    92 	}

    93 	next;

    94       }

    95     }

    96     push (@result, $element);

    97   }

    98   if ($hasLeadingSlash) {

    99     $$a = '\\';

   100   }

   101   else {

   102     $$a = '';

   103   }

   104   $$a .= join ('\\', @result);

   105   if ($hasTrailingSlash) {

   106     $$a .= '\\';

   107   }

   108 }

   109 

   110 sub IsAbsolute {

   111   my $path = shift;

   112   if ($path =~ /^[\\\/]/) {

   113     return 1;

   114   }

   115   return 0;

   116 }

   117 

   118 sub AbsoluteFileName {

   119   my $fileName = shift;

   120   (my $base, my $path) = fileparse($$fileName);

   121   my $absPath = abs_path($path);

   122   $absPath =~ s/^\D://; # Remove drive letter.

   123   $$fileName = $absPath;

   124   unless ($$fileName =~ /[\\\/]$/) {

   125     $$fileName .= "\\";

   126   }

   127   $$fileName .= $base;

   128   TidyFileName($fileName);

   129 }

   130 

   131 sub AbsolutePath {

   132   my $path = shift;

   133   my $absPath = abs_path($$path);

   134   $absPath =~ s/^\D://; # Remove drive letter.

   135   $$path = $absPath;

   136   TidyFileName($path);

   137 }

   138 

   139 sub EpocRoot {

   140   my $epocRoot = $ENV{EPOCROOT};

   141   unless ($haveCheckedEpocRoot) {

   142     #use Carp qw/cluck/;

   143     #cluck "Checking for EpocRoot";

   144     die "Error: Must set the EPOCROOT environment variable\n" if (!defined($epocRoot));

   145     die "Error: EPOCROOT must not include a drive letter\n" if ($epocRoot =~ /^.:/);

   146     die "Error: EPOCROOT must be an absolute path without a drive letter\n" if ($epocRoot !~ /^\\/);

   147     die "Error: EPOCROOT must not be a UNC path\n" if ($epocRoot =~ /^\\\\/);

   148     die "Error: EPOCROOT must end with a backslash\n" if ($epocRoot !~ /\\$/);

   149     die "Error: EPOCROOT must specify an existing directory\n" if (!-d $epocRoot);

   150     $haveCheckedEpocRoot = 1;

   151   }

   152   return $epocRoot;

   153 }

   154 

   155 sub SourceRoot {

   156   my $srcRoot = $ENV{SRCROOT};

   157   unless ($haveCheckedSrcRoot) {

   158     if (defined $srcRoot) { # undefined SRCROOTs are OK

   159       die "Error: SRCROOT must not include a drive letter\n" if ($srcRoot =~ /^.:/);

   160       die "Error: SRCROOT must be an absolute path without a drive letter\n" if ($srcRoot !~ /^\\/);

   161       die "Error: SRCROOT must not be a UNC path\n" if ($srcRoot =~ /^\\\\/);

   162       die "Error: SRCROOT must end with a backslash\n" if ($srcRoot !~ /\\$/);

   163       die "Error: SRCROOT must specify an existing directory\n" if (!-d $srcRoot);

   164     }

   165     $haveCheckedSrcRoot = 1;

   166   }

   167   return $srcRoot || "\\";

   168 }

   169 

   170 sub CheckWithinEpocRoot {

   171   my $path = shift;

   172   die "Error: \"$path\" is not within EPOCROOT\n" unless (WithinEpocRoot($path));

   173 }

   174 

   175 sub WithinEpocRoot {

   176   my $path = shift;

   177   my $epocRoot = EpocRoot();

   178   return ($path =~ /^\Q$epocRoot\E/i);

   179 }

   180 

   181 sub PrependEpocRoot {

   182   my $path = shift;

   183   if (EpocRoot() ne "\\") {

   184     #use Carp qw/cluck/;

   185     #cluck "here";

   186     die "Error: EPOCROOT already present in \"$path\"\n" if ($path =~ /^\Q$ENV{EPOCROOT}\E/i);

   187   }

   188   $path =~ s!^[\\\/]!!; # Remove leading slash.

   189   return EpocRoot().$path;

   190 }

   191 

   192 sub RelativeToAbsolutePath {

   193 	my $path = shift;

   194 	my $iniData = shift;

   195 	my $pathType = shift;

   196 

   197 	if ( $pathType == SOURCE_RELATIVE ) {

   198 		if( $iniData->HasMappings() && SourceRoot() eq "\\" ) {

   199 			$path = $iniData->PerformMapOnFileName( $path );

   200 		}

   201 		else{

   202 			$path = PrependSourceRoot( $path );

   203 		}

   204 	}

   205 	else {

   206 		$path = PrependEpocRoot( $path );

   207 	}

   208 	return $path;

   209 }

   210 

   211 sub RemoveEpocRoot {

   212   my $path = shift;

   213   unless ($path =~ s/^\Q$ENV{EPOCROOT}\E//i) {

   214     die "Error: Path does not contain EPOCROOT - EPOCROOT:\"$ENV{EPOCROOT}\" - Path:\"$path\"\n";

   215   }

   216   return $path;

   217 }

   218 

   219 sub CheckWithinSourceRoot {

   220   my $path = shift;

   221   die "Error: \"$path\" is not within SRCROOT\n" unless (WithinSourceRoot($path));

   222 }

   223 

   224 sub WithinSourceRoot {

   225   my $path = shift;

   226   my $sourceRoot = SourceRoot();

   227   return ($path =~ /^\Q$sourceRoot\E/i);

   228 }

   229 

   230 sub PrependSourceRoot {

   231   my $path = shift;

   232   my $sourceRoot = SourceRoot();

   233   if ($sourceRoot ne "\\") {

   234     die "Error: SRCROOT already present in \"$path\"\n" if ($path =~ /^\Q$sourceRoot\E/i);

   235   }

   236 

   237   $path =~ s!^[\\\/]!!; # Remove leading slash.

   238   return SourceRoot() . $path;

   239 }

   240 

   241 sub RemoveSourceRoot {

   242   my $path = shift;

   243   my $sourceRoot = SourceRoot();

   244   unless ($path =~ s/^\Q$sourceRoot\E//i) {

   245     die "Error: Couldn't remove \"$sourceRoot\" from \"$path\"\n";

   246   }

   247   return $path;

   248 }

   249 

   250 sub MakeDir ($) {

   251   my $dir = shift;

   252   $dir =~ s/\//\\/g; # Convert all forward slashes to back slashes in path.

   253   unless (-e $dir) {

   254     if ($dir =~ /^\\\\/) {

   255       # This is a UNC path - make path manually because UNC isn't supported by mkpath.

   256       my $dirToMake = '';

   257       my @dirs = split /\\/, $dir;

   258       shift @dirs;  # Get rid of undefined dir.

   259       shift @dirs;  # Get rid of undefined dir.

   260       my $server = shift @dirs;

   261       my $share = shift @dirs;

   262       $dirToMake .= "\\\\$server\\$share";

   263       unless (-e $dirToMake) {

   264 	die "Error: Network share \"$dirToMake\" does not exist\n";

   265       }

   266       foreach my $thisDir (@dirs) {

   267 	$dirToMake .=  "\\$thisDir";

   268 	unless (-e $dirToMake) {

   269 	  mkdir($dirToMake,0) or die "Error: Couldn't make directory $dirToMake: $!\n";

   270 	}

   271       }

   272     }

   273     else {

   274       my @warnings;

   275       local $SIG{__WARN__} = sub {push @warnings, $!};

   276       

   277       eval {mkpath($dir)};

   278       if (@warnings) {

   279         die "Error: Couldn't make path \"$dir\": " . (join ', ', @warnings) . "\n";

   280       }

   281     }

   282   }

   283 }

   284 

   285 sub FileModifiedTime {

   286   my $file = shift;

   287   my $st = stat($file) or return 0;

   288   return TimeMinusDaylightSaving($st->mtime);

   289 }

   290 

   291 sub FileSize {

   292   my $file = shift;

   293   my $st = stat($file) or return 0;

   294   return $st->size;

   295 }

   296 

   297 sub FileModifiedTimeAndSize {

   298   my $file = shift;

   299   my $st = stat($file) or return 0;

   300   return (TimeMinusDaylightSaving($st->mtime), $st->size);

   301 }

   302 

   303 sub TimeMinusDaylightSaving {

   304   my $time = shift;

   305   (undef, undef, undef, undef, undef, undef, undef, undef, my $isDaylightSaving) = localtime;

   306   if ($isDaylightSaving) {

   307     $time -= 3600;

   308   }

   309   return $time;

   310 }

   311 

   312 sub TextTimeToEpochSeconds {

   313   my $textTime = shift;

   314   $textTime =~ /(\S+) (\S+) {1,2}(\d+) {1,2}(\d+):(\d+):(\d+) {1,2}(\d+)/;

   315   my $weekDay = $1;

   316   my $month = $2;

   317   my $monthDay = $3;

   318   my $hours = $4;

   319   my $minutes = $5;

   320   my $seconds = $6;

   321   my $year = $7 - 1900;

   322 

   323   if    ($month eq 'Jan') { $month = 0; }

   324   elsif ($month eq 'Feb') { $month = 1; }

   325   elsif ($month eq 'Mar') { $month = 2; }

   326   elsif ($month eq 'Apr') { $month = 3; }

   327   elsif ($month eq 'May') { $month = 4; }

   328   elsif ($month eq 'Jun') { $month = 5; }

   329   elsif ($month eq 'Jul') { $month = 6; }

   330   elsif ($month eq 'Aug') { $month = 7; }

   331   elsif ($month eq 'Sep') { $month = 8; }

   332   elsif ($month eq 'Oct') { $month = 9; }

   333   elsif ($month eq 'Nov') { $month = 10; }

   334   elsif ($month eq 'Dec') { $month = 11; }

   335 

   336   return timelocal($seconds, $minutes, $hours, $monthDay, $month, $year);

   337 }

   338 

   339 sub TextDateToEpochSeconds {

   340   my $textDate = shift;

   341   (my $day, my $month, my $year) = split (/\//, $textDate, 3);

   342   unless ($day and $month and $year) {

   343     die "Error: Invalid date specification: \"$textDate\"\n";

   344   }

   345   return timelocal(0, 0, 0, $day, $month - 1, $year - 1900);

   346 }

   347 

   348 sub SetFileReadOnly {

   349   my $file = shift;

   350   Utils::TidyFileName(\$file);

   351   system "attrib +r $file";

   352 }

   353 

   354 sub SetFileWritable {

   355   my $file = shift;

   356   Utils::TidyFileName(\$file);

   357   system "attrib -r $file";

   358 }

   359 

   360 sub SplitFileName {

   361   my $fileName = shift;

   362   my $path = '';

   363   my $base = '';

   364   my $ext = '';

   365 

   366   if ($fileName =~ /\\?([^\\]*?)(\.[^\\\.]*)?$/) {

   367     $base = $1;

   368   }

   369   if ($fileName =~ /^(.*\\)/) {

   370     $path = $1;

   371   }

   372   if ($fileName =~ /(\.[^\\\.]*)$/o) {

   373     $ext =  $1;

   374   }

   375 

   376   unless ($fileName eq "$path$base$ext") {

   377     my $prob = ($^V eq "v5.6.0")?" There is a known defect in Perl 5.6.0 which triggers this issue with filenames with two extensions (e.g. .exe.map). Please upgrade to Perl 5.6.1.":"";

   378     die "Couldn't parse filename \"$fileName\".$prob";

   379   }

   380   return ($path, $base, $ext);

   381 }

   382 

   383 sub SplitQuotedString {

   384   my $string = shift;

   385   my $original = $string;

   386   my @output = ();

   387   $string =~ s/^\s+//; # Remove leading delimiter if present.

   388   while ($string) {

   389     if ($string =~ s/^\"(.*?)\"//    # Match and remove next quoted string

   390 	or $string =~ s/^(.*?)\s+//  # or, match and remove next (but not last) unquoted string

   391 	or $string =~ s/^(.*)$//) {  # or, match and remove last unquoted string.

   392       push (@output, $1);

   393       $string =~ s/^\s+//; # Remove delimiter if present.

   394     }

   395     else {

   396       die "Error: Unable to decode string \"$original\"\n";

   397     }

   398   }

   399   return @output;

   400 }

   401 

   402 sub ConcatenateDirNames {

   403   my $dir1 = shift;

   404   my $dir2 = shift;

   405   TidyFileName(\$dir1);

   406   TidyFileName(\$dir2);

   407   $dir1 =~ s/([^\\]$)/$1\\/;

   408   $dir2 =~ s/^\\//;

   409   return $dir1.$dir2;

   410 }

   411 

   412 sub FindInPath {

   413   my $file = shift;

   414   unless (exists $ENV{PATH}) {

   415     die "Error: No path environment variable\n";

   416   }

   417   foreach my $dir (split (/;/, $ENV{PATH})) {

   418     if (-e "$dir\\$file") {

   419       return "$dir\\$file";

   420     }

   421   }

   422   die "Error: \"$file\" not found in path\n";

   423 }

   424 

   425 sub ReadDir {

   426   my $dir = shift;

   427   my @dir;

   428   opendir(DIR, $dir) or die "Error: Couldn't open directory \"$dir\": $!\n";

   429   while (defined(my $file = readdir(DIR))) {

   430     next if ($file eq '.' or $file eq '..');

   431     push (@dir, $file);

   432   }

   433   closedir(DIR);

   434   return \@dir;

   435 }

   436 

   437 sub ReadGlob {

   438   my $glob = shift;

   439   (my $path, my $base, my $ext) = SplitFileName($glob);

   440   $glob = "$base$ext";

   441   $glob =~ s/\./\\\./g; # Escape '.'

   442   $glob =~ s/\*/\.\*/g; # '*' -> '.*'

   443   $glob =~ s/\?/\./g;   # '?' -> '.'

   444   my @entries;

   445   foreach my $entry (@{ReadDir($path)}) {

   446     if ($entry =~ /$glob/) {

   447       push (@entries, "$path$entry");

   448     }

   449   }

   450   return \@entries;

   451 }

   452 

   453 sub ReadDirDescendingDateOrder {

   454   my $dir = shift;

   455   my $unsortedList = ReadDir($dir);

   456   my %mtimeHash;

   457   foreach my $entry (@$unsortedList) {

   458     my $mTime = FileModifiedTime("$dir\\$entry");

   459     while (exists $mtimeHash{$mTime}) {

   460       ++$mTime;

   461     }

   462     $mtimeHash{$mTime} = $entry;

   463   }

   464   my @dir;

   465   foreach my $key (sort { $b <=> $a } keys %mtimeHash) {

   466     push (@dir, $mtimeHash{$key});

   467   }

   468   return \@dir;

   469 }

   470 

   471 sub SignificantDir {

   472   my $dir = shift;

   473   my $significantSubDirs = FindSignificantSubDirs($dir);

   474   my $commonDir = CommonDir($significantSubDirs);

   475   return $commonDir;

   476 }

   477 

   478 

   479 # For a given directory, find which sub-directories contain files (rather than just other sub-directories).

   480 sub FindSignificantSubDirs {

   481   my $dir = shift;

   482   my $dirContents = ReadDir($dir);

   483   my @files;

   484   my @dirs;

   485   foreach my $thisEntry (@$dirContents) {

   486     if (-f "$dir\\$thisEntry") {

   487       push (@files, "$dir\\$thisEntry");

   488     }

   489     elsif (-d "$dir\\$thisEntry") {

   490       push (@dirs, "$dir\\$thisEntry");

   491     }

   492   }

   493   if (scalar @files > 0) {

   494     # This directory contains some files, so it is significant.

   495     return [$dir];

   496   }

   497   elsif (scalar @dirs > 0) {

   498     # Only sub-directories in this directory, so recurse.

   499     my @significantSubDirs;

   500     foreach my $thisDir (@dirs) {

   501       push (@significantSubDirs, @{FindSignificantSubDirs($thisDir)});

   502     }

   503     return \@significantSubDirs;

   504   }

   505   else {

   506     # Nothing of interest;

   507     return [];

   508   }

   509 }

   510 

   511 sub CrossCheckDirs {

   512   my $dir1 = shift;

   513   my $dir2 = shift;

   514   my $matched = CrossCheckDirsOneWay($dir1, $dir2);

   515   if ($matched) {

   516     $matched = CrossCheckDirsOneWay($dir2, $dir1);

   517   }

   518   return $matched;

   519 }

   520 

   521 sub CrossCheckDirsOneWay {

   522   my $dir1 = shift;

   523   my $dir2 = shift;

   524 

   525   my $matched = 1;

   526   opendir(DIR1, $dir1) or die "Error: Couldn't open directory $dir1: $!\n";

   527   while (defined(my $dir1File = readdir(DIR1))) {

   528     next if ($dir1File eq '.' or $dir1File eq '..');

   529     $dir1File = "$dir1\\$dir1File";

   530     (my $dir1MTime, my $dir1Size) = Utils::FileModifiedTimeAndSize($dir1File);

   531     (undef, my $base, my $extension) = Utils::SplitFileName($dir1File);

   532     my $dir2File = "$dir2\\$base$extension";

   533     if (-e $dir2File) {

   534       (my $dir2MTime, my $dir2Size) = Utils::FileModifiedTimeAndSize($dir2File);

   535       unless ($dir2MTime == $dir1MTime and $dir2Size == $dir1Size) {

   536 	print "\"$dir1File\" does not match modified time and size of \"$dir2File\"\n";

   537 	$matched = 0;

   538       }

   539     }

   540     else {

   541       print "\"$dir2File\" not found\n";

   542       $matched = 0;

   543     }

   544   }

   545   closedir(DIR1);

   546 

   547   return $matched;

   548 }

   549 

   550 sub ZipSourceList {

   551   my $zipName = shift;

   552   my $list = shift;

   553   my $verbose = shift;

   554   my $relativeTo = shift;

   555   my $iniData = shift;

   556 

   557   if (scalar(@$list) == 0) {

   558     if ($verbose) { print "No files to put into $zipName...\n"; }

   559     return;

   560   }

   561 

   562   my $dirName = dirname($zipName);

   563   unless (-d $dirName) {

   564     MakeDir($dirName) || die "ERROR: Unable to create directory.";

   565   }

   566 

   567   if ($verbose) { print "Creating $zipName...\n"; }

   568 

   569   my $zip = Archive::Zip->new() or die "ERROR: Unable to create new zip.\n";

   570   

   571   my $processedDirs = {};

   572 

   573   foreach my $file (@$list) {

   574     my $fileToZip = $file;

   575     $file = "$relativeTo"."$file";

   576 

   577     if(-f $file) {

   578 	  # We need to add distribution policy files for each directory

   579 	  my $dirname = dirname($file);

   580 	  

   581 	  if (!exists $processedDirs->{$dirname}) {

   582 		if (-e File::Spec->catdir($dirname, 'distribution.policy')) {

   583 		  push @$list, Utils::RemoveSourceRoot(File::Spec->catdir($dirname, 'distribution.policy'));

   584 		  $processedDirs->{$dirname} = 1;

   585 		}

   586 	  }

   587 	  

   588       if($iniData->HasMappings()){

   589         $fileToZip = $iniData->PerformReverseMapOnFileName($file);

   590         $fileToZip = Utils::RemoveSourceRoot($fileToZip);

   591       }

   592       my $member = $zip->addFile($file, $fileToZip);

   593       if (!defined $member) {

   594         die "ERROR: Cannot add file '$file' to new zip.\n";

   595       }

   596       $member->fileAttributeFormat(FA_MSDOS);

   597       my $attr = 0;

   598       Win32::File::GetAttributes($file, $attr);

   599       $member->{'externalFileAttributes'} |= $attr; # preserve win32 attrs

   600     }

   601     elsif(-e $file){}

   602     else {

   603       die "ERROR: $file does not exist, so can not add to $zipName.\n";

   604     }

   605   }

   606 

   607   # Warning message appears when an error code (which is a non zero) is returned.

   608 

   609   my $returnVal = $zip->writeToFileNamed($zipName);

   610 

   611   if ($returnVal) {

   612     die "Error: Failed to write ZIP file '$zipName'\n";

   613   }

   614 }

   615 

   616 sub ZipList {

   617   my $zipName = shift;

   618   my $list = shift;

   619   my $verbose = shift;

   620   my $noCompress = shift;

   621   my $relativeTo = shift;

   622 

   623   if (scalar(@$list) == 0) {

   624     if ($verbose) { print "No files to put into $zipName...\n"; }

   625     return;

   626   }

   627 

   628   my $dirName = dirname($zipName);

   629   unless (-e $dirName) {

   630     MakeDir($dirName);

   631   }

   632 

   633   if ($verbose) { print "Creating $zipName...\n"; }

   634 

   635   my $cwd = Cwd::cwd();

   636   if ($relativeTo) {

   637     chdir($relativeTo) or die "Error: Couldn't change working directory to \"$relativeTo\": $!\n";

   638   }

   639 

   640   my @opts = ('-@');;

   641   if ($verbose == 0) {

   642     push @opts, '-qq';

   643   }

   644   elsif ($verbose == 1) {

   645     push @opts, '-q';

   646   }

   647   elsif ($verbose > 1) {

   648     push @opts, '-v';

   649   }

   650   if ($noCompress) {

   651     push @opts, '-0';

   652   }

   653   

   654   my $missing = 0;

   655   my $retval;

   656   my $count = 0;

   657   do{

   658      open(ZIP, "| \"$FindBin::Bin\\zip\" @opts $zipName") or die "Error: Couldn't execute _zip.exe - $!\n";

   659 

   660      foreach my $file (@$list) {

   661        unless (-e $file) {

   662          $missing = $file;

   663          last;

   664        }

   665        $file =~ s/\[/\[\[\]/g;

   666        print ZIP "$file\n";

   667      }

   668      close(ZIP);

   669      

   670      $count ++;

   671      $retval = $? >> 8;

   672      if (!$missing && $retval > 1){

   673        print "Warning: Zipping failed with error code $retval for the $count times.\n";

   674      }

   675      

   676   }while(!$missing && $retval > 1 && $count < 10);

   677   

   678   if ($relativeTo) {

   679     chdir($cwd) or die "Error: Couldn't change working directory back to \"$cwd\": $!\n";

   680   }

   681 

   682   if ($missing) {

   683     die "Error: \"" . Utils::ConcatenateDirNames($relativeTo, $missing) . "\" does not exist\n";

   684   }

   685 

   686   die "Zipping failed with error code $retval\n" if $retval > 1; # 1 is warnings only

   687 }

   688 

   689 # So EnvDb::UnpackBinaries can be called from the test suite, use %INC to find path instead of FindBin::Bin

   690 sub UnzipPath {

   691     my $unzippath;

   692     my $envdbpath = $INC{'EnvDb.pm'};

   693     if(defined $envdbpath) {

   694 	# find the unzip binary

   695 	$envdbpath =~ s/\\/\//g;

   696 	$envdbpath =~ s/\/[^\/]+$//;

   697 	$unzippath .= $envdbpath;

   698     } else {

   699 	$unzippath .= $FindBin::Bin;

   700     }

   701     $unzippath .= "\\unzip";

   702     $unzippath = "\"$unzippath\"";

   703 

   704     return $unzippath;

   705 }

   706 

   707 sub UnzipSource {

   708   my $zipName = shift;

   709   my $destinationPath = shift;

   710   my $verbose = shift;

   711   my $overwrite = shift;

   712   my $iniData = shift;

   713   my $toValidate = shift;

   714   my $comp = shift;

   715   

   716   unless(defined $overwrite) {

   717     $overwrite = 0;

   718   }

   719 

   720   if($verbose) {

   721     print "Unpacking ";

   722     if($overwrite) {

   723       print "[in overwrite mode] ";

   724     }

   725     print "$zipName...\n";

   726   }

   727 

   728   my $catInArchive;

   729   my $changeInCat = 0;

   730   my $fileDirBuffer;

   731 

   732   # Sets $catInArchive to the category found on the source zip.

   733   if($toValidate==1 && $zipName =~ /source(.*).zip/){

   734     $catInArchive = $1;

   735   }

   736 

   737   my $zip = Archive::Zip->new($zipName);

   738   my @members = $zip->members();

   739 

   740   # Only print warning message if validation is not being performed, destination path is \\ and verbose is set.

   741 

   742   if($toValidate==0 && $destinationPath ne "\\" && $verbose) {

   743     print "Warning: Ignoring all mappings defined since either source path or SRCROOT is set as $destinationPath.\n";

   744   }

   745 

   746   foreach my $member (@members) {

   747 

   748     my $fileName = $member->fileName();

   749 

   750     $fileName =~ s/\//\\/g;

   751 

   752     if($fileName !~ /^\\/) {

   753       $fileName = "\\$fileName";

   754     }

   755 

   756     $iniData->CheckFileNameForMappingClash($fileName);

   757 

   758     my $newFileName;

   759 

   760     # PerfromMapOnFileName is only used for an validation and if the destintionPath is \\.

   761 

   762     if($toValidate==1 || $destinationPath eq "\\") {

   763       $newFileName = $iniData->PerformMapOnFileName($fileName);

   764     }

   765     else {

   766       $newFileName = $fileName;

   767     }

   768 

   769     # Check if the category has changed. Only occurs for validation.

   770     if(defined $catInArchive && -e $newFileName && $toValidate==1) {

   771       my $fileDir;

   772       my $classifySourceFlag = 1; # Classify source using function ClassifySourceFile only if set as 1 and not when set as 0;

   773 

   774       if(defined $fileDirBuffer) {

   775         ($fileDir) = SplitFileName($newFileName);

   776 

   777         if($fileDirBuffer =~ /^\Q$fileDir\E$/i){

   778           $classifySourceFlag = 0;

   779         }

   780       }

   781 

   782       if($classifySourceFlag){

   783         my ($catInEnv, $errors) = ClassifyPath($iniData, $newFileName, 0, 0, $comp); # verbose = 0 and logErrors = 0

   784         if($catInArchive !~ /$catInEnv/i){

   785           $changeInCat = 1;

   786         }

   787         ($fileDirBuffer) = SplitFileName($newFileName);

   788       }

   789     }

   790     ExtractFile($destinationPath, $newFileName, $member, $toValidate, $overwrite, $verbose);

   791   }

   792 

   793   return $changeInCat;

   794 }

   795 

   796 

   797 sub ExtractFile {

   798   my $destinationPath = shift;

   799   my $newFileName = shift;

   800   my $member = shift;

   801   my $toValidate = shift;

   802   my $overwrite = shift;

   803   my $verbose = shift;

   804   my $unzipRetVal = shift; # The return value from unzip if it has already been tried

   805   my $extractFlag = 0;

   806   

   807   my $attr;

   808 

   809   # If the file is a distribution.policy file then set the overwrite flag to true

   810   if ($newFileName =~ /distribution\.policy/i) {

   811 	$overwrite = 1;

   812   }

   813 

   814   # If extracting file for validation or destination path is not equal to \\ unzip file to $destinationPath.

   815 

   816   if($toValidate==1 || $destinationPath ne "\\") {

   817     $newFileName = File::Spec->catfile($destinationPath, $newFileName);

   818   }

   819 

   820   CheckPathLength($newFileName);

   821 

   822   # If the file exists need to check if file is to be overwritten.

   823 

   824   if(-f $newFileName) {

   825     if($overwrite) {

   826       if((Win32::File::GetAttributes($newFileName, $attr)) && ($attr & HIDDEN)){

   827       	Win32::File::SetAttributes($newFileName, ARCHIVE|NORMAL) || die "ERROR: Unable to overwrite the hidden file $newFileName: $!";

   828 	  }

   829 	  elsif(!-w $newFileName){

   830         chmod(0777,$newFileName) || die "ERROR: Unable to overwrite the read-only file $newFileName: $!";

   831       }

   832       $extractFlag = 1;

   833     }

   834     else {

   835       if($verbose) {

   836         print "Ignoring the file $newFileName, as this is already present.\n";

   837       }

   838     }

   839   }

   840   else{

   841     $extractFlag = 1;

   842   }

   843 

   844   if($extractFlag){

   845     {

   846       #DEF122018

   847       # Invalid paths will cause Archive::Zip to give an error.  We capture the error and re-format it.

   848       my @warnings;

   849       local $SIG{__WARN__} = sub {

   850         push @warnings, $!;

   851       };

   852       

   853       eval { mkpath(dirname($newFileName)) };

   854   

   855       if (@warnings) {

   856         die "Error: Unable to make the directory \"$newFileName\": " . (join "\n", @warnings) . "\n";

   857       }

   858     }

   859 

   860     # A non-zero is returned if there is a problem with extractToFileNamed().

   861     if($member->extractToFileNamed($newFileName)) {

   862       warn "ERROR: Failed to extract $newFileName.\n";

   863       CheckUnzipError($unzipRetVal);

   864       die;

   865     }

   866     utime($member->lastModTime(), $member->lastModTime(), $newFileName);

   867     my $newattr = $member->externalFileAttributes() & 0xFFFF;

   868     Win32::File::SetAttributes($newFileName, $newattr); # reapply win32 attrs

   869   }

   870 }

   871 

   872 sub Unzip {

   873   my $zipName = shift;

   874   my $destinationPath = shift;

   875   my $verbose = shift;

   876   my $overwrite = shift || '';

   877   

   878   $overwrite = '-o' if $overwrite eq '1'; # Some callers to this method may send a boolean value rather then an unzip option

   879   

   880   if ($verbose) {

   881     print "Unpacking ";

   882     if ($overwrite) {

   883       print "[in overwrite mode] ";

   884     }

   885     print "$zipName...\n";

   886   }

   887 

   888   my $v;

   889   if ($verbose == 0) {

   890     $v = "-qq";

   891   }

   892   elsif ($verbose == 1) {

   893     $v = "-q";

   894   }

   895   if ($verbose > 1) {

   896     $v = "";

   897   }

   898 

   899   # Here we check that the files in the zip file are not so long they can not be unpacked

   900   my $zip = Archive::Zip->new($zipName);

   901   my @members = $zip->members();

   902 

   903   foreach my $member (@members) {

   904     my $fileName = File::Spec->catdir('\.', $destinationPath, $member->fileName());

   905     CheckPathLength($fileName);

   906   }

   907 

   908   MakeDir($destinationPath);

   909   

   910   # prepare command

   911   my $cmd = "unzip $overwrite $v $zipName -d $destinationPath 2>&1";

   912   

   913   # run $cmd, fetching io handles for it

   914   my $pid = open2(\*IN, \*OUT, $cmd);

   915   

   916   # one character per read

   917   local $/ = \1;

   918   

   919   # command output line buffer

   920   my $line = '';

   921   

   922   while (<IN>) {

   923     # accumulate line data

   924     $line .= $_;

   925     

   926     # look for expected output

   927     if ($line =~ /^(?:(replace).*\[r\]ename|new name): $/) {

   928       # dump line buffer so user can read prompt

   929       print $line and $line = '';

   930       

   931       # read whole lines for user response

   932       local $/ = "\n";

   933       

   934       # read user's response

   935       chomp(my $response = <STDIN>);

   936       

   937       if (defined $1) { # matched "replace"

   938 	# set overwrite mode if the user chooses to replace [A]ll

   939 	$overwrite = '-o' if $response =~ /^A/;

   940 	

   941 	# set no-overwrite mode if the user chooses to replace [N]one

   942 	$overwrite = '-n' if $response =~ /^N/;

   943       }

   944       

   945       # convey response to the command

   946       print OUT "$response\n";

   947     }

   948     

   949     # dump line buffer at EOL

   950     print $line and $line = '' if $line =~ /\n$/;

   951   }

   952   

   953   close (OUT);

   954   close (IN);

   955   

   956   waitpid($pid,0);

   957 

   958   CheckUnzipError($?);  

   959   

   960   return $overwrite;

   961 }

   962 

   963 sub CheckUnzipError {

   964   my $retval = shift;

   965   $retval = $retval >> 8;

   966   # Error numbers found in unzip (Info-ZIP) source code: there doesn't

   967   # seem to be a manual. Common with return values from PKZIP so

   968   # unlikely to change

   969   # Error 1 is just a warning, so we only care about those > 1

   970   die "Unzip reported an out-of-memory error ($retval)\n" if ($retval>3 && $retval<9);

   971   die "Unzip reported a problem with the zip file ($retval)\n" if ($retval>1 && $retval<4);

   972   die "Unzip reported disk full (though this might mean it's trying to overwrite files in use) ($retval)\n" if ($retval==50);

   973   die "Unzip reported error code ($retval)" if ($retval>1 && $retval<52);

   974   warn "Warning: Unzip returned an unexpected error code ($retval)\n" if ($retval >51)

   975 }

   976 

   977 sub UnzipSingleFile {

   978   my $zipName = shift;

   979   my $file = shift;

   980   my $destinationPath = shift;

   981   my $verbose = shift;

   982   my $overwrite = shift;

   983   my $comp = shift;

   984   

   985   unless (defined $overwrite) {

   986     $overwrite = 0;

   987   }

   988 

   989   if ($verbose) {

   990     print "Unpacking ";

   991     if ($overwrite) {

   992       print "[in overwrite mode] ";

   993     }

   994     print "\"$file\" from \"$zipName\"...\n";

   995   }

   996 

   997 

   998   my $v;

   999   if ($verbose == 0) {

  1000     $v = "-qq";

  1001   }

  1002   elsif ($verbose == 1) {

  1003     $v = "-q";

  1004   }

  1005   if ($verbose > 1) {

  1006     $v = "";

  1007   }

  1008 

  1009   my $o = "";

  1010   if ($overwrite) {

  1011     $o = "-o";

  1012   }

  1013 

  1014   MakeDir($destinationPath);

  1015   my $retval = system(UnzipPath()." $o $v \"$zipName\" \"$file\" -d \"$destinationPath\"");

  1016 

  1017   unless (-e ConcatenateDirNames($destinationPath, $file)) {

  1018     #Fallback to using archive::zip

  1019     print "Unable to extract $file using unzip. Trying alternative extraction method...\n";

  1020     

  1021     my $zip = GetArchiveZipObject($zipName, $comp);

  1022 

  1023     my $fileWithForwardSlashes = $file;

  1024     $fileWithForwardSlashes =~ s/\\/\//g; # Archive::Zip stores file names with forward slashes

  1025   

  1026     my $member = $zip->memberNamed($fileWithForwardSlashes);

  1027     

  1028     if (!defined $member) {

  1029       # Archive::Zip is also case-sensitive.  If it doesn't find the required file we compile the filename into

  1030       # a case insensitive regex and try again.  This takes longer than just calling memberNamed.

  1031       my $fileNameRegEx = qr/$fileWithForwardSlashes/i;

  1032       ($member) = $zip->membersMatching($fileNameRegEx);

  1033       

  1034       # If it still can't find the file then it doesn't exist in the zip file

  1035       if (!defined $member) {

  1036         warn "Unable to find $file in $zipName\n";

  1037         CheckUnzipError($retval);

  1038         die;

  1039       }

  1040     }

  1041   

  1042     ExtractFile($destinationPath, $file, $member, 0, $overwrite, $verbose, $retval);

  1043     print "Successfully extracted $file\n";

  1044   }

  1045 }

  1046 

  1047 sub ListZip {

  1048   my $zipName = shift;

  1049   my @list;

  1050 

  1051   my $zipper = Archive::Zip->new();

  1052   unless ($zipper->read($zipName) == AZ_OK) {

  1053     die "Error: problem reading \"$zipName\"\n";

  1054   }

  1055 

  1056   my @members = $zipper->members();

  1057   foreach my $thisMember (@members) {

  1058     my $file = $thisMember->fileName();

  1059     TidyFileName(\$file);

  1060     unless ($file =~ /^\\/) {

  1061       $file = "\\$file";

  1062     }

  1063     push (@list, $file);

  1064   }

  1065 

  1066   return \@list;

  1067 }

  1068 

  1069 sub CheckZipFileContentsNotPresent {

  1070   my $zipName = shift;

  1071   my $where = shift;

  1072   my $iniData = shift;

  1073   my $checkFailed = 0;

  1074   foreach my $thisFile (@{ListZip($zipName)}) {

  1075     if ($thisFile =~ /\\$/) {

  1076       next;

  1077     }

  1078     my $fullName = ConcatenateDirNames($where, $thisFile);

  1079 

  1080     if($iniData->HasMappings()){

  1081       $fullName = $iniData->PerformMapOnFileName($fullName);

  1082     }

  1083 

  1084 	if ($fullName =~ /distribution\.policy$/i) {

  1085 	  return $checkFailed;

  1086 	}

  1087 

  1088     if (-e $fullName) {

  1089       print "Error: \"$fullName\" would be overwritten by unpacking \"$zipName\"\n";

  1090       $checkFailed = 1;

  1091     }

  1092   }

  1093   return $checkFailed;

  1094 }

  1095 

  1096 sub SignificantZipDir {

  1097   my $zipName = shift;

  1098 

  1099   my $zipper = Archive::Zip->new();

  1100   unless ($zipper->read($zipName) == AZ_OK) {

  1101     die "Error: problem reading \"$zipName\"\n";

  1102   }

  1103 

  1104   my %dirs;

  1105   my @members = $zipper->members();

  1106   foreach my $thisMember (@members) {

  1107     my $file = $thisMember->fileName();

  1108     my $dir = lc(dirname($file));

  1109     TidyFileName(\$dir);

  1110     unless (exists $dirs{$dir}) {

  1111       $dirs{$dir} = 1;

  1112     }

  1113   }

  1114 

  1115   my @dirs = sort keys %dirs;

  1116   return CommonDir(\@dirs);

  1117 }

  1118 

  1119 # Given an array of directories, find the common directory they share.

  1120 sub CommonDir {

  1121   my $dirs = shift;

  1122   my $disectedDirs = DisectDirs($dirs);

  1123   my $numDirs = scalar @$dirs;

  1124   if ($numDirs == 1) {

  1125 	# if there is only one signifigant directory then this has to be

  1126 	# the common one so return it.

  1127 	return $dirs->[0];

  1128   }

  1129   my $commonDir = '';

  1130   my $dirLevel = 0;

  1131   while (1) {

  1132     my $toMatch;

  1133     my $allMatch = 0;

  1134     for (my $ii = 0; $ii < $numDirs; ++$ii, ++$allMatch) {