This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In regen_lib.pl use a meaningful key for storing the file's name.
[perl5.git] / regen / regen_lib.pl
index 9008629..b4d9f86 100644 (file)
@@ -3,6 +3,7 @@ use strict;
 use vars qw($Needs_Write $Verbose @Changed $TAP);
 use File::Compare;
 use Symbol;
 use vars qw($Needs_Write $Verbose @Changed $TAP);
 use File::Compare;
 use Symbol;
+use Text::Wrap;
 
 # Common functions needed by the regen scripts
 
 
 # Common functions needed by the regen scripts
 
@@ -64,14 +65,64 @@ sub safer_open {
     my $name = shift;
     my $fh = gensym;
     open $fh, ">$name" or die "Can't create $name: $!";
     my $name = shift;
     my $fh = gensym;
     open $fh, ">$name" or die "Can't create $name: $!";
-    *{$fh}->{SCALAR} = $name;
+    *{$fh}->{name} = $name;
     binmode $fh;
     $fh;
 }
 
 sub safer_close {
     my $fh = shift;
     binmode $fh;
     $fh;
 }
 
 sub safer_close {
     my $fh = shift;
-    close $fh or die 'Error closing ' . *{$fh}->{SCALAR} . ": $!";
+    close $fh or die 'Error closing ' . *{$fh}->{name} . ": $!";
+}
+
+sub read_only_top {
+    my %args = @_;
+    die "Missing language argument" unless defined $args{lang};
+    die "Unknown language argument '$args{lang}'"
+       unless $args{lang} eq 'Perl' or $args{lang} eq 'C';
+    my $style = $args{style} ? " $args{style} " : '   ';
+
+    my $raw = "-*- buffer-read-only: t -*-\n";
+
+    if ($args{file}) {
+       $raw .= "\n   $args{file}\n";
+    }
+    if ($args{copyright}) {
+       local $" = ', ';
+       local $Text::Wrap::columns = 75;
+       $raw .= wrap('   ', '   ', <<"EOM") . "\n";
+
+Copyright (C) @{$args{copyright}} by\0Larry\0Wall\0and\0others
+
+You may distribute under the terms of either the GNU General Public
+License or the Artistic License, as specified in the README file.
+EOM
+    }
+
+    $raw .= "!!!!!!!   DO NOT EDIT THIS FILE   !!!!!!!\n";
+
+    if ($args{by}) {
+       $raw .= "This file is built by $args{by}";
+       if ($args{from}) {
+           my @from = ref $args{from} eq 'ARRAY' ? @{$args{from}} : $args{from};
+           my $last = pop @from;
+           if (@from) {
+               $raw .= ' from ' . join (', ', @from) . " and $last";
+           } else {
+               $raw .= " from $last";
+           }
+       }
+       $raw .= ".\n";
+    }
+    $raw .= "Any changes made here will be lost!\n";
+    $raw .= $args{final} if $args{final};
+
+    local $Text::Wrap::columns = 78;
+    my $cooked = $args{lang} eq 'Perl'
+       ? wrap('# ', '# ', $raw) . "\n" : wrap('/* ', $style, $raw) . " */\n\n";
+    $cooked =~ tr/\0/ /; # Don't break Larry's name etc
+    $cooked =~ s/ +$//mg; # Remove all trailing spaces
+    return $cooked;
 }
 
 1;
 }
 
 1;