3 use vars qw($Needs_Write $Verbose @Changed $TAP);
8 # Common functions needed by the regen scripts
10 $Needs_Write = $^O eq 'cygwin' || $^O eq 'os2' || $^O eq 'MSWin32';
13 @ARGV = grep { not($_ eq '-q' and $Verbose = -1) }
14 grep { not($_ eq '--tap' and $TAP = 1) }
15 grep { not($_ eq '-v' and $Verbose = 1) } @ARGV;
18 print STDOUT "Changed: @Changed\n" if @Changed;
26 foreach $name (@names) {
28 chmod 0777, $name if $Needs_Write;
29 ( CORE::unlink($name) and ++$cnt
30 or warn "Couldn't unlink $name: $!\n" );
35 sub safer_rename_silent {
38 # Some dosish systems can't rename over an existing file:
40 chmod 0600, $from if $Needs_Write;
44 sub rename_if_different {
48 my $not = compare($from, $to) ? 'not ' : '';
49 print STDOUT $not . "ok - $0 $to\n";
53 if (compare($from, $to) == 0) {
54 warn "no changes between '$from' & '$to'\n" if $Verbose > 0;
58 warn "changed '$from' to '$to'\n" if $Verbose > 0;
59 push @Changed, $to unless $Verbose < 0;
60 safer_rename_silent($from, $to) or die "renaming $from to $to: $!";
63 # Saf*er*, but not totally safe. And assumes always open for output.
65 my ($name, $final_name) = @_;
67 unlink $name or die "$name exists but can't unlink: $!";
70 open $fh, ">$name" or die "Can't create $name: $!";
71 *{$fh}->{name} = $name;
72 *{$fh}->{final_name} = $final_name if defined $final_name;
79 close $fh or die 'Error closing ' . *{$fh}->{name} . ": $!";
84 die "Missing language argument" unless defined $args{lang};
85 die "Unknown language argument '$args{lang}'"
86 unless $args{lang} eq 'Perl' or $args{lang} eq 'C';
87 my $style = $args{style} ? " $args{style} " : ' ';
89 my $raw = "-*- buffer-read-only: t -*-\n";
92 $raw .= "\n $args{file}\n";
94 if ($args{copyright}) {
96 local $Text::Wrap::columns = 75;
97 $raw .= wrap(' ', ' ', <<"EOM") . "\n";
99 Copyright (C) @{$args{copyright}} by\0Larry\0Wall\0and\0others
101 You may distribute under the terms of either the GNU General Public
102 License or the Artistic License, as specified in the README file.
106 $raw .= "!!!!!!! DO NOT EDIT THIS FILE !!!!!!!\n";
109 $raw .= "This file is built by $args{by}";
111 my @from = ref $args{from} eq 'ARRAY' ? @{$args{from}} : $args{from};
112 my $last = pop @from;
114 $raw .= ' from ' . join (', ', @from) . " and $last";
116 $raw .= " from $last";
121 $raw .= "Any changes made here will be lost!\n";
122 $raw .= $args{final} if $args{final};
124 local $Text::Wrap::columns = 78;
125 my $cooked = $args{lang} eq 'Perl'
126 ? wrap('# ', '# ', $raw) . "\n" : wrap('/* ', $style, $raw) . " */\n\n";
127 $cooked =~ tr/\0/ /; # Don't break Larry's name etc
128 $cooked =~ s/ +$//mg; # Remove all trailing spaces
132 sub close_and_rename {
134 my $name = *{$fh}->{name};
135 die "No final name specified at open time for $name"
136 unless *{$fh}->{final_name};
138 rename_if_different($name, *{$fh}->{final_name});