This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
In regen scripts, print to explicit file handles instead of using select.
authorNicholas Clark <nick@ccl4.org>
Sun, 23 Jan 2011 11:15:14 +0000 (11:15 +0000)
committerNicholas Clark <nick@ccl4.org>
Sun, 23 Jan 2011 11:15:14 +0000 (11:15 +0000)
Also put explicit quotes on heredoc declarations to show whether they should
interpolate, merge some heredocs, and remove & from calls to &tab(...)

regen/keywords.pl
regen/opcode.pl
regen/overload.pl
regen/reentr.pl

index 1a84112..9b06182 100755 (executable)
@@ -15,11 +15,10 @@ use strict;
 require 'regen/regen_lib.pl';
 
 my $kw = safer_open('keywords.h-new', 'keywords.h');
-select $kw;
 
-print read_only_top(lang => 'C', by => 'regen/keywords.pl', from => 'its data',
-                   file => 'keywords.h', style => '*',
-                   copyright => [1994 .. 1997, 1999 .. 2002, 2005 .. 2007]);
+print $kw read_only_top(lang => 'C', by => 'regen/keywords.pl',
+                       from => 'its data', file => 'keywords.h', style => '*',
+                       copyright => [1994 .. 1997, 1999 .. 2002, 2005 .. 2007]);
 
 # Read & print data.
 
@@ -29,7 +28,7 @@ while (<DATA>) {
     next unless $_;
     next if /^#/;
     my ($keyword) = split;
-    print &tab(5, "#define KEY_$keyword"), $keynum++, "\n";
+    print $kw tab(5, "#define KEY_$keyword"), $keynum++, "\n";
 }
 
 read_only_bottom_close_and_rename($kw);
