Finding a way to put "I'm MAINT" in perl -v is a TODO

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index ff5769a..f387cf1 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -847,7 +847,9 @@ perl_destruct(pTHXx)
            svend = &sva[SvREFCNT(sva)];
            for (sv = sva + 1; sv < svend; ++sv) {
                if (SvTYPE(sv) != SVTYPEMASK) {
-                   PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
+                   PerlIO_printf(Perl_debug_log, "leaked: 0x%p"
+                                  pTHX__FORMAT "\n",
+                                  sv pTHX__VALUE);
                }
            }
        }
@@ -1188,8 +1190,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     register SV *sv;
     register char *s;
     char *cddir = Nullch;
-/* PSz 18 Feb 04  fdscript now global, keep from confusion */
-    int dummy_fdscript = -1;
 
     PL_fdscript = -1;
     PL_suidscript = -1;
@@ -1364,7 +1364,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
                    sv_catpv(PL_Sv,"\"  Locally applied patches:\\n\",");
                    for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
                        if (PL_localpatches[i])
-                           Perl_sv_catpvf(aTHX_ PL_Sv,"q\"  \t%s\n\",",PL_localpatches[i]);
+                           Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,",
+                                   0, PL_localpatches[i], 0);
                    }
                }
 #endif
@@ -1499,9 +1500,9 @@ print \"  \\@INC:\\n    @INC\\n\";");
 
     init_perllib();
 
-    open_script(scriptname,dosearch,sv,&dummy_fdscript);
+    open_script(scriptname,dosearch,sv);
 
-    validate_suid(validarg, scriptname,dummy_fdscript);
+    validate_suid(validarg, scriptname);
 
 #ifndef PERL_MICRO
 #if defined(SIGCHLD) || defined(SIGCLD)
@@ -2382,6 +2383,33 @@ NULL
 int
 Perl_get_debug_opts(pTHX_ char **s)
 {
+    static char *usage_msgd[] = {
+      " Debugging flag values: (see also -d)",
+      "  p  Tokenizing and parsing (with v, displays parse stack)",
+      "  s  Stack snapshots. with v, displays all stacks",
+      "  l  Context (loop) stack processing",
+      "  t  Trace execution",
+      "  o  Method and overloading resolution",
+      "  c  String/numeric conversions",
+      "  P  Print profiling info, preprocessor command for -P, source file input state",
+      "  m  Memory allocation",
+      "  f  Format processing",
+      "  r  Regular expression parsing and execution",
+      "  x  Syntax tree dump",
+      "  u  Tainting checks (Obsolete, previously used for LEAKTEST)",
+      "  H  Hash dump -- usurps values()",
+      "  X  Scratchpad allocation",
+      "  D  Cleaning up",
+      "  S  Thread synchronization",
+      "  T  Tokenising",
+      "  R  Include reference counts of dumped variables (eg when using -Ds)",
+      "  J  Do not s,t,P-debug (Jump over) opcodes within package DB",
+      "  v  Verbose: use in conjunction with other flags",
+      "  C  Copy On Write",
+      "  A  Consistency checks on internal structures",
+      "  q  quiet - currently only suppressed the 'EXECUTING' message",
+      NULL
+    };
     int i = 0;
     if (isALPHA(**s)) {
        /* if adding extra options, remember to update DEBUG_MASK */
@@ -2392,14 +2420,18 @@ Perl_get_debug_opts(pTHX_ char **s)
            if (d)
                i |= 1 << (d - debopts);
            else if (ckWARN_d(WARN_DEBUGGING))
-               Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
-                   "invalid option -D%c\n", **s);
+               Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
+                   "invalid option -D%c, use -D'' to see choices\n", **s);
        }
     }
-    else {
+    else if (isDIGIT(**s)) {
        i = atoi(*s);
        for (; isALNUM(**s); (*s)++) ;
     }
+    else {
+      char **p = usage_msgd;
+      while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
+    }
 #  ifdef EBCDIC
     if ((i & DEBUG_p_FLAG) && ckWARN_d(WARN_DEBUGGING))
        Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
@@ -2514,7 +2546,7 @@ Perl_moreswitches(pTHX_ char *s)
 #else /* !DEBUGGING */
        if (ckWARN_d(WARN_DEBUGGING))
            Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
-                  "Recompile perl with -DDEBUGGING to use -D switch\n");
+                  "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n");
        for (s++; isALNUM(*s); s++) ;
 #endif
        /*SUPPRESS 530*/
@@ -2934,7 +2966,7 @@ S_init_main_stash(pTHX)
 
 /* PSz 18 Nov 03  fdscript now global but do not change prototype */
 STATIC void
-S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *dummy_fdscript)
+S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
 {
 #ifndef IAMSUID
     char *quote;
@@ -3000,7 +3032,10 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *dummy_fdscript
     }
 #ifdef IAMSUID
     else {
-       Perl_croak(aTHX_ "suidperl needs fd script\n");
+       Perl_croak(aTHX_ "sperl needs fd script\n"
+                  "You should not call sperl directly; do you need to "
+                  "change a #! line\nfrom sperl to perl?\n");
+
 /* PSz 11 Nov 03
  * Do not open (or do other fancy stuff) while setuid.
  * Perl does the open, and hands script to suidperl on a fd;
@@ -3091,9 +3126,10 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *dummy_fdscript
     }
 #endif /* IAMSUID */
     if (!PL_rsfp) {
-/* PSz 16 Sep 03  Keep neat error message */
-            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
-                       CopFILE(PL_curcop), Strerror(errno));
+       /* PSz 16 Sep 03  Keep neat error message */
+       Perl_croak(aTHX_ "Can't open perl script \"%s\": %s%s\n",
+               CopFILE(PL_curcop), Strerror(errno),
+               ".\nUse -S to search $PATH for it.");
     }
 }
 
@@ -3232,9 +3268,8 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
 }
 #endif /* IAMSUID */
 
-/* PSz 18 Nov 03  fdscript now global but do not change prototype */
 STATIC void
-S_validate_suid(pTHX_ char *validarg, char *scriptname, int dummy_fdscript)
+S_validate_suid(pTHX_ char *validarg, char *scriptname)
 {
 #ifdef IAMSUID
     /* int which; */
@@ -4581,7 +4616,7 @@ Perl_my_failure_exit(pTHX)
            STATUS_NATIVE_SET(44);
     }
     else {
-       if (!vaxc$errno && errno)       /* unlikely */
+       if (!vaxc$errno)                /* unlikely */
            STATUS_NATIVE_SET(44);
        else
            STATUS_NATIVE_SET(vaxc$errno);