Mercurial > repo
comparison perl-5.22.2/os2/perl2cmd.pl @ 8045:a16537d2fe07
<xfix> tar xf perl-5.22.2.tar.gz # Ah, whatever, I\'m doing it anyway
author | HackBot |
---|---|
date | Sat, 14 May 2016 14:54:38 +0000 |
parents | |
children |
comparison
equal
deleted
inserted
replaced
8044:711c038a7dce | 8045:a16537d2fe07 |
---|---|
1 # This will put installed perl files into some other location | |
2 # Note that we cannot put hashbang to be extproc to make Configure work. | |
3 | |
4 use Config; | |
5 use File::Compare; | |
6 | |
7 $dir = shift; | |
8 $dir =~ s|/|\\|g ; | |
9 $nowarn = 1, $dir = shift if $dir eq '-n'; | |
10 | |
11 die <<EOU unless defined $dir and -d $dir; | |
12 usage: $^X $0 [-n] directory-to-install | |
13 -n do not check whether the directory is not on path | |
14 EOU | |
15 | |
16 @path = split /;/, $ENV{PATH}; | |
17 $idir = $Config{installbin}; | |
18 $indir =~ s|\\|/|g ; | |
19 | |
20 my %seen; | |
21 | |
22 foreach $file (<$idir/*>) { | |
23 next if $file =~ /\.(exe|bak)/i; | |
24 $base = $file; | |
25 $base =~ s/\.$//; # just in case... | |
26 $base =~ s|.*/||; | |
27 $base =~ s|\.pl$||; | |
28 #$file =~ s|/|\\|g ; | |
29 warn "Clashing output name for $file, skipping" if $seen{$base}++; | |
30 my $new = (-f "$dir/$base.cmd" ? '' : ' (new file)'); | |
31 print "Processing $file => $dir/$base.cmd$new\n"; | |
32 my $ext = ($new ? '.cmd' : '.tcm'); | |
33 open IN, '<', $file or warn, next; | |
34 open OUT, '>', "$dir/$base$ext" or warn, next; | |
35 my $firstline = <IN>; | |
36 my $flags = ''; | |
37 $flags = $2 if $firstline =~ /^#!\s*(\S+)\s+-([^#]+?)\s*(#|$)/; | |
38 print OUT "extproc perl -S$flags\n$firstline"; | |
39 print OUT $_ while <IN>; | |
40 close IN or warn, next; | |
41 close OUT or warn, next; | |
42 chmod 0444, "$dir/$base$ext"; | |
43 next if $new; | |
44 if (compare "$dir/$base$ext", "$dir/$base.cmd") { # different | |
45 chmod 0666, "$dir/$base.cmd"; | |
46 unlink "$dir/$base.cmd"; | |
47 rename "$dir/$base$ext", "$dir/$base.cmd"; | |
48 } else { | |
49 chmod 0666, "$dir/$base$ext"; | |
50 unlink "$dir/$base$ext"; | |
51 print "...unchanged...\n"; | |
52 } | |
53 } | |
54 |