index 9b970ad..4902e00 100755 (executable)
@@ -22,7 +22,6 @@ BEGIN {
 
 my $oc = safer_open('opcode.h-new', 'opcode.h');
 my $on = safer_open('opnames.h-new', 'opnames.h');
-select $oc;
 
 # Read data.
 
@@ -139,9 +138,9 @@ foreach my $sock_func (qw(socket bind listen accept shutdown
 
 # Emit defines.
 
-print read_only_top(lang => 'C', by => 'regen/opcode.pl', from => 'its data',
-                   file => 'opcode.h', style => '*',
-                   copyright => [1993 .. 2007]),
+print $oc read_only_top(lang => 'C', by => 'regen/opcode.pl', from => 'its data',
+                       file => 'opcode.h', style => '*',
+                       copyright => [1993 .. 2007]),
     "#ifndef PERL_GLOBAL_STRUCT_INIT\n\n";
 
 {
@@ -150,11 +149,11 @@ print read_only_top(lang => 'C', by => 'regen/opcode.pl', from => 'its data',
 
     sub unimplemented {
        if (@unimplemented) {
-           print "#else\n";
+           print $oc "#else\n";
            foreach (@unimplemented) {
-               print "#define $_ Perl_unimplemented_op\n";
+               print $oc "#define $_ Perl_unimplemented_op\n";
            }
-           print "#endif\n";
+           print $oc "#endif\n";
            @unimplemented = ();
        }
 
@@ -169,11 +168,11 @@ print read_only_top(lang => 'C', by => 'regen/opcode.pl', from => 'its data',
            unimplemented();
            $last_cond = $cond;
            if ($last_cond) {
-               print "$last_cond\n";
+               print $oc "$last_cond\n";
            }
        }
        push @unimplemented, $op_func if $last_cond;
-       print "#define $op_func $impl\n" if $impl ne $op_func;
+       print $oc "#define $op_func $impl\n" if $impl ne $op_func;
     }
     # If the last op was conditional, we need to close it out:
     unimplemented();
@@ -186,15 +185,15 @@ print $on read_only_top(lang => 'C', by => 'regen/opcode.pl',
 
 my $i = 0;
 for (@ops) {
-      print $on "\t", &tab(3,"OP_\U$_"), " = ", $i++, ",\n";
+      print $on "\t", tab(3,"OP_\U$_"), " = ", $i++, ",\n";
 }
-print $on "\t", &tab(3,"OP_max"), "\n";
+print $on "\t", tab(3,"OP_max"), "\n";
 print $on "} opcode;\n";
 print $on "\n#define MAXO ", scalar @ops, "\n";
 
 # Emit op names and descriptions.
 
-print <<END;
+print $oc <<'END';
 START_EXTERN_C
 
 #ifndef DOINIT
@@ -204,16 +203,13 @@ EXTCONST char* const PL_op_name[] = {
 END
 
 for (@ops) {
-    print qq(\t"$_",\n);
+    print $oc qq(\t"$_",\n);
 }
 
-print <<END;
+print $oc <<'END';
 };
 #endif
 
-END
-
-print <<END;
 #ifndef DOINIT
 EXTCONST char* const PL_op_desc[];
 #else
@@ -226,10 +222,10 @@ for (@ops) {
     # Have to escape double quotes and escape characters.
     $safe_desc =~ s/([\\"])/\\$1/g;
 
-    print qq(\t"$safe_desc",\n);
+    print $oc qq(\t"$safe_desc",\n);
 }
 
-print <<END;
+print $oc <<'END';
 };
 #endif
 
@@ -240,7 +236,7 @@ END
 
 # Emit ppcode switch array.
 
-print <<END;
+print $oc <<'END';
 
 START_EXTERN_C
 
@@ -262,25 +258,20 @@ for (@ops) {
     my $op_func = "Perl_pp_$_";
     my $name = $alias{$_};
     if ($name && $name->[0] ne $op_func) {
-       print "\t$op_func,\t/* implemented by $name->[0] */\n";
+       print $oc "\t$op_func,\t/* implemented by $name->[0] */\n";
     }
     else {
-       print "\t$op_func,\n";
+       print $oc "\t$op_func,\n";
     }
 }
 
-print <<END;
+print $oc <<'END';
 }
 #endif
 #ifdef PERL_PPADDR_INITED
 ;
 #endif
 
-END
-
-# Emit check routines.
-
-print <<END;
 #ifdef PERL_GLOBAL_STRUCT_INIT
 #  define PERL_CHECK_INITED
 static const Perl_check_t Gcheck[]
@@ -296,23 +287,16 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 END
 
 for (@ops) {
-    print "\t", &tab(3, "Perl_$check{$_},"), "\t/* $_ */\n";
+    print $oc "\t", tab(3, "Perl_$check{$_},"), "\t/* $_ */\n";
 }
 
-print <<END;
+print $oc <<'END';
 }
 #endif
 #ifdef PERL_CHECK_INITED
 ;
 #endif /* #ifdef PERL_CHECK_INITED */
 
-END
-
-# Emit allowed argument types.
-
-my $ARGBITS = 32;
-
-print <<END;
 #ifndef PERL_GLOBAL_STRUCT_INIT
 
 #ifndef DOINIT
@@ -321,6 +305,10 @@ EXTCONST U32 PL_opargs[];
 EXTCONST U32 PL_opargs[] = {
 END
 
+# Emit allowed argument types.
+
+my $ARGBITS = 32;
+
 my %argnum = (
     'S',  1,           # scalar
     'L',  2,           # list
@@ -398,10 +386,10 @@ for my $op (@ops) {
        $argshift += 4;
     }
     $argsum = sprintf("0x%08x", $argsum);
-    print "\t", &tab(3, "$argsum,"), "/* $op */\n";
+    print $oc "\t", tab(3, "$argsum,"), "/* $op */\n";
 }
 
-print <<END;
+print $oc <<'END';
 };
 #endif
 
@@ -412,7 +400,7 @@ END
 
 # Emit OP_IS_* macros
 
-print $on <<EO_OP_IS_COMMENT;
+print $on <<'EO_OP_IS_COMMENT';
 
 /* the OP_IS_(SOCKET|FILETEST) macros are optimized to a simple range
     check because all the member OPs are contiguous in opcode.pl
index fa22bd5..88e2153 100644 (file)
@@ -35,15 +35,12 @@ my $h = safer_open('overload.h-new', 'overload.h');
 mkdir("lib/overload", 0777) unless -d 'lib/overload';
 my $p = safer_open('lib/overload/numbers.pm-new', 'lib/overload/numbers.pm');
 
-
-select $p;
-
-print read_only_top(lang => 'Perl', by => 'regen/overload.pl',
-                   file => 'lib/overload/numbers.pm', copyright => [2008]);
+print $p read_only_top(lang => 'Perl', by => 'regen/overload.pl',
+                      file => 'lib/overload/numbers.pm', copyright => [2008]);
 
 {
 local $" = "\n    ";
-print <<"EOF";
+print $p <<"EOF";
 package overload::numbers;
 
 our \@names = qw#
@@ -68,8 +65,7 @@ for ([$c, 'overload.c'], [$h, 'overload.h']) {
                                             2005 .. 2007, 2011]);
 }
 
-select $h;
-print "enum {\n";
+print $h "enum {\n";
 
 for (0..$#enums) {
     my $op = $names[$_];
@@ -78,11 +74,11 @@ for (0..$#enums) {
     die if $op =~ m{\*/};
     my $l =   3 - int((length($enums[$_]) + 9) / 8);
     $l = 1 if $l < 1;
-    printf "    %s_amg,%s/* 0x%02x %-8s */\n", $enums[$_],
+    printf $h "    %s_amg,%s/* 0x%02x %-8s */\n", $enums[$_],
        ("\t" x $l), $_, $op;
 }
 
-print <<'EOF';
+print $h <<'EOF';
     max_amg_code
     /* Do not leave a trailing comma here.  C9X allows it, C89 doesn't. */
 };
index 6c7b5e6..69f92d1 100644 (file)
@@ -52,13 +52,12 @@ my %map = (
 
 
 my $h = safer_open('reentr.h-new', 'reentr.h');
-select $h;
-print read_only_top(lang => 'C', by => 'regen/reentr.pl',
-                   from => 'data in regen/reentr.pl',
-                   file => 'reentr.h', style => '*',
-                   copyright => [2002, 2003, 2005 .. 2007]);
+print $h read_only_top(lang => 'C', by => 'regen/reentr.pl',
+                      from => 'data in regen/reentr.pl',
+                      file => 'reentr.h', style => '*',
+                      copyright => [2002, 2003, 2005 .. 2007]);
 
-print <<EOF;
+print $h <<EOF;
 #ifndef REENTR_H
 #define REENTR_H
 
@@ -202,7 +201,6 @@ while (<DATA>) { # Read in the protypes.
     # If given the -U option open up the metaconfig unit for this function.
     if ($opts{U} && open(U, ">d_${func}_r.U"))  {
        binmode U;
-       select U;
     }
 
     if ($opts{U}) {
@@ -223,7 +221,7 @@ while (<DATA>) { # Read in the protypes.
            push @prereq, 'i_systime';
        }
        # Output the metaconfig unit header.
-       print <<EOF;
+       print U <<"EOF";
 ?RCS: \$Id: d_${func}_r.U,v $
 ?RCS:
 ?RCS: Copyright (c) 2002,2003 Jarkko Hietaniemi
@@ -268,7 +266,7 @@ eval \$inlibc
 case "\$d_${func}_r" in
 "\$define")
 EOF
-       print <<EOF;
+       print U <<"EOF";
        hdrs="$hdrs"
        case "\$d_${func}_r_proto:\$usethreads" in
        ":define")      d_${func}_r_proto=define
@@ -284,7 +282,7 @@ EOF
         my ($r, $a) = ($p =~ /^(.)_(.+)/);
        my $v = join(", ", map { $m{$_} } split '', $a);
        if ($opts{U}) {
-           print <<EOF ;
+           print U <<"EOF";
        case "\$${func}_r_proto" in
        ''|0) try='$m{$r} ${func}_r($v);'
        ./protochk "extern \$try" \$hdrs && ${func}_r_proto=$p ;;
@@ -300,7 +298,7 @@ EOF
        $seenm{$func} = \%m;
     }
     if ($opts{U}) {
-       print <<EOF;
+       print U <<"EOF";
        case "\$${func}_r_proto" in
        ''|0)   d_${func}_r=undef
                ${func}_r_proto=0
@@ -331,15 +329,11 @@ EOF
 
 close DATA;
 
-# Prepare to continue writing the reentr.h.
-
-select $h;
-
 {
     # Write out all the known prototype signatures.
     my $i = 1;
     for my $p (sort keys %seenp) {
-       print "#define REENTRANT_PROTO_${p}     ${i}\n";
+       print $h "#define REENTRANT_PROTO_${p}  ${i}\n";
        $i++;
     }
 }
@@ -765,7 +759,7 @@ EOF
 
 local $" = '';
 
-print <<EOF;
+print $h <<EOF;
 
 /* Defines for indicating which special features are supported. */
 
@@ -789,7 +783,6 @@ read_only_bottom_close_and_rename($h);
 # Prepare to write the reentr.c.
 
 my $c = safer_open('reentr.c-new', 'reentr.c');
-select $c;
 my $top = read_only_top(lang => 'C', by => 'regen/reentr.pl',
                        from => 'data in regen/reentr.pl',
                        file => 'reentr.c', style => '*',
@@ -808,7 +801,7 @@ $top =~ s! \*/\n! *
  */
 !s;
 
-print $top, <<EOF;
+print $c $top, <<"EOF";
 #include "EXTERN.h"
 #define PERL_IN_REENTR_C
 #include "perl.h"