Generate "Unsupported socket function" stubs using PL_ppaddr.
authorNicholas Clark <nick@ccl4.org>
Sat, 8 Jan 2011 15:56:22 +0000 (15:56 +0000)
committerNicholas Clark <nick@ccl4.org>
Sun, 9 Jan 2011 17:28:17 +0000 (17:28 +0000)
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.

opcode.h
pp.c
pp_sys.c
regen/opcode.pl

index 33b485c..8cc671a 100644 (file)
--- a/opcode.h
+++ b/opcode.h
 #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 ba12f6c..df28740 100644 (file)
--- 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);
 }
 
index 69ca3f9..f8c50d6 100644 (file)
--- 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. */
 
index 94e95e0..701ec27 100755 (executable)
@@ -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;