Generate "Unsupported socket function" stubs using PL_ppaddr.

Instead of having each socket op conditionally compile as either the
implementation or a DIE() depending on #HAS_SOCKET

1: remove the conditional code from the ops themselves
2: only compile the ops if HAS_SOCKET is defined
3: general conditional code for the intialisation of PL_ppaddr - as appropriate
   either the ops, or Perl_unimplemented_op
4: Amend Perl_unimplemented_op to generate the appropriate DIE() for socket
   ops (ie not the "panic"... message)

Whilst this complicates the support code in regen/opcode.pl, it's already a
net saving of 5 lines in the C code.

4 files changed, 90 insertions, 51 deletions

diff --git a/opcode.h b/opcode.h
index 33b485cf8b..8cc671a806 100644
--- a/opcode.h
+++ b/opcode.h
@@ -53,11 +53,29 @@
 #define Perl_pp_say Perl_pp_print
 #define Perl_pp_seek Perl_pp_sysseek
 #define Perl_pp_fcntl Perl_pp_ioctl
+#ifdef HAS_SOCKET
 #define Perl_pp_send Perl_pp_syswrite
 #define Perl_pp_recv Perl_pp_sysread
+#else
+#define Perl_pp_send Perl_unimplemented_op
+#define Perl_pp_recv Perl_unimplemented_op
+#define Perl_pp_socket Perl_unimplemented_op
+#endif
+#ifdef HAS_SOCKET
 #define Perl_pp_connect Perl_pp_bind
 #define Perl_pp_gsockopt Perl_pp_ssockopt
 #define Perl_pp_getsockname Perl_pp_getpeername
+#else
+#define Perl_pp_bind Perl_unimplemented_op
+#define Perl_pp_connect Perl_unimplemented_op
+#define Perl_pp_listen Perl_unimplemented_op
+#define Perl_pp_accept Perl_unimplemented_op
+#define Perl_pp_shutdown Perl_unimplemented_op
+#define Perl_pp_gsockopt Perl_unimplemented_op
+#define Perl_pp_ssockopt Perl_unimplemented_op
+#define Perl_pp_getsockname Perl_unimplemented_op
+#define Perl_pp_getpeername Perl_unimplemented_op
+#endif
 #define Perl_pp_lstat Perl_pp_stat
 #define Perl_pp_ftrwrite Perl_pp_ftrread
 #define Perl_pp_ftrexec Perl_pp_ftrread
diff --git a/pp.c b/pp.c
index ba12f6c84c..df28740929 100644
--- a/pp.c
+++ b/pp.c
@@ -6306,6 +6306,8 @@ PP(unimplemented_op)
        NULL doesn't generate a useful error message. "custom" does. */
     const char *const name = op_type >= OP_max
 	? "[out of range]" : PL_op_name[PL_op->op_type];
+    if(OP_IS_SOCKET(op_type))
+	DIE(aTHX_ PL_no_sock_func, name);
     DIE(aTHX_ "panic: unimplemented op %s (#%d) called", name,	op_type);
 }
 
diff --git a/pp_sys.c b/pp_sys.c
index 69ca3f9c2b..f8c50d6615 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -1680,9 +1680,6 @@ PP(pp_sysread)
 	PUSHs(TARG);
 	RETURN;
     }
-#else
-    if (PL_op->op_type == OP_RECV)
-	DIE(aTHX_ PL_no_sock_func, "recv");
 #endif
     if (DO_UTF8(bufsv)) {
 	/* offset adjust in characters not bytes */
@@ -1892,8 +1889,8 @@ PP(pp_syswrite)
 	}
     }
 
