| Lines 1-117
          
      
      
        Link Here | 
            
              | 1 | #!/usr/bin/env perl |  |  | 
            
              | 2 | # This file is part of Koha. | 
            
              | 3 | # | 
            
              | 4 | # Koha is free software; you can redistribute it and/or modify it under the | 
            
              | 5 | # terms of the GNU General Public License as published by the Free Software | 
            
              | 6 | # Foundation; either version 2 of the License, or (at your option) any later | 
            
              | 7 | # version. | 
            
              | 8 | # | 
            
              | 9 | # Koha is distributed in the hope that it will be useful, but WITHOUT ANY | 
            
              | 10 | # WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR | 
            
              | 11 | # A PARTICULAR PURPOSE.  See the GNU General Public License for more details. | 
            
              | 12 | # | 
            
              | 13 | # You should have received a copy of the GNU General Public License along with | 
            
              | 14 | # Koha; if not, write to the Free Software Foundation, Inc., 59 Temple Place, | 
            
              | 15 | # Suite 330, Boston, MA  02111-1307 USA | 
            
              | 16 | # | 
            
              | 17 |  | 
            
              | 18 | use strict; | 
            
              | 19 | use ExtUtils::MakeMaker::Config; | 
            
              | 20 | use Tie::File; | 
            
              | 21 |  | 
            
              | 22 | my $basedir = (shift); | 
            
              | 23 | my $DEBUG = exists $ENV{'DEBUG'} ? $ENV{'DEBUG'} : 0; | 
            
              | 24 |  | 
            
              | 25 | $DEBUG = 1 if $basedir eq 'test'; | 
            
              | 26 |  | 
            
              | 27 | my $bindir = $Config{installbin}; | 
            
              | 28 | $bindir =~ s!\\!/!g;	# make all directory separators uniform since Win32 does not care and *nix does... | 
            
              | 29 | my $shebang = "#!$bindir\/perl"; | 
            
              | 30 |  | 
            
              | 31 | warn "Perl binary located in $bindir on this system.\n" if $DEBUG; | 
            
              | 32 | warn "The shebang line for this sytems should be $shebang\n\n" if $DEBUG; | 
            
              | 33 |  | 
            
              | 34 | die if $basedir eq 'test'; | 
            
              | 35 |  | 
            
              | 36 | =head1 NAME | 
            
              | 37 |  | 
            
              | 38 | fix-perl-path.PL - A script to correct the shebang line to match the current platform | 
            
              | 39 |  | 
            
              | 40 | =head1 SYNOPSIS | 
            
              | 41 |  | 
            
              | 42 | =head2 BASIC USAGE | 
            
              | 43 |  | 
            
              | 44 |     perl fix-perl-path.PL /absolute/path/to/foo | 
            
              | 45 |  | 
            
              | 46 | =head1 DESCRIPTION | 
            
              | 47 |  | 
            
              | 48 | This script should be run from the base of the directory | 
            
              | 49 | structure which contains the file(s) that need the | 
            
              | 50 | shebang line corrected. It will recurse through all | 
            
              | 51 | directories below the one called from and modify all | 
            
              | 52 | .pl files. | 
            
              | 53 |  | 
            
              | 54 | =head2 fixshebang | 
            
              | 55 |  | 
            
              | 56 | This sub will recurse through a given directory and its subdirectories checking for the existence of a shebang | 
            
              | 57 | line in .pl files and replacing it with the correct line for the current OS if needed. It should be called | 
            
              | 58 | in a manner similar to 'fixshebang (foodir)' but may be supplied with any directory. | 
            
              | 59 |  | 
            
              | 60 | =cut | 
            
              | 61 |  | 
            
              | 62 | sub fixshebang{ | 
            
              | 63 | 	my $dir = shift; | 
            
              | 64 |     opendir my $dh, $dir or die $!; | 
            
              | 65 | 	warn "Reading $dir contents.\n" if $DEBUG; | 
            
              | 66 |     while( my $file = readdir($dh) ) { | 
            
              | 67 | 		# this may be used to exclude any desired files from the scan | 
            
              | 68 |         # if ( $file =~ /foo/ ) { next; } | 
            
              | 69 | 		# handle files... other extensions could be substituted/added if needed | 
            
              | 70 | 		if ( $file =~ /\.pl$/ ) { | 
            
              | 71 |             my @filearray; | 
            
              | 72 | 			my $pathfile =$dir . '/' . $file; | 
            
              | 73 | 			warn "Found a perl script named $pathfile\n" if $DEBUG; | 
            
              | 74 |  | 
            
              | 75 |             # At this point, file is in 'blib' and by default | 
            
              | 76 |             # has mode a-w.  Therefore, must change permission | 
            
              | 77 |             # to make it writable.  Note that stat and chmod | 
            
              | 78 |             # (the Perl functions) should work on Win32 | 
            
              | 79 |             my $old_perm; | 
            
              | 80 |             $old_perm = (stat $pathfile)[2] & 07777; | 
            
              | 81 |             my $new_perm = $old_perm | 0200; | 
            
              | 82 |             chmod $new_perm, $pathfile; | 
            
              | 83 |  | 
            
              | 84 |             # tie the file -- note that we're explicitly setting the line (record) | 
            
              | 85 |             # separator to hex 0A (the Unix newline) because that's what | 
            
              | 86 |             # the files copied to blib are using, regardless of whether the install | 
            
              | 87 |             # is under a Unix variant or Windows. | 
            
              | 88 |             tie @filearray, 'Tie::File', $pathfile, recsep => "\x0a" or die $!; | 
            
              | 89 |  | 
            
              | 90 |             warn "First line of $file is $filearray[0]\n\n" if $DEBUG; | 
            
              | 91 | 			if ( ( $filearray[0] =~ /#!.*perl/ ) && ( $filearray[0] !~ /$shebang|"$shebang -w"/ ) ) { | 
            
              | 92 | 				warn "\n\tRe-writing shebang line for $pathfile\n" if $DEBUG; | 
            
              | 93 |                 warn "\tOriginal shebang line: $filearray[0]\n" if $DEBUG; | 
            
              | 94 |                 $filearray[0] =~ /-w$/ ? $filearray[0] = "$shebang -w" : $filearray[0] = $shebang; | 
            
              | 95 |                 warn "\tNew shebang line is: $filearray[0]\n\n" if $DEBUG; | 
            
              | 96 | 			} | 
            
              | 97 |             elsif ( $filearray[0] =~ /$shebang|"$shebang -w"/ ) { | 
            
              | 98 |                 warn "\n\tShebang line is correct.\n\n" if $DEBUG; | 
            
              | 99 |             } | 
            
              | 100 | 			else { | 
            
              | 101 |                 warn "\n\tNo shebang line found in $pathfile\n\n" if $DEBUG; | 
            
              | 102 | 			} | 
            
              | 103 |             untie @filearray; | 
            
              | 104 |             chmod $old_perm, $pathfile; | 
            
              | 105 | 		} | 
            
              | 106 | 		# handle directories | 
            
              | 107 | 		elsif ( -d ($dir . '/' . $file) && $file !~ /^\.{1,2}/ ) { | 
            
              | 108 | 			my $dirpath = $dir . '/' . $file; | 
            
              | 109 | 			warn "Found a subdir named $dirpath\n" if $DEBUG; | 
            
              | 110 | 			fixshebang ($dirpath); | 
            
              | 111 | 		} | 
            
              | 112 | 	} | 
            
              | 113 | 	closedir $dh; | 
            
              | 114 | } | 
            
              | 115 |  | 
            
              | 116 | fixshebang ($basedir); | 
            
              | 117 |  | 
            
              | 118 | -  |