-    if (op_type == OP_SEND) {
 #ifdef HAS_SOCKET
+    if (op_type == OP_SEND) {
 	const int flags = SvIVx(*++MARK);
 	if (SP > MARK) {
 	    STRLEN mlen;
@@ -1905,10 +1902,10 @@ PP(pp_syswrite)
 	    retval
 		= PerlSock_send(PerlIO_fileno(IoIFP(io)), buffer, blen, flags);
 	}
-#else
-	DIE(aTHX_ PL_no_sock_func, "send");
+    }
+    else
 #endif
-    } else {
+    {
 	Size_t length = 0; /* This length is in characters.  */
 	STRLEN blen_chars;
 	IV offset;
@@ -2366,9 +2363,10 @@ PP(pp_flock)
 
 /* Sockets. */
 
+#ifdef HAS_SOCKET
+
 PP(pp_socket)
 {
-#ifdef HAS_SOCKET
     dVAR; dSP;
     const int protocol = POPi;
     const int type = POPi;
@@ -2410,10 +2408,8 @@ PP(pp_socket)
 #endif
 
     RETPUSHYES;
-#else
-    DIE(aTHX_ PL_no_sock_func, "socket");
-#endif
 }
+#endif
 
 PP(pp_sockpair)
 {
@@ -2470,9 +2466,10 @@ PP(pp_sockpair)
 #endif
 }
 
+#ifdef HAS_SOCKET
+
 PP(pp_bind)
 {
-#ifdef HAS_SOCKET
     dVAR; dSP;
     SV * const addrsv = POPs;
     /* OK, so on what platform does bind modify addr?  */
@@ -2499,14 +2496,10 @@ nuts:
     report_evil_fh(gv);
     SETERRNO(EBADF,SS_IVCHAN);
     RETPUSHUNDEF;
-#else
-    DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
-#endif
 }
 
 PP(pp_listen)
 {
-#ifdef HAS_SOCKET
     dVAR; dSP;
     const int backlog = POPi;
     GV * const gv = MUTABLE_GV(POPs);
@@ -2524,14 +2517,10 @@ nuts:
     report_evil_fh(gv);
     SETERRNO(EBADF,SS_IVCHAN);
     RETPUSHUNDEF;
-#else
-    DIE(aTHX_ PL_no_sock_func, "listen");
-#endif
 }
 
 PP(pp_accept)
 {
-#ifdef HAS_SOCKET
     dVAR; dSP; dTARGET;
     register IO *nstio;
     register IO *gstio;
@@ -2602,14 +2591,10 @@ nuts:
 badexit:
     RETPUSHUNDEF;
 
-#else
-    DIE(aTHX_ PL_no_sock_func, "accept");
-#endif
 }
 
 PP(pp_shutdown)
 {
-#ifdef HAS_SOCKET
     dVAR; dSP; dTARGET;
     const int how = POPi;
     GV * const gv = MUTABLE_GV(POPs);
@@ -2625,14 +2610,10 @@ nuts:
     report_evil_fh(gv);
     SETERRNO(EBADF,SS_IVCHAN);
     RETPUSHUNDEF;
-#else
-    DIE(aTHX_ PL_no_sock_func, "shutdown");
-#endif
 }
 
 PP(pp_ssockopt)
 {
-#ifdef HAS_SOCKET
     dVAR; dSP;
     const int optype = PL_op->op_type;
     SV * const sv = (optype == OP_GSOCKOPT) ? sv_2mortal(newSV(257)) : POPs;
@@ -2701,14 +2682,10 @@ nuts:
 nuts2:
     RETPUSHUNDEF;
 
-#else
-    DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
-#endif
 }
 
 PP(pp_getpeername)
 {
-#ifdef HAS_SOCKET
     dVAR; dSP;
     const int optype = PL_op->op_type;
     GV * const gv = MUTABLE_GV(POPs);
@@ -2763,11 +2740,9 @@ nuts:
     SETERRNO(EBADF,SS_IVCHAN);
 nuts2:
     RETPUSHUNDEF;
+}
 
-#else
-    DIE(aTHX_ PL_no_sock_func, PL_op_desc[PL_op->op_type]);
 #endif
-}
 
 /* Stat calls. */
 
diff --git a/regen/opcode.pl b/regen/opcode.pl
index 94e95e0138..701ec27bf5 100755
--- a/regen/opcode.pl
+++ b/regen/opcode.pl
@@ -69,11 +69,11 @@ my @raw_alias = (
 		 Perl_pp_goto => ['dump'],
 		 Perl_pp_require => ['dofile'],
 		 Perl_pp_untie => ['dbmclose'],
-		 Perl_pp_sysread => [qw(read recv)],
+		 Perl_pp_sysread => {read => '', recv => '#ifdef HAS_SOCKET'},
 		 Perl_pp_sysseek => ['seek'],
 		 Perl_pp_ioctl => ['fcntl'],
-		 Perl_pp_ssockopt => ['gsockopt'],
-		 Perl_pp_getpeername => ['getsockname'],
+		 Perl_pp_ssockopt => {gsockopt => '#ifdef HAS_SOCKET'},
+		 Perl_pp_getpeername => {getsockname => '#ifdef HAS_SOCKET'},
 		 Perl_pp_stat => ['lstat'],
 		 Perl_pp_ftrowned => [qw(fteowned ftzero ftsock ftchr ftblk
 					 ftfile ftdir ftpipe ftsuid ftsgid
@@ -94,7 +94,7 @@ my @raw_alias = (
 		 Perl_pp_ftrread => [qw(ftrwrite ftrexec fteread ftewrite
  					fteexec)],
 		 Perl_pp_shmwrite => [qw(shmread msgsnd msgrcv semop)],
-		 Perl_pp_syswrite => ['send'],
+		 Perl_pp_syswrite => {send => '#ifdef HAS_SOCKET'},
 		 Perl_pp_defined => [qw(dor dorassign)],
                  Perl_pp_and => ['andassign'],
 		 Perl_pp_or => ['orassign'],
@@ -109,10 +109,10 @@ my @raw_alias = (
 		 Perl_pp_rv2av => ['rv2hv'],
 		 Perl_pp_akeys => ['avalues'],
 		 Perl_pp_rkeys => [qw(rvalues reach)],
-		 Perl_pp_trans => ['transr'],
-		 Perl_pp_chop => ['chomp'],
-		 Perl_pp_schop => ['schomp'],
-		 Perl_pp_bind => ['connect'],
+		 Perl_pp_trans => [qw(trans transr)],
+		 Perl_pp_chop => [qw(chop chomp)],
+		 Perl_pp_schop => [qw(schop schomp)],
+		 Perl_pp_bind => {connect => '#ifdef HAS_SOCKET'},
 		 Perl_pp_preinc => ['i_preinc'],
 		 Perl_pp_predec => ['i_predec'],
 		 Perl_pp_postinc => ['i_postinc'],
@@ -120,11 +120,22 @@ my @raw_alias = (
 		);
 
 while (my ($func, $names) = splice @raw_alias, 0, 2) {
-    foreach (@$names) {
-	$alias{$_} = $func;
+    if (ref $names eq 'ARRAY') {
+	foreach (@$names) {
+	    $alias{$_} = [$func, ''];
+	}
+    } else {
+	while (my ($opname, $cond) = each %$names) {
+	    $alias{$opname} = [$func, $cond];
+	}
     }
 }
 
+foreach my $sock_func (qw(socket bind listen accept shutdown
+			  ssockopt getpeername)) {
+    $alias{$sock_func} = ["Perl_pp_$sock_func", '#ifdef HAS_SOCKET'],
+}
+
 # Emit defines.
 
 print <<"END";
@@ -147,8 +158,39 @@ print <<"END";
 
 END
 
-for (@ops) {
-    print "#define Perl_pp_$_ $alias{$_}\n" if $alias{$_};
+{
+    my $last_cond = '';
+    my @unimplemented;
+
+    sub unimplemented {
+	if (@unimplemented) {
+	    print "#else\n";
+	    foreach (@unimplemented) {
+		print "#define $_ Perl_unimplemented_op\n";
+	    }
+	    print "#endif\n";
+	    @unimplemented = ();
+	}
+
+    }
+
+    for (@ops) {
+	my ($impl, $cond) = @{$alias{$_} || ["Perl_pp_$_", '']};
+	my $op_func = "Perl_pp_$_";
+
+	if ($cond ne $last_cond) {
+	    # A change in condition. (including to or from no condition)
+	    unimplemented();
+	    $last_cond = $cond;
+	    if ($last_cond) {
+		print "$last_cond\n";
+	    }
+	}
+	push @unimplemented, $op_func if $last_cond;
+	print "#define $op_func $impl\n" if $impl ne $op_func;
+    }
+    # If the last op was conditional, we need to close it out:
+    unimplemented();
 }
 
 print $on <<"END";
@@ -246,11 +288,13 @@ EXT Perl_ppaddr_t PL_ppaddr[] /* or perlvars.h */
 END
 
 for (@ops) {
-    if (my $name = $alias{$_}) {
-	print "\tPerl_pp_$_,\t/* implemented by $name */\n";
+    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";
     }
     else {
-	print "\tPerl_pp_$_,\n";
+	print "\t$op_func,\n";
     }
 }
 
@@ -465,7 +509,7 @@ END
 {
     my %funcs;
     for (@ops) {
-	my $name = $alias{$_} || "Perl_pp_$_";
+	my $name = $alias{$_} ? $alias{$_}[0] : "Perl_pp_$_";
 	++$funcs{$name};
     }
     print $pp "PERL_CALLCONV OP *$_(pTHX);\n" foreach sort keys %funcs;