home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / perl560.zip / util.c < prev    next >
C/C++ Source or Header  |  2000-03-22  |  88KB  |  3,830 lines
  1. /*    util.c
  2.  *
  3.  *    Copyright (c) 1991-2000, Larry Wall
  4.  *
  5.  *    You may distribute under the terms of either the GNU General Public
  6.  *    License or the Artistic License, as specified in the README file.
  7.  *
  8.  */
  9.  
  10. /*
  11.  * "Very useful, no doubt, that was to Saruman; yet it seems that he was
  12.  * not content."  --Gandalf
  13.  */
  14.  
  15. #include "EXTERN.h"
  16. #define PERL_IN_UTIL_C
  17. #include "perl.h"
  18.  
  19. #if !defined(NSIG) || defined(M_UNIX) || defined(M_XENIX)
  20. #include <signal.h>
  21. #endif
  22.  
  23. #ifndef SIG_ERR
  24. # define SIG_ERR ((Sighandler_t) -1)
  25. #endif
  26.  
  27. /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
  28. #ifdef I_UNISTD
  29. #  include <unistd.h>
  30. #endif
  31.  
  32. #ifdef I_VFORK
  33. #  include <vfork.h>
  34. #endif
  35.  
  36. /* Put this after #includes because fork and vfork prototypes may
  37.    conflict.
  38. */
  39. #ifndef HAS_VFORK
  40. #   define vfork fork
  41. #endif
  42.  
  43. #ifdef I_SYS_WAIT
  44. #  include <sys/wait.h>
  45. #endif
  46.  
  47. #ifdef I_LOCALE
  48. #  include <locale.h>
  49. #endif
  50.  
  51. #define FLUSH
  52.  
  53. #ifdef LEAKTEST
  54.  
  55. long xcount[MAXXCOUNT];
  56. long lastxcount[MAXXCOUNT];
  57. long xycount[MAXXCOUNT][MAXYCOUNT];
  58. long lastxycount[MAXXCOUNT][MAXYCOUNT];
  59.  
  60. #endif
  61.  
  62. #if defined(HAS_FCNTL) && defined(F_SETFD) && !defined(FD_CLOEXEC)
  63. #  define FD_CLOEXEC 1            /* NeXT needs this */
  64. #endif
  65.  
  66. /* paranoid version of system's malloc() */
  67.  
  68. /* NOTE:  Do not call the next three routines directly.  Use the macros
  69.  * in handy.h, so that we can easily redefine everything to do tracking of
  70.  * allocated hunks back to the original New to track down any memory leaks.
  71.  * XXX This advice seems to be widely ignored :-(   --AD  August 1996.
  72.  */
  73.  
  74. Malloc_t
  75. Perl_safesysmalloc(MEM_SIZE size)
  76. {
  77.     dTHX;
  78.     Malloc_t ptr;
  79. #ifdef HAS_64K_LIMIT
  80.     if (size > 0xffff) {
  81.         PerlIO_printf(Perl_error_log,
  82.               "Allocation too large: %lx\n", size) FLUSH;
  83.         my_exit(1);
  84.     }
  85. #endif /* HAS_64K_LIMIT */
  86. #ifdef DEBUGGING
  87.     if ((long)size < 0)
  88.     Perl_croak_nocontext("panic: malloc");
  89. #endif
  90.     ptr = PerlMem_malloc(size?size:1);    /* malloc(0) is NASTY on our system */
  91.     PERL_ALLOC_CHECK(ptr);
  92.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) malloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
  93.     if (ptr != Nullch)
  94.     return ptr;
  95.     else if (PL_nomemok)
  96.     return Nullch;
  97.     else {
  98.     PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
  99.     my_exit(1);
  100.         return Nullch;
  101.     }
  102.     /*NOTREACHED*/
  103. }
  104.  
  105. /* paranoid version of system's realloc() */
  106.  
  107. Malloc_t
  108. Perl_safesysrealloc(Malloc_t where,MEM_SIZE size)
  109. {
  110.     dTHX;
  111.     Malloc_t ptr;
  112. #if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO)
  113.     Malloc_t PerlMem_realloc();
  114. #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */
  115.  
  116. #ifdef HAS_64K_LIMIT 
  117.     if (size > 0xffff) {
  118.     PerlIO_printf(Perl_error_log,
  119.               "Reallocation too large: %lx\n", size) FLUSH;
  120.     my_exit(1);
  121.     }
  122. #endif /* HAS_64K_LIMIT */
  123.     if (!size) {
  124.     safesysfree(where);
  125.     return NULL;
  126.     }
  127.  
  128.     if (!where)
  129.     return safesysmalloc(size);
  130. #ifdef DEBUGGING
  131.     if ((long)size < 0)
  132.     Perl_croak_nocontext("panic: realloc");
  133. #endif
  134.     ptr = PerlMem_realloc(where,size);
  135.     PERL_ALLOC_CHECK(ptr);
  136.  
  137.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) rfree\n",PTR2UV(where),(long)PL_an++));
  138.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) realloc %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)size));
  139.  
  140.     if (ptr != Nullch)
  141.     return ptr;
  142.     else if (PL_nomemok)
  143.     return Nullch;
  144.     else {
  145.     PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
  146.     my_exit(1);
  147.     return Nullch;
  148.     }
  149.     /*NOTREACHED*/
  150. }
  151.  
  152. /* safe version of system's free() */
  153.  
  154. Free_t
  155. Perl_safesysfree(Malloc_t where)
  156. {
  157. #ifdef PERL_IMPLICIT_SYS
  158.     dTHX;
  159. #endif
  160.     DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++));
  161.     if (where) {
  162.     /*SUPPRESS 701*/
  163.     PerlMem_free(where);
  164.     }
  165. }
  166.  
  167. /* safe version of system's calloc() */
  168.  
  169. Malloc_t
  170. Perl_safesyscalloc(MEM_SIZE count, MEM_SIZE size)
  171. {
  172.     dTHX;
  173.     Malloc_t ptr;
  174.  
  175. #ifdef HAS_64K_LIMIT
  176.     if (size * count > 0xffff) {
  177.     PerlIO_printf(Perl_error_log,
  178.               "Allocation too large: %lx\n", size * count) FLUSH;
  179.     my_exit(1);
  180.     }
  181. #endif /* HAS_64K_LIMIT */
  182. #ifdef DEBUGGING
  183.     if ((long)size < 0 || (long)count < 0)
  184.     Perl_croak_nocontext("panic: calloc");
  185. #endif
  186.     size *= count;
  187.     ptr = PerlMem_malloc(size?size:1);    /* malloc(0) is NASTY on our system */
  188.     PERL_ALLOC_CHECK(ptr);
  189.     DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) calloc %ld x %ld bytes\n",PTR2UV(ptr),(long)PL_an++,(long)count,(long)size));
  190.     if (ptr != Nullch) {
  191.     memset((void*)ptr, 0, size);
  192.     return ptr;
  193.     }
  194.     else if (PL_nomemok)
  195.     return Nullch;
  196.     else {
  197.     PerlIO_puts(Perl_error_log,PL_no_mem) FLUSH;
  198.     my_exit(1);
  199.     return Nullch;
  200.     }
  201.     /*NOTREACHED*/
  202. }
  203.  
  204. #ifdef LEAKTEST
  205.  
  206. struct mem_test_strut {
  207.     union {
  208.     long type;
  209.     char c[2];
  210.     } u;
  211.     long size;
  212. };
  213.  
  214. #    define ALIGN sizeof(struct mem_test_strut)
  215.  
  216. #    define sizeof_chunk(ch) (((struct mem_test_strut*) (ch))->size)
  217. #    define typeof_chunk(ch) \
  218.     (((struct mem_test_strut*) (ch))->u.c[0] + ((struct mem_test_strut*) (ch))->u.c[1]*100)
  219. #    define set_typeof_chunk(ch,t) \
  220.     (((struct mem_test_strut*) (ch))->u.c[0] = t % 100, ((struct mem_test_strut*) (ch))->u.c[1] = t / 100)
  221. #define SIZE_TO_Y(size) ( (size) > MAXY_SIZE                \
  222.               ? MAXYCOUNT - 1                 \
  223.               : ( (size) > 40                 \
  224.                   ? ((size) - 1)/8 + 5            \
  225.                   : ((size) - 1)/4))
  226.  
  227. Malloc_t
  228. Perl_safexmalloc(I32 x, MEM_SIZE size)
  229. {
  230.     register char* where = (char*)safemalloc(size + ALIGN);
  231.  
  232.     xcount[x] += size;
  233.     xycount[x][SIZE_TO_Y(size)]++;
  234.     set_typeof_chunk(where, x);
  235.     sizeof_chunk(where) = size;
  236.     return (Malloc_t)(where + ALIGN);
  237. }
  238.  
  239. Malloc_t
  240. Perl_safexrealloc(Malloc_t wh, MEM_SIZE size)
  241. {
  242.     char *where = (char*)wh;
  243.  
  244.     if (!wh)
  245.     return safexmalloc(0,size);
  246.     
  247.     {
  248.     MEM_SIZE old = sizeof_chunk(where - ALIGN);
  249.     int t = typeof_chunk(where - ALIGN);
  250.     register char* new = (char*)saferealloc(where - ALIGN, size + ALIGN);
  251.     
  252.     xycount[t][SIZE_TO_Y(old)]--;
  253.     xycount[t][SIZE_TO_Y(size)]++;
  254.     xcount[t] += size - old;
  255.     sizeof_chunk(new) = size;
  256.     return (Malloc_t)(new + ALIGN);
  257.     }
  258. }
  259.  
  260. void
  261. Perl_safexfree(Malloc_t wh)
  262. {
  263.     I32 x;
  264.     char *where = (char*)wh;
  265.     MEM_SIZE size;
  266.     
  267.     if (!where)
  268.     return;
  269.     where -= ALIGN;
  270.     size = sizeof_chunk(where);
  271.     x = where[0] + 100 * where[1];
  272.     xcount[x] -= size;
  273.     xycount[x][SIZE_TO_Y(size)]--;
  274.     safefree(where);
  275. }
  276.  
  277. Malloc_t
  278. Perl_safexcalloc(I32 x,MEM_SIZE count, MEM_SIZE size)
  279. {
  280.     register char * where = (char*)safexmalloc(x, size * count + ALIGN);
  281.     xcount[x] += size;
  282.     xycount[x][SIZE_TO_Y(size)]++;
  283.     memset((void*)(where + ALIGN), 0, size * count);
  284.     set_typeof_chunk(where, x);
  285.     sizeof_chunk(where) = size;
  286.     return (Malloc_t)(where + ALIGN);
  287. }
  288.  
  289. STATIC void
  290. S_xstat(pTHX_ int flag)
  291. {
  292.     register I32 i, j, total = 0;
  293.     I32 subtot[MAXYCOUNT];
  294.  
  295.     for (j = 0; j < MAXYCOUNT; j++) {
  296.     subtot[j] = 0;
  297.     }
  298.     
  299.     PerlIO_printf(Perl_debug_log, "   Id  subtot   4   8  12  16  20  24  28  32  36  40  48  56  64  72  80 80+\n", total);
  300.     for (i = 0; i < MAXXCOUNT; i++) {
  301.     total += xcount[i];
  302.     for (j = 0; j < MAXYCOUNT; j++) {
  303.         subtot[j] += xycount[i][j];
  304.     }
  305.     if (flag == 0
  306.         ? xcount[i]            /* Have something */
  307.         : (flag == 2 
  308.            ? xcount[i] != lastxcount[i] /* Changed */
  309.            : xcount[i] > lastxcount[i])) { /* Growed */
  310.         PerlIO_printf(Perl_debug_log,"%2d %02d %7ld ", i / 100, i % 100, 
  311.               flag == 2 ? xcount[i] - lastxcount[i] : xcount[i]);
  312.         lastxcount[i] = xcount[i];
  313.         for (j = 0; j < MAXYCOUNT; j++) {
  314.         if ( flag == 0 
  315.              ? xycount[i][j]    /* Have something */
  316.              : (flag == 2 
  317.             ? xycount[i][j] != lastxycount[i][j] /* Changed */
  318.             : xycount[i][j] > lastxycount[i][j])) {    /* Growed */
  319.             PerlIO_printf(Perl_debug_log,"%3ld ", 
  320.                   flag == 2 
  321.                   ? xycount[i][j] - lastxycount[i][j] 
  322.                   : xycount[i][j]);
  323.             lastxycount[i][j] = xycount[i][j];
  324.         } else {
  325.             PerlIO_printf(Perl_debug_log, "  . ", xycount[i][j]);
  326.         }
  327.         }
  328.         PerlIO_printf(Perl_debug_log, "\n");
  329.     }
  330.     }
  331.     if (flag != 2) {
  332.     PerlIO_printf(Perl_debug_log, "Total %7ld ", total);
  333.     for (j = 0; j < MAXYCOUNT; j++) {
  334.         if (subtot[j]) {
  335.         PerlIO_printf(Perl_debug_log, "%3ld ", subtot[j]);
  336.         } else {
  337.         PerlIO_printf(Perl_debug_log, "  . ");
  338.         }
  339.     }
  340.     PerlIO_printf(Perl_debug_log, "\n");    
  341.     }
  342. }
  343.  
  344. #endif /* LEAKTEST */
  345.  
  346. /* copy a string up to some (non-backslashed) delimiter, if any */
  347.  
  348. char *
  349. Perl_delimcpy(pTHX_ register char *to, register char *toend, register char *from, register char *fromend, register int delim, I32 *retlen)
  350. {
  351.     register I32 tolen;
  352.     for (tolen = 0; from < fromend; from++, tolen++) {
  353.     if (*from == '\\') {
  354.         if (from[1] == delim)
  355.         from++;
  356.         else {
  357.         if (to < toend)
  358.             *to++ = *from;
  359.         tolen++;
  360.         from++;
  361.         }
  362.     }
  363.     else if (*from == delim)
  364.         break;
  365.     if (to < toend)
  366.         *to++ = *from;
  367.     }
  368.     if (to < toend)
  369.     *to = '\0';
  370.     *retlen = tolen;
  371.     return from;
  372. }
  373.  
  374. /* return ptr to little string in big string, NULL if not found */
  375. /* This routine was donated by Corey Satten. */
  376.  
  377. char *
  378. Perl_instr(pTHX_ register const char *big, register const char *little)
  379. {
  380.     register const char *s, *x;
  381.     register I32 first;
  382.  
  383.     if (!little)
  384.     return (char*)big;
  385.     first = *little++;
  386.     if (!first)
  387.     return (char*)big;
  388.     while (*big) {
  389.     if (*big++ != first)
  390.         continue;
  391.     for (x=big,s=little; *s; /**/ ) {
  392.         if (!*x)
  393.         return Nullch;
  394.         if (*s++ != *x++) {
  395.         s--;
  396.         break;
  397.         }
  398.     }
  399.     if (!*s)
  400.         return (char*)(big-1);
  401.     }
  402.     return Nullch;
  403. }
  404.  
  405. /* same as instr but allow embedded nulls */
  406.  
  407. char *
  408. Perl_ninstr(pTHX_ register const char *big, register const char *bigend, const char *little, const char *lend)
  409. {
  410.     register const char *s, *x;
  411.     register I32 first = *little;
  412.     register const char *littleend = lend;
  413.  
  414.     if (!first && little >= littleend)
  415.     return (char*)big;
  416.     if (bigend - big < littleend - little)
  417.     return Nullch;
  418.     bigend -= littleend - little++;
  419.     while (big <= bigend) {
  420.     if (*big++ != first)
  421.         continue;
  422.     for (x=big,s=little; s < littleend; /**/ ) {
  423.         if (*s++ != *x++) {
  424.         s--;
  425.         break;
  426.         }
  427.     }
  428.     if (s >= littleend)
  429.         return (char*)(big-1);
  430.     }
  431.     return Nullch;
  432. }
  433.  
  434. /* reverse of the above--find last substring */
  435.  
  436. char *
  437. Perl_rninstr(pTHX_ register const char *big, const char *bigend, const char *little, const char *lend)
  438. {
  439.     register const char *bigbeg;
  440.     register const char *s, *x;
  441.     register I32 first = *little;
  442.     register const char *littleend = lend;
  443.  
  444.     if (!first && little >= littleend)
  445.     return (char*)bigend;
  446.     bigbeg = big;
  447.     big = bigend - (littleend - little++);
  448.     while (big >= bigbeg) {
  449.     if (*big-- != first)
  450.         continue;
  451.     for (x=big+2,s=little; s < littleend; /**/ ) {
  452.         if (*s++ != *x++) {
  453.         s--;
  454.         break;
  455.         }
  456.     }
  457.     if (s >= littleend)
  458.         return (char*)(big+1);
  459.     }
  460.     return Nullch;
  461. }
  462.  
  463. /*
  464.  * Set up for a new ctype locale.
  465.  */
  466. void
  467. Perl_new_ctype(pTHX_ const char *newctype)
  468. {
  469. #ifdef USE_LOCALE_CTYPE
  470.  
  471.     int i;
  472.  
  473.     for (i = 0; i < 256; i++) {
  474.     if (isUPPER_LC(i))
  475.         PL_fold_locale[i] = toLOWER_LC(i);
  476.     else if (isLOWER_LC(i))
  477.         PL_fold_locale[i] = toUPPER_LC(i);
  478.     else
  479.         PL_fold_locale[i] = i;
  480.     }
  481.  
  482. #endif /* USE_LOCALE_CTYPE */
  483. }
  484.  
  485. /*
  486.  * Set up for a new collation locale.
  487.  */
  488. void
  489. Perl_new_collate(pTHX_ const char *newcoll)
  490. {
  491. #ifdef USE_LOCALE_COLLATE
  492.  
  493.     if (! newcoll) {
  494.     if (PL_collation_name) {
  495.         ++PL_collation_ix;
  496.         Safefree(PL_collation_name);
  497.         PL_collation_name = NULL;
  498.         PL_collation_standard = TRUE;
  499.         PL_collxfrm_base = 0;
  500.         PL_collxfrm_mult = 2;
  501.     }
  502.     return;
  503.     }
  504.  
  505.     if (! PL_collation_name || strNE(PL_collation_name, newcoll)) {
  506.     ++PL_collation_ix;
  507.     Safefree(PL_collation_name);
  508.     PL_collation_name = savepv(newcoll);
  509.     PL_collation_standard = (strEQ(newcoll, "C") || strEQ(newcoll, "POSIX"));
  510.  
  511.     {
  512.       /*  2: at most so many chars ('a', 'b'). */
  513.       /* 50: surely no system expands a char more. */
  514. #define XFRMBUFSIZE  (2 * 50)
  515.       char xbuf[XFRMBUFSIZE];
  516.       Size_t fa = strxfrm(xbuf, "a",  XFRMBUFSIZE);
  517.       Size_t fb = strxfrm(xbuf, "ab", XFRMBUFSIZE);
  518.       SSize_t mult = fb - fa;
  519.       if (mult < 1)
  520.           Perl_croak(aTHX_ "strxfrm() gets absurd");
  521.       PL_collxfrm_base = (fa > mult) ? (fa - mult) : 0;
  522.       PL_collxfrm_mult = mult;
  523.     }
  524.     }
  525.  
  526. #endif /* USE_LOCALE_COLLATE */
  527. }
  528.  
  529. void
  530. Perl_set_numeric_radix(pTHX)
  531. {
  532. #ifdef USE_LOCALE_NUMERIC
  533. # ifdef HAS_LOCALECONV
  534.     struct lconv* lc;
  535.  
  536.     lc = localeconv();
  537.     if (lc && lc->decimal_point)
  538.     /* We assume that decimal separator aka the radix
  539.      * character is always a single character.  If it
  540.      * ever is a string, this needs to be rethunk. */
  541.     PL_numeric_radix = *lc->decimal_point;
  542.     else
  543.     PL_numeric_radix = 0;
  544. # endif /* HAS_LOCALECONV */
  545. #endif /* USE_LOCALE_NUMERIC */
  546. }
  547.  
  548. /*
  549.  * Set up for a new numeric locale.
  550.  */
  551. void
  552. Perl_new_numeric(pTHX_ const char *newnum)
  553. {
  554. #ifdef USE_LOCALE_NUMERIC
  555.  
  556.     if (! newnum) {
  557.     if (PL_numeric_name) {
  558.         Safefree(PL_numeric_name);
  559.         PL_numeric_name = NULL;
  560.         PL_numeric_standard = TRUE;
  561.         PL_numeric_local = TRUE;
  562.     }
  563.     return;
  564.     }
  565.  
  566.     if (! PL_numeric_name || strNE(PL_numeric_name, newnum)) {
  567.     Safefree(PL_numeric_name);
  568.     PL_numeric_name = savepv(newnum);
  569.     PL_numeric_standard = (strEQ(newnum, "C") || strEQ(newnum, "POSIX"));
  570.     PL_numeric_local = TRUE;
  571.     set_numeric_radix();
  572.     }
  573.  
  574. #endif /* USE_LOCALE_NUMERIC */
  575. }
  576.  
  577. void
  578. Perl_set_numeric_standard(pTHX)
  579. {
  580. #ifdef USE_LOCALE_NUMERIC
  581.  
  582.     if (! PL_numeric_standard) {
  583.     setlocale(LC_NUMERIC, "C");
  584.     PL_numeric_standard = TRUE;
  585.     PL_numeric_local = FALSE;
  586.     }
  587.  
  588. #endif /* USE_LOCALE_NUMERIC */
  589. }
  590.  
  591. void
  592. Perl_set_numeric_local(pTHX)
  593. {
  594. #ifdef USE_LOCALE_NUMERIC
  595.  
  596.     if (! PL_numeric_local) {
  597.     setlocale(LC_NUMERIC, PL_numeric_name);
  598.     PL_numeric_standard = FALSE;
  599.     PL_numeric_local = TRUE;
  600.     set_numeric_radix();
  601.     }
  602.  
  603. #endif /* USE_LOCALE_NUMERIC */
  604. }
  605.  
  606. /*
  607.  * Initialize locale awareness.
  608.  */
  609. int
  610. Perl_init_i18nl10n(pTHX_ int printwarn)
  611. {
  612.     int ok = 1;
  613.     /* returns
  614.      *    1 = set ok or not applicable,
  615.      *    0 = fallback to C locale,
  616.      *   -1 = fallback to C locale failed
  617.      */
  618.  
  619. #ifdef USE_LOCALE
  620.  
  621. #ifdef USE_LOCALE_CTYPE
  622.     char *curctype   = NULL;
  623. #endif /* USE_LOCALE_CTYPE */
  624. #ifdef USE_LOCALE_COLLATE
  625.     char *curcoll    = NULL;
  626. #endif /* USE_LOCALE_COLLATE */
  627. #ifdef USE_LOCALE_NUMERIC
  628.     char *curnum     = NULL;
  629. #endif /* USE_LOCALE_NUMERIC */
  630. #ifdef __GLIBC__
  631.     char *language   = PerlEnv_getenv("LANGUAGE");
  632. #endif
  633.     char *lc_all     = PerlEnv_getenv("LC_ALL");
  634.     char *lang       = PerlEnv_getenv("LANG");
  635.     bool setlocale_failure = FALSE;
  636.  
  637. #ifdef LOCALE_ENVIRON_REQUIRED
  638.  
  639.     /*
  640.      * Ultrix setlocale(..., "") fails if there are no environment
  641.      * variables from which to get a locale name.
  642.      */
  643.  
  644.     bool done = FALSE;
  645.  
  646. #ifdef LC_ALL
  647.     if (lang) {
  648.     if (setlocale(LC_ALL, ""))
  649.         done = TRUE;
  650.     else
  651.         setlocale_failure = TRUE;
  652.     }
  653.     if (!setlocale_failure) {
  654. #ifdef USE_LOCALE_CTYPE
  655.     if (! (curctype =
  656.            setlocale(LC_CTYPE,
  657.              (!done && (lang || PerlEnv_getenv("LC_CTYPE")))
  658.                     ? "" : Nullch)))
  659.         setlocale_failure = TRUE;
  660. #endif /* USE_LOCALE_CTYPE */
  661. #ifdef USE_LOCALE_COLLATE
  662.     if (! (curcoll =
  663.            setlocale(LC_COLLATE,
  664.              (!done && (lang || PerlEnv_getenv("LC_COLLATE")))
  665.                    ? "" : Nullch)))
  666.         setlocale_failure = TRUE;
  667. #endif /* USE_LOCALE_COLLATE */
  668. #ifdef USE_LOCALE_NUMERIC
  669.     if (! (curnum =
  670.            setlocale(LC_NUMERIC,
  671.              (!done && (lang || PerlEnv_getenv("LC_NUMERIC")))
  672.                   ? "" : Nullch)))
  673.         setlocale_failure = TRUE;
  674. #endif /* USE_LOCALE_NUMERIC */
  675.     }
  676.  
  677. #endif /* LC_ALL */
  678.  
  679. #endif /* !LOCALE_ENVIRON_REQUIRED */
  680.  
  681. #ifdef LC_ALL
  682.     if (! setlocale(LC_ALL, ""))
  683.     setlocale_failure = TRUE;
  684. #endif /* LC_ALL */
  685.  
  686.     if (!setlocale_failure) {
  687. #ifdef USE_LOCALE_CTYPE
  688.     if (! (curctype = setlocale(LC_CTYPE, "")))
  689.         setlocale_failure = TRUE;
  690. #endif /* USE_LOCALE_CTYPE */
  691. #ifdef USE_LOCALE_COLLATE
  692.     if (! (curcoll = setlocale(LC_COLLATE, "")))
  693.         setlocale_failure = TRUE;
  694. #endif /* USE_LOCALE_COLLATE */
  695. #ifdef USE_LOCALE_NUMERIC
  696.     if (! (curnum = setlocale(LC_NUMERIC, "")))
  697.         setlocale_failure = TRUE;
  698. #endif /* USE_LOCALE_NUMERIC */
  699.     }
  700.  
  701.     if (setlocale_failure) {
  702.     char *p;
  703.     bool locwarn = (printwarn > 1 || 
  704.             (printwarn &&
  705.              (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))));
  706.  
  707.     if (locwarn) {
  708. #ifdef LC_ALL
  709.   
  710.         PerlIO_printf(Perl_error_log,
  711.            "perl: warning: Setting locale failed.\n");
  712.  
  713. #else /* !LC_ALL */
  714.   
  715.         PerlIO_printf(Perl_error_log,
  716.            "perl: warning: Setting locale failed for the categories:\n\t");
  717. #ifdef USE_LOCALE_CTYPE
  718.         if (! curctype)
  719.         PerlIO_printf(Perl_error_log, "LC_CTYPE ");
  720. #endif /* USE_LOCALE_CTYPE */
  721. #ifdef USE_LOCALE_COLLATE
  722.         if (! curcoll)
  723.         PerlIO_printf(Perl_error_log, "LC_COLLATE ");
  724. #endif /* USE_LOCALE_COLLATE */
  725. #ifdef USE_LOCALE_NUMERIC
  726.         if (! curnum)
  727.         PerlIO_printf(Perl_error_log, "LC_NUMERIC ");
  728. #endif /* USE_LOCALE_NUMERIC */
  729.         PerlIO_printf(Perl_error_log, "\n");
  730.  
  731. #endif /* LC_ALL */
  732.  
  733.         PerlIO_printf(Perl_error_log,
  734.         "perl: warning: Please check that your locale settings:\n");
  735.  
  736. #ifdef __GLIBC__
  737.         PerlIO_printf(Perl_error_log,
  738.               "\tLANGUAGE = %c%s%c,\n",
  739.               language ? '"' : '(',
  740.               language ? language : "unset",
  741.               language ? '"' : ')');
  742. #endif
  743.  
  744.         PerlIO_printf(Perl_error_log,
  745.               "\tLC_ALL = %c%s%c,\n",
  746.               lc_all ? '"' : '(',
  747.               lc_all ? lc_all : "unset",
  748.               lc_all ? '"' : ')');
  749.  
  750.         {
  751.           char **e;
  752.           for (e = environ; *e; e++) {
  753.           if (strnEQ(*e, "LC_", 3)
  754.             && strnNE(*e, "LC_ALL=", 7)
  755.             && (p = strchr(*e, '=')))
  756.               PerlIO_printf(Perl_error_log, "\t%.*s = \"%s\",\n",
  757.                     (int)(p - *e), *e, p + 1);
  758.           }
  759.         }
  760.  
  761.         PerlIO_printf(Perl_error_log,
  762.               "\tLANG = %c%s%c\n",
  763.               lang ? '"' : '(',
  764.               lang ? lang : "unset",
  765.               lang ? '"' : ')');
  766.  
  767.         PerlIO_printf(Perl_error_log,
  768.               "    are supported and installed on your system.\n");
  769.     }
  770.  
  771. #ifdef LC_ALL
  772.  
  773.     if (setlocale(LC_ALL, "C")) {
  774.         if (locwarn)
  775.         PerlIO_printf(Perl_error_log,
  776.       "perl: warning: Falling back to the standard locale (\"C\").\n");
  777.         ok = 0;
  778.     }
  779.     else {
  780.         if (locwarn)
  781.         PerlIO_printf(Perl_error_log,
  782.       "perl: warning: Failed to fall back to the standard locale (\"C\").\n");
  783.         ok = -1;
  784.     }
  785.  
  786. #else /* ! LC_ALL */
  787.  
  788.     if (0
  789. #ifdef USE_LOCALE_CTYPE
  790.         || !(curctype || setlocale(LC_CTYPE, "C"))
  791. #endif /* USE_LOCALE_CTYPE */
  792. #ifdef USE_LOCALE_COLLATE
  793.         || !(curcoll || setlocale(LC_COLLATE, "C"))
  794. #endif /* USE_LOCALE_COLLATE */
  795. #ifdef USE_LOCALE_NUMERIC
  796.         || !(curnum || setlocale(LC_NUMERIC, "C"))
  797. #endif /* USE_LOCALE_NUMERIC */
  798.         )
  799.     {
  800.         if (locwarn)
  801.         PerlIO_printf(Perl_error_log,
  802.       "perl: warning: Cannot fall back to the standard locale (\"C\").\n");
  803.         ok = -1;
  804.     }
  805.  
  806. #endif /* ! LC_ALL */
  807.  
  808. #ifdef USE_LOCALE_CTYPE
  809.     curctype = setlocale(LC_CTYPE, Nullch);
  810. #endif /* USE_LOCALE_CTYPE */
  811. #ifdef USE_LOCALE_COLLATE
  812.     curcoll = setlocale(LC_COLLATE, Nullch);
  813. #endif /* USE_LOCALE_COLLATE */
  814. #ifdef USE_LOCALE_NUMERIC
  815.     curnum = setlocale(LC_NUMERIC, Nullch);
  816. #endif /* USE_LOCALE_NUMERIC */
  817.     }
  818.  
  819. #ifdef USE_LOCALE_CTYPE
  820.     new_ctype(curctype);
  821. #endif /* USE_LOCALE_CTYPE */
  822.  
  823. #ifdef USE_LOCALE_COLLATE
  824.     new_collate(curcoll);
  825. #endif /* USE_LOCALE_COLLATE */
  826.  
  827. #ifdef USE_LOCALE_NUMERIC
  828.     new_numeric(curnum);
  829. #endif /* USE_LOCALE_NUMERIC */
  830.  
  831. #endif /* USE_LOCALE */
  832.  
  833.     return ok;
  834. }
  835.  
  836. /* Backwards compatibility. */
  837. int
  838. Perl_init_i18nl14n(pTHX_ int printwarn)
  839. {
  840.     return init_i18nl10n(printwarn);
  841. }
  842.  
  843. #ifdef USE_LOCALE_COLLATE
  844.  
  845. /*
  846.  * mem_collxfrm() is a bit like strxfrm() but with two important
  847.  * differences. First, it handles embedded NULs. Second, it allocates
  848.  * a bit more memory than needed for the transformed data itself.
  849.  * The real transformed data begins at offset sizeof(collationix).
  850.  * Please see sv_collxfrm() to see how this is used.
  851.  */
  852. char *
  853. Perl_mem_collxfrm(pTHX_ const char *s, STRLEN len, STRLEN *xlen)
  854. {
  855.     char *xbuf;
  856.     STRLEN xAlloc, xin, xout; /* xalloc is a reserved word in VC */
  857.  
  858.     /* the first sizeof(collationix) bytes are used by sv_collxfrm(). */
  859.     /* the +1 is for the terminating NUL. */
  860.  
  861.     xAlloc = sizeof(PL_collation_ix) + PL_collxfrm_base + (PL_collxfrm_mult * len) + 1;
  862.     New(171, xbuf, xAlloc, char);
  863.     if (! xbuf)
  864.     goto bad;
  865.  
  866.     *(U32*)xbuf = PL_collation_ix;
  867.     xout = sizeof(PL_collation_ix);
  868.     for (xin = 0; xin < len; ) {
  869.     SSize_t xused;
  870.  
  871.     for (;;) {
  872.         xused = strxfrm(xbuf + xout, s + xin, xAlloc - xout);
  873.         if (xused == -1)
  874.         goto bad;
  875.         if (xused < xAlloc - xout)
  876.         break;
  877.         xAlloc = (2 * xAlloc) + 1;
  878.         Renew(xbuf, xAlloc, char);
  879.         if (! xbuf)
  880.         goto bad;
  881.     }
  882.  
  883.     xin += strlen(s + xin) + 1;
  884.     xout += xused;
  885.  
  886.     /* Embedded NULs are understood but silently skipped
  887.      * because they make no sense in locale collation. */
  888.     }
  889.  
  890.     xbuf[xout] = '\0';
  891.     *xlen = xout - sizeof(PL_collation_ix);
  892.     return xbuf;
  893.  
  894.   bad:
  895.     Safefree(xbuf);
  896.     *xlen = 0;
  897.     return NULL;
  898. }
  899.  
  900. #endif /* USE_LOCALE_COLLATE */
  901.  
  902. #define FBM_TABLE_OFFSET 2    /* Number of bytes between EOS and table*/
  903.  
  904. /* As a space optimization, we do not compile tables for strings of length
  905.    0 and 1, and for strings of length 2 unless FBMcf_TAIL.  These are
  906.    special-cased in fbm_instr().
  907.  
  908.    If FBMcf_TAIL, the table is created as if the string has a trailing \n. */
  909.  
  910. /*
  911. =for apidoc fbm_compile
  912.  
  913. Analyses the string in order to make fast searches on it using fbm_instr()
  914. -- the Boyer-Moore algorithm.
  915.  
  916. =cut
  917. */
  918.  
  919. void
  920. Perl_fbm_compile(pTHX_ SV *sv, U32 flags)
  921. {
  922.     register U8 *s;
  923.     register U8 *table;
  924.     register U32 i;
  925.     STRLEN len;
  926.     I32 rarest = 0;
  927.     U32 frequency = 256;
  928.  
  929.     if (flags & FBMcf_TAIL)
  930.     sv_catpvn(sv, "\n", 1);        /* Taken into account in fbm_instr() */
  931.     s = (U8*)SvPV_force(sv, len);
  932.     (void)SvUPGRADE(sv, SVt_PVBM);
  933.     if (len == 0)        /* TAIL might be on on a zero-length string. */
  934.     return;
  935.     if (len > 2) {
  936.     U8 mlen;
  937.     unsigned char *sb;
  938.  
  939.     if (len > 255)
  940.         mlen = 255;
  941.     else
  942.         mlen = (U8)len;
  943.     Sv_Grow(sv, len + 256 + FBM_TABLE_OFFSET);
  944.     table = (unsigned char*)(SvPVX(sv) + len + FBM_TABLE_OFFSET);
  945.     s = table - 1 - FBM_TABLE_OFFSET;    /* last char */
  946.     memset((void*)table, mlen, 256);
  947.     table[-1] = (U8)flags;
  948.     i = 0;
  949.     sb = s - mlen + 1;            /* first char (maybe) */
  950.     while (s >= sb) {
  951.         if (table[*s] == mlen)
  952.         table[*s] = (U8)i;
  953.         s--, i++;
  954.     }
  955.     }
  956.     sv_magic(sv, Nullsv, 'B', Nullch, 0);    /* deep magic */
  957.     SvVALID_on(sv);
  958.  
  959.     s = (unsigned char*)(SvPVX(sv));        /* deeper magic */
  960.     for (i = 0; i < len; i++) {
  961.     if (PL_freq[s[i]] < frequency) {
  962.         rarest = i;
  963.         frequency = PL_freq[s[i]];
  964.     }
  965.     }
  966.     BmRARE(sv) = s[rarest];
  967.     BmPREVIOUS(sv) = rarest;
  968.     BmUSEFUL(sv) = 100;            /* Initial value */
  969.     if (flags & FBMcf_TAIL)
  970.     SvTAIL_on(sv);
  971.     DEBUG_r(PerlIO_printf(Perl_debug_log, "rarest char %c at %d\n",
  972.               BmRARE(sv),BmPREVIOUS(sv)));
  973. }
  974.  
  975. /* If SvTAIL(littlestr), it has a fake '\n' at end. */
  976. /* If SvTAIL is actually due to \Z or \z, this gives false positives
  977.    if multiline */
  978.  
  979. /*
  980. =for apidoc fbm_instr
  981.  
  982. Returns the location of the SV in the string delimited by C<str> and
  983. C<strend>.  It returns C<Nullch> if the string can't be found.  The C<sv>
  984. does not have to be fbm_compiled, but the search will not be as fast
  985. then.
  986.  
  987. =cut
  988. */
  989.  
  990. char *
  991. Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *littlestr, U32 flags)
  992. {
  993.     register unsigned char *s;
  994.     STRLEN l;
  995.     register unsigned char *little = (unsigned char *)SvPV(littlestr,l);
  996.     register STRLEN littlelen = l;
  997.     register I32 multiline = flags & FBMrf_MULTILINE;
  998.  
  999.     if (bigend - big < littlelen) {
  1000.     if ( SvTAIL(littlestr) 
  1001.          && (bigend - big == littlelen - 1)
  1002.          && (littlelen == 1 
  1003.          || (*big == *little && memEQ(big, little, littlelen - 1))))
  1004.         return (char*)big;
  1005.     return Nullch;
  1006.     }
  1007.  
  1008.     if (littlelen <= 2) {        /* Special-cased */
  1009.  
  1010.     if (littlelen == 1) {
  1011.         if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */
  1012.         /* Know that bigend != big.  */
  1013.         if (bigend[-1] == '\n')
  1014.             return (char *)(bigend - 1);
  1015.         return (char *) bigend;
  1016.         }
  1017.         s = big;
  1018.         while (s < bigend) {
  1019.         if (*s == *little)
  1020.             return (char *)s;
  1021.         s++;
  1022.         }
  1023.         if (SvTAIL(littlestr))
  1024.         return (char *) bigend;
  1025.         return Nullch;
  1026.     }
  1027.     if (!littlelen)
  1028.         return (char*)big;        /* Cannot be SvTAIL! */
  1029.  
  1030.     /* littlelen is 2 */
  1031.     if (SvTAIL(littlestr) && !multiline) {
  1032.         if (bigend[-1] == '\n' && bigend[-2] == *little)
  1033.         return (char*)bigend - 2;
  1034.         if (bigend[-1] == *little)
  1035.         return (char*)bigend - 1;
  1036.         return Nullch;
  1037.     }
  1038.     {
  1039.         /* This should be better than FBM if c1 == c2, and almost
  1040.            as good otherwise: maybe better since we do less indirection.
  1041.            And we save a lot of memory by caching no table. */
  1042.         register unsigned char c1 = little[0];
  1043.         register unsigned char c2 = little[1];
  1044.  
  1045.         s = big + 1;
  1046.         bigend--;
  1047.         if (c1 != c2) {
  1048.         while (s <= bigend) {
  1049.             if (s[0] == c2) {
  1050.             if (s[-1] == c1)
  1051.                 return (char*)s - 1;
  1052.             s += 2;
  1053.             continue;
  1054.             }
  1055.           next_chars:
  1056.             if (s[0] == c1) {
  1057.             if (s == bigend)
  1058.                 goto check_1char_anchor;
  1059.             if (s[1] == c2)
  1060.                 return (char*)s;
  1061.             else {
  1062.                 s++;
  1063.                 goto next_chars;
  1064.             }
  1065.             }
  1066.             else
  1067.             s += 2;
  1068.         }
  1069.         goto check_1char_anchor;
  1070.         }
  1071.         /* Now c1 == c2 */
  1072.         while (s <= bigend) {
  1073.         if (s[0] == c1) {
  1074.             if (s[-1] == c1)
  1075.             return (char*)s - 1;
  1076.             if (s == bigend)
  1077.             goto check_1char_anchor;
  1078.             if (s[1] == c1)
  1079.             return (char*)s;
  1080.             s += 3;
  1081.         }
  1082.         else
  1083.             s += 2;
  1084.         }
  1085.     }
  1086.       check_1char_anchor:        /* One char and anchor! */
  1087.     if (SvTAIL(littlestr) && (*bigend == *little))
  1088.         return (char *)bigend;    /* bigend is already decremented. */
  1089.     return Nullch;
  1090.     }
  1091.     if (SvTAIL(littlestr) && !multiline) {    /* tail anchored? */
  1092.     s = bigend - littlelen;
  1093.     if (s >= big && bigend[-1] == '\n' && *s == *little 
  1094.         /* Automatically of length > 2 */
  1095.         && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
  1096.     {
  1097.         return (char*)s;        /* how sweet it is */
  1098.     }
  1099.     if (s[1] == *little
  1100.         && memEQ((char*)s + 2, (char*)little + 1, littlelen - 2))
  1101.     {
  1102.         return (char*)s + 1;    /* how sweet it is */
  1103.     }
  1104.     return Nullch;
  1105.     }
  1106.     if (SvTYPE(littlestr) != SVt_PVBM || !SvVALID(littlestr)) {
  1107.     char *b = ninstr((char*)big,(char*)bigend,
  1108.              (char*)little, (char*)little + littlelen);
  1109.  
  1110.     if (!b && SvTAIL(littlestr)) {    /* Automatically multiline!  */
  1111.         /* Chop \n from littlestr: */
  1112.         s = bigend - littlelen + 1;
  1113.         if (*s == *little
  1114.         && memEQ((char*)s + 1, (char*)little + 1, littlelen - 2))
  1115.         {
  1116.         return (char*)s;
  1117.         }
  1118.         return Nullch;
  1119.     }
  1120.     return b;
  1121.     }
  1122.     
  1123.     {    /* Do actual FBM.  */
  1124.     register unsigned char *table = little + littlelen + FBM_TABLE_OFFSET;
  1125.     register unsigned char *oldlittle;
  1126.  
  1127.     if (littlelen > bigend - big)
  1128.         return Nullch;
  1129.     --littlelen;            /* Last char found by table lookup */
  1130.  
  1131.     s = big + littlelen;
  1132.     little += littlelen;        /* last char */
  1133.     oldlittle = little;
  1134.     if (s < bigend) {
  1135.         register I32 tmp;
  1136.  
  1137.       top2:
  1138.         /*SUPPRESS 560*/
  1139.         if ((tmp = table[*s])) {
  1140. #ifdef POINTERRIGOR
  1141.         if (bigend - s > tmp) {
  1142.             s += tmp;
  1143.             goto top2;
  1144.         }
  1145.         s += tmp;
  1146. #else
  1147.         if ((s += tmp) < bigend)
  1148.             goto top2;
  1149. #endif
  1150.         goto check_end;
  1151.         }
  1152.         else {        /* less expensive than calling strncmp() */
  1153.         register unsigned char *olds = s;
  1154.  
  1155.         tmp = littlelen;
  1156.  
  1157.         while (tmp--) {
  1158.             if (*--s == *--little)
  1159.             continue;
  1160.             s = olds + 1;    /* here we pay the price for failure */
  1161.             little = oldlittle;
  1162.             if (s < bigend)    /* fake up continue to outer loop */
  1163.             goto top2;
  1164.             goto check_end;
  1165.         }
  1166.         return (char *)s;
  1167.         }
  1168.     }
  1169.       check_end:
  1170.     if ( s == bigend && (table[-1] & FBMcf_TAIL)
  1171.          && memEQ(bigend - littlelen, oldlittle - littlelen, littlelen) )
  1172.         return (char*)bigend - littlelen;
  1173.     return Nullch;
  1174.     }
  1175. }
  1176.  
  1177. /* start_shift, end_shift are positive quantities which give offsets
  1178.    of ends of some substring of bigstr.
  1179.    If `last' we want the last occurence.
  1180.    old_posp is the way of communication between consequent calls if
  1181.    the next call needs to find the . 
  1182.    The initial *old_posp should be -1.
  1183.  
  1184.    Note that we take into account SvTAIL, so one can get extra
  1185.    optimizations if _ALL flag is set.
  1186.  */
  1187.  
  1188. /* If SvTAIL is actually due to \Z or \z, this gives false positives
  1189.    if PL_multiline.  In fact if !PL_multiline the autoritative answer
  1190.    is not supported yet. */
  1191.  
  1192. char *
  1193. Perl_screaminstr(pTHX_ SV *bigstr, SV *littlestr, I32 start_shift, I32 end_shift, I32 *old_posp, I32 last)
  1194. {
  1195.     dTHR;
  1196.     register unsigned char *s, *x;
  1197.     register unsigned char *big;
  1198.     register I32 pos;
  1199.     register I32 previous;
  1200.     register I32 first;
  1201.     register unsigned char *little;
  1202.     register I32 stop_pos;
  1203.     register unsigned char *littleend;
  1204.     I32 found = 0;
  1205.  
  1206.     if (*old_posp == -1
  1207.     ? (pos = PL_screamfirst[BmRARE(littlestr)]) < 0
  1208.     : (((pos = *old_posp), pos += PL_screamnext[pos]) == 0)) {
  1209.       cant_find:
  1210.     if ( BmRARE(littlestr) == '\n' 
  1211.          && BmPREVIOUS(littlestr) == SvCUR(littlestr) - 1) {
  1212.         little = (unsigned char *)(SvPVX(littlestr));
  1213.         littleend = little + SvCUR(littlestr);
  1214.         first = *little++;
  1215.         goto check_tail;
  1216.     }
  1217.     return Nullch;
  1218.     }
  1219.  
  1220.     little = (unsigned char *)(SvPVX(littlestr));
  1221.     littleend = little + SvCUR(littlestr);
  1222.     first = *little++;
  1223.     /* The value of pos we can start at: */
  1224.     previous = BmPREVIOUS(littlestr);
  1225.     big = (unsigned char *)(SvPVX(bigstr));
  1226.     /* The value of pos we can stop at: */
  1227.     stop_pos = SvCUR(bigstr) - end_shift - (SvCUR(littlestr) - 1 - previous);
  1228.     if (previous + start_shift > stop_pos) {
  1229.     if (previous + start_shift == stop_pos + 1) /* A fake '\n'? */
  1230.         goto check_tail;
  1231.     return Nullch;
  1232.     }
  1233.     while (pos < previous + start_shift) {
  1234.     if (!(pos += PL_screamnext[pos]))
  1235.         goto cant_find;
  1236.     }
  1237. #ifdef POINTERRIGOR
  1238.     do {
  1239.     if (pos >= stop_pos) break;
  1240.     if (big[pos-previous] != first)
  1241.         continue;
  1242.     for (x=big+pos+1-previous,s=little; s < littleend; /**/ ) {
  1243.         if (*s++ != *x++) {
  1244.         s--;
  1245.         break;
  1246.         }
  1247.     }
  1248.     if (s == littleend) {
  1249.         *old_posp = pos;
  1250.         if (!last) return (char *)(big+pos-previous);
  1251.         found = 1;
  1252.     }
  1253.     } while ( pos += PL_screamnext[pos] );
  1254.     return (last && found) ? (char *)(big+(*old_posp)-previous) : Nullch;
  1255. #else /* !POINTERRIGOR */
  1256.     big -= previous;
  1257.     do {
  1258.     if (pos >= stop_pos) break;
  1259.     if (big[pos] != first)
  1260.         continue;
  1261.     for (x=big+pos+1,s=little; s < littleend; /**/ ) {
  1262.         if (*s++ != *x++) {
  1263.         s--;
  1264.         break;
  1265.         }
  1266.     }
  1267.     if (s == littleend) {
  1268.         *old_posp = pos;
  1269.         if (!last) return (char *)(big+pos);
  1270.         found = 1;
  1271.     }
  1272.     } while ( pos += PL_screamnext[pos] );
  1273.     if (last && found) 
  1274.     return (char *)(big+(*old_posp));
  1275. #endif /* POINTERRIGOR */
  1276.   check_tail:
  1277.     if (!SvTAIL(littlestr) || (end_shift > 0))
  1278.     return Nullch;
  1279.     /* Ignore the trailing "\n".  This code is not microoptimized */
  1280.     big = (unsigned char *)(SvPVX(bigstr) + SvCUR(bigstr));
  1281.     stop_pos = littleend - little;    /* Actual littlestr len */
  1282.     if (stop_pos == 0)
  1283.     return (char*)big;
  1284.     big -= stop_pos;
  1285.     if (*big == first
  1286.     && ((stop_pos == 1) || memEQ(big + 1, little, stop_pos - 1)))
  1287.     return (char*)big;
  1288.     return Nullch;
  1289. }
  1290.  
  1291. I32
  1292. Perl_ibcmp(pTHX_ const char *s1, const char *s2, register I32 len)
  1293. {
  1294.     register U8 *a = (U8 *)s1;
  1295.     register U8 *b = (U8 *)s2;
  1296.     while (len--) {
  1297.     if (*a != *b && *a != PL_fold[*b])
  1298.         return 1;
  1299.     a++,b++;
  1300.     }
  1301.     return 0;
  1302. }
  1303.  
  1304. I32
  1305. Perl_ibcmp_locale(pTHX_ const char *s1, const char *s2, register I32 len)
  1306. {
  1307.     register U8 *a = (U8 *)s1;
  1308.     register U8 *b = (U8 *)s2;
  1309.     while (len--) {
  1310.     if (*a != *b && *a != PL_fold_locale[*b])
  1311.         return 1;
  1312.     a++,b++;
  1313.     }
  1314.     return 0;
  1315. }
  1316.  
  1317. /* copy a string to a safe spot */
  1318.  
  1319. /*
  1320. =for apidoc savepv
  1321.  
  1322. Copy a string to a safe spot.  This does not use an SV.
  1323.  
  1324. =cut
  1325. */
  1326.  
  1327. char *
  1328. Perl_savepv(pTHX_ const char *sv)
  1329. {
  1330.     register char *newaddr;
  1331.  
  1332.     New(902,newaddr,strlen(sv)+1,char);
  1333.     (void)strcpy(newaddr,sv);
  1334.     return newaddr;
  1335. }
  1336.  
  1337. /* same thing but with a known length */
  1338.  
  1339. /*
  1340. =for apidoc savepvn
  1341.  
  1342. Copy a string to a safe spot.  The C<len> indicates number of bytes to
  1343. copy.  This does not use an SV.
  1344.  
  1345. =cut
  1346. */
  1347.  
  1348. char *
  1349. Perl_savepvn(pTHX_ const char *sv, register I32 len)
  1350. {
  1351.     register char *newaddr;
  1352.  
  1353.     New(903,newaddr,len+1,char);
  1354.     Copy(sv,newaddr,len,char);        /* might not be null terminated */
  1355.     newaddr[len] = '\0';        /* is now */
  1356.     return newaddr;
  1357. }
  1358.  
  1359. /* the SV for Perl_form() and mess() is not kept in an arena */
  1360.  
  1361. STATIC SV *
  1362. S_mess_alloc(pTHX)
  1363. {
  1364.     dTHR;
  1365.     SV *sv;
  1366.     XPVMG *any;
  1367.  
  1368.     if (!PL_dirty)
  1369.     return sv_2mortal(newSVpvn("",0));
  1370.  
  1371.     if (PL_mess_sv)
  1372.     return PL_mess_sv;
  1373.  
  1374.     /* Create as PVMG now, to avoid any upgrading later */
  1375.     New(905, sv, 1, SV);
  1376.     Newz(905, any, 1, XPVMG);
  1377.     SvFLAGS(sv) = SVt_PVMG;
  1378.     SvANY(sv) = (void*)any;
  1379.     SvREFCNT(sv) = 1 << 30; /* practically infinite */
  1380.     PL_mess_sv = sv;
  1381.     return sv;
  1382. }
  1383.  
  1384. #if defined(PERL_IMPLICIT_CONTEXT)
  1385. char *
  1386. Perl_form_nocontext(const char* pat, ...)
  1387. {
  1388.     dTHX;
  1389.     char *retval;
  1390.     va_list args;
  1391.     va_start(args, pat);
  1392.     retval = vform(pat, &args);
  1393.     va_end(args);
  1394.     return retval;
  1395. }
  1396. #endif /* PERL_IMPLICIT_CONTEXT */
  1397.  
  1398. char *
  1399. Perl_form(pTHX_ const char* pat, ...)
  1400. {
  1401.     char *retval;
  1402.     va_list args;
  1403.     va_start(args, pat);
  1404.     retval = vform(pat, &args);
  1405.     va_end(args);
  1406.     return retval;
  1407. }
  1408.  
  1409. char *
  1410. Perl_vform(pTHX_ const char *pat, va_list *args)
  1411. {
  1412.     SV *sv = mess_alloc();
  1413.     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
  1414.     return SvPVX(sv);
  1415. }
  1416.  
  1417. #if defined(PERL_IMPLICIT_CONTEXT)
  1418. SV *
  1419. Perl_mess_nocontext(const char *pat, ...)
  1420. {
  1421.     dTHX;
  1422.     SV *retval;
  1423.     va_list args;
  1424.     va_start(args, pat);
  1425.     retval = vmess(pat, &args);
  1426.     va_end(args);
  1427.     return retval;
  1428. }
  1429. #endif /* PERL_IMPLICIT_CONTEXT */
  1430.  
  1431. SV *
  1432. Perl_mess(pTHX_ const char *pat, ...)
  1433. {
  1434.     SV *retval;
  1435.     va_list args;
  1436.     va_start(args, pat);
  1437.     retval = vmess(pat, &args);
  1438.     va_end(args);
  1439.     return retval;
  1440. }
  1441.  
  1442. SV *
  1443. Perl_vmess(pTHX_ const char *pat, va_list *args)
  1444. {
  1445.     SV *sv = mess_alloc();
  1446.     static char dgd[] = " during global destruction.\n";
  1447.  
  1448.     sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*));
  1449.     if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') {
  1450.     dTHR;
  1451.     if (CopLINE(PL_curcop))
  1452.         Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf,
  1453.                CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
  1454.     if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) {
  1455.         bool line_mode = (RsSIMPLE(PL_rs) &&
  1456.                   SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n');
  1457.         Perl_sv_catpvf(aTHX_ sv, ", <%s> %s %"IVdf,
  1458.               PL_last_in_gv == PL_argvgv ? "" : GvNAME(PL_last_in_gv),
  1459.               line_mode ? "line" : "chunk", 
  1460.               (IV)IoLINES(GvIOp(PL_last_in_gv)));
  1461.     }
  1462. #ifdef USE_THREADS
  1463.     if (thr->tid)
  1464.         Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid);
  1465. #endif
  1466.     sv_catpv(sv, PL_dirty ? dgd : ".\n");
  1467.     }
  1468.     return sv;
  1469. }
  1470.  
  1471. OP *
  1472. Perl_vdie(pTHX_ const char* pat, va_list *args)
  1473. {
  1474.     dTHR;
  1475.     char *message;
  1476.     int was_in_eval = PL_in_eval;
  1477.     HV *stash;
  1478.     GV *gv;
  1479.     CV *cv;
  1480.     SV *msv;
  1481.     STRLEN msglen;
  1482.  
  1483.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  1484.               "%p: die: curstack = %p, mainstack = %p\n",
  1485.               thr, PL_curstack, PL_mainstack));
  1486.  
  1487.     if (pat) {
  1488.     msv = vmess(pat, args);
  1489.     if (PL_errors && SvCUR(PL_errors)) {
  1490.         sv_catsv(PL_errors, msv);
  1491.         message = SvPV(PL_errors, msglen);
  1492.         SvCUR_set(PL_errors, 0);
  1493.     }
  1494.     else
  1495.         message = SvPV(msv,msglen);
  1496.     }
  1497.     else {
  1498.     message = Nullch;
  1499.     msglen = 0;
  1500.     }
  1501.  
  1502.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  1503.               "%p: die: message = %s\ndiehook = %p\n",
  1504.               thr, message, PL_diehook));
  1505.     if (PL_diehook) {
  1506.     /* sv_2cv might call Perl_croak() */
  1507.     SV *olddiehook = PL_diehook;
  1508.     ENTER;
  1509.     SAVESPTR(PL_diehook);
  1510.     PL_diehook = Nullsv;
  1511.     cv = sv_2cv(olddiehook, &stash, &gv, 0);
  1512.     LEAVE;
  1513.     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1514.         dSP;
  1515.         SV *msg;
  1516.  
  1517.         ENTER;
  1518.         save_re_context();
  1519.         if (message) {
  1520.         msg = newSVpvn(message, msglen);
  1521.         SvREADONLY_on(msg);
  1522.         SAVEFREESV(msg);
  1523.         }
  1524.         else {
  1525.         msg = ERRSV;
  1526.         }
  1527.  
  1528.         PUSHSTACKi(PERLSI_DIEHOOK);
  1529.         PUSHMARK(SP);
  1530.         XPUSHs(msg);
  1531.         PUTBACK;
  1532.         call_sv((SV*)cv, G_DISCARD);
  1533.         POPSTACK;
  1534.         LEAVE;
  1535.     }
  1536.     }
  1537.  
  1538.     PL_restartop = die_where(message, msglen);
  1539.     DEBUG_S(PerlIO_printf(Perl_debug_log,
  1540.       "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n",
  1541.       thr, PL_restartop, was_in_eval, PL_top_env));
  1542.     if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev)
  1543.     JMPENV_JUMP(3);
  1544.     return PL_restartop;
  1545. }
  1546.  
  1547. #if defined(PERL_IMPLICIT_CONTEXT)
  1548. OP *
  1549. Perl_die_nocontext(const char* pat, ...)
  1550. {
  1551.     dTHX;
  1552.     OP *o;
  1553.     va_list args;
  1554.     va_start(args, pat);
  1555.     o = vdie(pat, &args);
  1556.     va_end(args);
  1557.     return o;
  1558. }
  1559. #endif /* PERL_IMPLICIT_CONTEXT */
  1560.  
  1561. OP *
  1562. Perl_die(pTHX_ const char* pat, ...)
  1563. {
  1564.     OP *o;
  1565.     va_list args;
  1566.     va_start(args, pat);
  1567.     o = vdie(pat, &args);
  1568.     va_end(args);
  1569.     return o;
  1570. }
  1571.  
  1572. void
  1573. Perl_vcroak(pTHX_ const char* pat, va_list *args)
  1574. {
  1575.     dTHR;
  1576.     char *message;
  1577.     HV *stash;
  1578.     GV *gv;
  1579.     CV *cv;
  1580.     SV *msv;
  1581.     STRLEN msglen;
  1582.  
  1583.     msv = vmess(pat, args);
  1584.     if (PL_errors && SvCUR(PL_errors)) {
  1585.     sv_catsv(PL_errors, msv);
  1586.     message = SvPV(PL_errors, msglen);
  1587.     SvCUR_set(PL_errors, 0);
  1588.     }
  1589.     else
  1590.     message = SvPV(msv,msglen);
  1591.  
  1592.     DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s",
  1593.               PTR2UV(thr), message));
  1594.  
  1595.     if (PL_diehook) {
  1596.     /* sv_2cv might call Perl_croak() */
  1597.     SV *olddiehook = PL_diehook;
  1598.     ENTER;
  1599.     SAVESPTR(PL_diehook);
  1600.     PL_diehook = Nullsv;
  1601.     cv = sv_2cv(olddiehook, &stash, &gv, 0);
  1602.     LEAVE;
  1603.     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1604.         dSP;
  1605.         SV *msg;
  1606.  
  1607.         ENTER;
  1608.         save_re_context();
  1609.         msg = newSVpvn(message, msglen);
  1610.         SvREADONLY_on(msg);
  1611.         SAVEFREESV(msg);
  1612.  
  1613.         PUSHSTACKi(PERLSI_DIEHOOK);
  1614.         PUSHMARK(SP);
  1615.         XPUSHs(msg);
  1616.         PUTBACK;
  1617.         call_sv((SV*)cv, G_DISCARD);
  1618.         POPSTACK;
  1619.         LEAVE;
  1620.     }
  1621.     }
  1622.     if (PL_in_eval) {
  1623.     PL_restartop = die_where(message, msglen);
  1624.     JMPENV_JUMP(3);
  1625.     }
  1626.     {
  1627. #ifdef USE_SFIO
  1628.     /* SFIO can really mess with your errno */
  1629.     int e = errno;
  1630. #endif
  1631.     PerlIO *serr = Perl_error_log;
  1632.  
  1633.     PerlIO_write(serr, message, msglen);
  1634.     (void)PerlIO_flush(serr);
  1635. #ifdef USE_SFIO
  1636.     errno = e;
  1637. #endif
  1638.     }
  1639.     my_failure_exit();
  1640. }
  1641.  
  1642. #if defined(PERL_IMPLICIT_CONTEXT)
  1643. void
  1644. Perl_croak_nocontext(const char *pat, ...)
  1645. {
  1646.     dTHX;
  1647.     va_list args;
  1648.     va_start(args, pat);
  1649.     vcroak(pat, &args);
  1650.     /* NOTREACHED */
  1651.     va_end(args);
  1652. }
  1653. #endif /* PERL_IMPLICIT_CONTEXT */
  1654.  
  1655. /*
  1656. =for apidoc croak
  1657.  
  1658. This is the XSUB-writer's interface to Perl's C<die> function.  Use this
  1659. function the same way you use the C C<printf> function.  See
  1660. C<warn>.
  1661.  
  1662. =cut
  1663. */
  1664.  
  1665. void
  1666. Perl_croak(pTHX_ const char *pat, ...)
  1667. {
  1668.     va_list args;
  1669.     va_start(args, pat);
  1670.     vcroak(pat, &args);
  1671.     /* NOTREACHED */
  1672.     va_end(args);
  1673. }
  1674.  
  1675. void
  1676. Perl_vwarn(pTHX_ const char* pat, va_list *args)
  1677. {
  1678.     char *message;
  1679.     HV *stash;
  1680.     GV *gv;
  1681.     CV *cv;
  1682.     SV *msv;
  1683.     STRLEN msglen;
  1684.  
  1685.     msv = vmess(pat, args);
  1686.     message = SvPV(msv, msglen);
  1687.  
  1688.     if (PL_warnhook) {
  1689.     /* sv_2cv might call Perl_warn() */
  1690.     dTHR;
  1691.     SV *oldwarnhook = PL_warnhook;
  1692.     ENTER;
  1693.     SAVESPTR(PL_warnhook);
  1694.     PL_warnhook = Nullsv;
  1695.     cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
  1696.     LEAVE;
  1697.     if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1698.         dSP;
  1699.         SV *msg;
  1700.  
  1701.         ENTER;
  1702.         save_re_context();
  1703.         msg = newSVpvn(message, msglen);
  1704.         SvREADONLY_on(msg);
  1705.         SAVEFREESV(msg);
  1706.  
  1707.         PUSHSTACKi(PERLSI_WARNHOOK);
  1708.         PUSHMARK(SP);
  1709.         XPUSHs(msg);
  1710.         PUTBACK;
  1711.         call_sv((SV*)cv, G_DISCARD);
  1712.         POPSTACK;
  1713.         LEAVE;
  1714.         return;
  1715.     }
  1716.     }
  1717.     {
  1718.     PerlIO *serr = Perl_error_log;
  1719.  
  1720.     PerlIO_write(serr, message, msglen);
  1721. #ifdef LEAKTEST
  1722.     DEBUG_L(*message == '!' 
  1723.         ? (xstat(message[1]=='!'
  1724.              ? (message[2]=='!' ? 2 : 1)
  1725.              : 0)
  1726.            , 0)
  1727.         : 0);
  1728. #endif
  1729.     (void)PerlIO_flush(serr);
  1730.     }
  1731. }
  1732.  
  1733. #if defined(PERL_IMPLICIT_CONTEXT)
  1734. void
  1735. Perl_warn_nocontext(const char *pat, ...)
  1736. {
  1737.     dTHX;
  1738.     va_list args;
  1739.     va_start(args, pat);
  1740.     vwarn(pat, &args);
  1741.     va_end(args);
  1742. }
  1743. #endif /* PERL_IMPLICIT_CONTEXT */
  1744.  
  1745. /*
  1746. =for apidoc warn
  1747.  
  1748. This is the XSUB-writer's interface to Perl's C<warn> function.  Use this
  1749. function the same way you use the C C<printf> function.  See
  1750. C<croak>.
  1751.  
  1752. =cut
  1753. */
  1754.  
  1755. void
  1756. Perl_warn(pTHX_ const char *pat, ...)
  1757. {
  1758.     va_list args;
  1759.     va_start(args, pat);
  1760.     vwarn(pat, &args);
  1761.     va_end(args);
  1762. }
  1763.  
  1764. #if defined(PERL_IMPLICIT_CONTEXT)
  1765. void
  1766. Perl_warner_nocontext(U32 err, const char *pat, ...)
  1767. {
  1768.     dTHX;
  1769.     va_list args;
  1770.     va_start(args, pat);
  1771.     vwarner(err, pat, &args);
  1772.     va_end(args);
  1773. }
  1774. #endif /* PERL_IMPLICIT_CONTEXT */
  1775.  
  1776. void
  1777. Perl_warner(pTHX_ U32  err, const char* pat,...)
  1778. {
  1779.     va_list args;
  1780.     va_start(args, pat);
  1781.     vwarner(err, pat, &args);
  1782.     va_end(args);
  1783. }
  1784.  
  1785. void
  1786. Perl_vwarner(pTHX_ U32  err, const char* pat, va_list* args)
  1787. {
  1788.     dTHR;
  1789.     char *message;
  1790.     HV *stash;
  1791.     GV *gv;
  1792.     CV *cv;
  1793.     SV *msv;
  1794.     STRLEN msglen;
  1795.  
  1796.     msv = vmess(pat, args);
  1797.     message = SvPV(msv, msglen);
  1798.  
  1799.     if (ckDEAD(err)) {
  1800. #ifdef USE_THREADS
  1801.         DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message));
  1802. #endif /* USE_THREADS */
  1803.         if (PL_diehook) {
  1804.             /* sv_2cv might call Perl_croak() */
  1805.             SV *olddiehook = PL_diehook;
  1806.             ENTER;
  1807.             SAVESPTR(PL_diehook);
  1808.             PL_diehook = Nullsv;
  1809.             cv = sv_2cv(olddiehook, &stash, &gv, 0);
  1810.             LEAVE;
  1811.             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1812.                 dSP;
  1813.                 SV *msg;
  1814.  
  1815.                 ENTER;
  1816.         save_re_context();
  1817.                 msg = newSVpvn(message, msglen);
  1818.                 SvREADONLY_on(msg);
  1819.                 SAVEFREESV(msg);
  1820.  
  1821.         PUSHSTACKi(PERLSI_DIEHOOK);
  1822.                 PUSHMARK(sp);
  1823.                 XPUSHs(msg);
  1824.                 PUTBACK;
  1825.                 call_sv((SV*)cv, G_DISCARD);
  1826.         POPSTACK;
  1827.                 LEAVE;
  1828.             }
  1829.         }
  1830.         if (PL_in_eval) {
  1831.             PL_restartop = die_where(message, msglen);
  1832.             JMPENV_JUMP(3);
  1833.         }
  1834.     {
  1835.         PerlIO *serr = Perl_error_log;
  1836.         PerlIO_write(serr, message, msglen);
  1837.         (void)PerlIO_flush(serr);
  1838.     }
  1839.         my_failure_exit();
  1840.  
  1841.     }
  1842.     else {
  1843.         if (PL_warnhook) {
  1844.             /* sv_2cv might call Perl_warn() */
  1845.             dTHR;
  1846.             SV *oldwarnhook = PL_warnhook;
  1847.             ENTER;
  1848.             SAVESPTR(PL_warnhook);
  1849.             PL_warnhook = Nullsv;
  1850.             cv = sv_2cv(oldwarnhook, &stash, &gv, 0);
  1851.         LEAVE;
  1852.             if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) {
  1853.                 dSP;
  1854.                 SV *msg;
  1855.  
  1856.                 ENTER;
  1857.         save_re_context();
  1858.                 msg = newSVpvn(message, msglen);
  1859.                 SvREADONLY_on(msg);
  1860.                 SAVEFREESV(msg);
  1861.  
  1862.         PUSHSTACKi(PERLSI_WARNHOOK);
  1863.                 PUSHMARK(sp);
  1864.                 XPUSHs(msg);
  1865.                 PUTBACK;
  1866.                 call_sv((SV*)cv, G_DISCARD);
  1867.         POPSTACK;
  1868.                 LEAVE;
  1869.                 return;
  1870.             }
  1871.         }
  1872.     {
  1873.         PerlIO *serr = Perl_error_log;
  1874.         PerlIO_write(serr, message, msglen);
  1875. #ifdef LEAKTEST
  1876.         DEBUG_L(xstat());
  1877. #endif
  1878.         (void)PerlIO_flush(serr);
  1879.     }
  1880.     }
  1881. }
  1882.  
  1883. #ifndef VMS  /* VMS' my_setenv() is in VMS.c */
  1884. #if !defined(WIN32) && !defined(__CYGWIN__)
  1885. void
  1886. Perl_my_setenv(pTHX_ char *nam, char *val)
  1887. {
  1888. #ifndef PERL_USE_SAFE_PUTENV
  1889.     /* most putenv()s leak, so we manipulate environ directly */
  1890.     register I32 i=setenv_getix(nam);        /* where does it go? */
  1891.  
  1892.     if (environ == PL_origenviron) {    /* need we copy environment? */
  1893.     I32 j;
  1894.     I32 max;
  1895.     char **tmpenv;
  1896.  
  1897.     /*SUPPRESS 530*/
  1898.     for (max = i; environ[max]; max++) ;
  1899.     tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*));
  1900.     for (j=0; j<max; j++) {        /* copy environment */
  1901.         tmpenv[j] = (char*)safesysmalloc((strlen(environ[j])+1)*sizeof(char));
  1902.         strcpy(tmpenv[j], environ[j]);
  1903.     }
  1904.     tmpenv[max] = Nullch;
  1905.     environ = tmpenv;        /* tell exec where it is now */
  1906.     }
  1907.     if (!val) {
  1908.     safesysfree(environ[i]);
  1909.     while (environ[i]) {
  1910.         environ[i] = environ[i+1];
  1911.         i++;
  1912.     }
  1913.     return;
  1914.     }
  1915.     if (!environ[i]) {            /* does not exist yet */
  1916.     environ = (char**)safesysrealloc(environ, (i+2) * sizeof(char*));
  1917.     environ[i+1] = Nullch;    /* make sure it's null terminated */
  1918.     }
  1919.     else
  1920.     safesysfree(environ[i]);
  1921.     environ[i] = (char*)safesysmalloc((strlen(nam)+strlen(val)+2) * sizeof(char));
  1922.  
  1923.     (void)sprintf(environ[i],"%s=%s",nam,val);/* all that work just for this */
  1924.  
  1925. #else   /* PERL_USE_SAFE_PUTENV */
  1926.     char *new_env;
  1927.  
  1928.     new_env = (char*)safesysmalloc((strlen(nam) + strlen(val) + 2) * sizeof(char));
  1929.     (void)sprintf(new_env,"%s=%s",nam,val);/* all that work just for this */
  1930.     (void)putenv(new_env);
  1931. #endif  /* PERL_USE_SAFE_PUTENV */
  1932. }
  1933.  
  1934. #else /* WIN32 || __CYGWIN__ */
  1935. #if defined(__CYGWIN__)
  1936. /*
  1937.  * Save environ of perl.exe, currently Cygwin links in separate environ's
  1938.  * for each exe/dll.  Probably should be a member of impure_ptr.
  1939.  */
  1940. static char ***Perl_main_environ;
  1941.  
  1942. EXTERN_C void
  1943. Perl_my_setenv_init(char ***penviron)
  1944. {
  1945.     Perl_main_environ = penviron;
  1946. }
  1947.  
  1948. void
  1949. Perl_my_setenv(pTHX_ char *nam, char *val)
  1950. {
  1951.     /* You can not directly manipulate the environ[] array because
  1952.      * the routines do some additional work that syncs the Cygwin
  1953.      * environment with the Windows environment.
  1954.      */
  1955.     char *oldstr = environ[setenv_getix(nam)];
  1956.  
  1957.     if (!val) {
  1958.        if (!oldstr)
  1959.            return;
  1960.        unsetenv(nam);
  1961.        safesysfree(oldstr);
  1962.        return;
  1963.     }
  1964.     setenv(nam, val, 1);
  1965.     environ = *Perl_main_environ; /* environ realloc can occur in setenv */
  1966.     if(oldstr && environ[setenv_getix(nam)] != oldstr)
  1967.        safesysfree(oldstr);
  1968. }
  1969. #else /* if WIN32 */
  1970.  
  1971. void
  1972. Perl_my_setenv(pTHX_ char *nam,char *val)
  1973. {
  1974.  
  1975. #ifdef USE_WIN32_RTL_ENV
  1976.  
  1977.     register char *envstr;
  1978.     STRLEN namlen = strlen(nam);
  1979.     STRLEN vallen;
  1980.     char *oldstr = environ[setenv_getix(nam)];
  1981.  
  1982.     /* putenv() has totally broken semantics in both the Borland
  1983.      * and Microsoft CRTLs.  They either store the passed pointer in
  1984.      * the environment without making a copy, or make a copy and don't
  1985.      * free it. And on top of that, they dont free() old entries that
  1986.      * are being replaced/deleted.  This means the caller must
  1987.      * free any old entries somehow, or we end up with a memory
  1988.      * leak every time my_setenv() is called.  One might think
  1989.      * one could directly manipulate environ[], like the UNIX code
  1990.      * above, but direct changes to environ are not allowed when
  1991.      * calling putenv(), since the RTLs maintain an internal
  1992.      * *copy* of environ[]. Bad, bad, *bad* stink.
  1993.      * GSAR 97-06-07
  1994.      */
  1995.  
  1996.     if (!val) {
  1997.     if (!oldstr)
  1998.         return;
  1999.     val = "";
  2000.     vallen = 0;
  2001.     }
  2002.     else
  2003.     vallen = strlen(val);
  2004.     envstr = (char*)safesysmalloc((namlen + vallen + 3) * sizeof(char));
  2005.     (void)sprintf(envstr,"%s=%s",nam,val);
  2006.     (void)PerlEnv_putenv(envstr);
  2007.     if (oldstr)
  2008.     safesysfree(oldstr);
  2009. #ifdef _MSC_VER
  2010.     safesysfree(envstr);    /* MSVCRT leaks without this */
  2011. #endif
  2012.  
  2013. #else /* !USE_WIN32_RTL_ENV */
  2014.  
  2015.     register char *envstr;
  2016.     STRLEN len = strlen(nam) + 3;
  2017.     if (!val) {
  2018.     val = "";
  2019.     }
  2020.     len += strlen(val);
  2021.     New(904, envstr, len, char);
  2022.     (void)sprintf(envstr,"%s=%s",nam,val);
  2023.     (void)PerlEnv_putenv(envstr);
  2024.     Safefree(envstr);
  2025.  
  2026. #endif
  2027. }
  2028.  
  2029. #endif /* WIN32 */
  2030. #endif
  2031.  
  2032. I32
  2033. Perl_setenv_getix(pTHX_ char *nam)
  2034. {
  2035.     register I32 i, len = strlen(nam);
  2036.  
  2037.     for (i = 0; environ[i]; i++) {
  2038.     if (
  2039. #ifdef WIN32
  2040.         strnicmp(environ[i],nam,len) == 0
  2041. #else
  2042.         strnEQ(environ[i],nam,len)
  2043. #endif
  2044.         && environ[i][len] == '=')
  2045.         break;            /* strnEQ must come first to avoid */
  2046.     }                    /* potential SEGV's */
  2047.     return i;
  2048. }
  2049.  
  2050. #endif /* !VMS */
  2051.  
  2052. #ifdef UNLINK_ALL_VERSIONS
  2053. I32
  2054. Perl_unlnk(pTHX_ char *f)    /* unlink all versions of a file */
  2055. {
  2056.     I32 i;
  2057.  
  2058.     for (i = 0; PerlLIO_unlink(f) >= 0; i++) ;
  2059.     return i ? 0 : -1;
  2060. }
  2061. #endif
  2062.  
  2063. /* this is a drop-in replacement for bcopy() */
  2064. #if !defined(HAS_BCOPY) || !defined(HAS_SAFE_BCOPY)
  2065. char *
  2066. Perl_my_bcopy(register const char *from,register char *to,register I32 len)
  2067. {
  2068.     char *retval = to;
  2069.  
  2070.     if (from - to >= 0) {
  2071.     while (len--)
  2072.         *to++ = *from++;
  2073.     }
  2074.     else {
  2075.     to += len;
  2076.     from += len;
  2077.     while (len--)
  2078.         *(--to) = *(--from);
  2079.     }
  2080.     return retval;
  2081. }
  2082. #endif
  2083.  
  2084. /* this is a drop-in replacement for memset() */
  2085. #ifndef HAS_MEMSET
  2086. void *
  2087. Perl_my_memset(register char *loc, register I32 ch, register I32 len)
  2088. {
  2089.     char *retval = loc;
  2090.  
  2091.     while (len--)
  2092.     *loc++ = ch;
  2093.     return retval;
  2094. }
  2095. #endif
  2096.  
  2097. /* this is a drop-in replacement for bzero() */
  2098. #if !defined(HAS_BZERO) && !defined(HAS_MEMSET)
  2099. char *
  2100. Perl_my_bzero(register char *loc, register I32 len)
  2101. {
  2102.     char *retval = loc;
  2103.  
  2104.     while (len--)
  2105.     *loc++ = 0;
  2106.     return retval;
  2107. }
  2108. #endif
  2109.  
  2110. /* this is a drop-in replacement for memcmp() */
  2111. #if !defined(HAS_MEMCMP) || !defined(HAS_SANE_MEMCMP)
  2112. I32
  2113. Perl_my_memcmp(const char *s1, const char *s2, register I32 len)
  2114. {
  2115.     register U8 *a = (U8 *)s1;
  2116.     register U8 *b = (U8 *)s2;
  2117.     register I32 tmp;
  2118.  
  2119.     while (len--) {
  2120.     if (tmp = *a++ - *b++)
  2121.         return tmp;
  2122.     }
  2123.     return 0;
  2124. }
  2125. #endif /* !HAS_MEMCMP || !HAS_SANE_MEMCMP */
  2126.  
  2127. #ifndef HAS_VPRINTF
  2128.  
  2129. #ifdef USE_CHAR_VSPRINTF
  2130. char *
  2131. #else
  2132. int
  2133. #endif
  2134. vsprintf(char *dest, const char *pat, char *args)
  2135. {
  2136.     FILE fakebuf;
  2137.  
  2138.     fakebuf._ptr = dest;
  2139.     fakebuf._cnt = 32767;
  2140. #ifndef _IOSTRG
  2141. #define _IOSTRG 0
  2142. #endif
  2143.     fakebuf._flag = _IOWRT|_IOSTRG;
  2144.     _doprnt(pat, args, &fakebuf);    /* what a kludge */
  2145.     (void)putc('\0', &fakebuf);
  2146. #ifdef USE_CHAR_VSPRINTF
  2147.     return(dest);
  2148. #else
  2149.     return 0;        /* perl doesn't use return value */
  2150. #endif
  2151. }
  2152.  
  2153. #endif /* HAS_VPRINTF */
  2154.  
  2155. #ifdef MYSWAP
  2156. #if BYTEORDER != 0x4321
  2157. short
  2158. Perl_my_swap(pTHX_ short s)
  2159. {
  2160. #if (BYTEORDER & 1) == 0
  2161.     short result;
  2162.  
  2163.     result = ((s & 255) << 8) + ((s >> 8) & 255);
  2164.     return result;
  2165. #else
  2166.     return s;
  2167. #endif
  2168. }
  2169.  
  2170. long
  2171. Perl_my_htonl(pTHX_ long l)
  2172. {
  2173.     union {
  2174.     long result;
  2175.     char c[sizeof(long)];
  2176.     } u;
  2177.  
  2178. #if BYTEORDER == 0x1234
  2179.     u.c[0] = (l >> 24) & 255;
  2180.     u.c[1] = (l >> 16) & 255;
  2181.     u.c[2] = (l >> 8) & 255;
  2182.     u.c[3] = l & 255;
  2183.     return u.result;
  2184. #else
  2185. #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
  2186.     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
  2187. #else
  2188.     register I32 o;
  2189.     register I32 s;
  2190.  
  2191.     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
  2192.     u.c[o & 0xf] = (l >> s) & 255;
  2193.     }
  2194.     return u.result;
  2195. #endif
  2196. #endif
  2197. }
  2198.  
  2199. long
  2200. Perl_my_ntohl(pTHX_ long l)
  2201. {
  2202.     union {
  2203.     long l;
  2204.     char c[sizeof(long)];
  2205.     } u;
  2206.  
  2207. #if BYTEORDER == 0x1234
  2208.     u.c[0] = (l >> 24) & 255;
  2209.     u.c[1] = (l >> 16) & 255;
  2210.     u.c[2] = (l >> 8) & 255;
  2211.     u.c[3] = l & 255;
  2212.     return u.l;
  2213. #else
  2214. #if ((BYTEORDER - 0x1111) & 0x444) || !(BYTEORDER & 0xf)
  2215.     Perl_croak(aTHX_ "Unknown BYTEORDER\n");
  2216. #else
  2217.     register I32 o;
  2218.     register I32 s;
  2219.  
  2220.     u.l = l;
  2221.     l = 0;
  2222.     for (o = BYTEORDER - 0x1111, s = 0; s < (sizeof(long)*8); o >>= 4, s += 8) {
  2223.     l |= (u.c[o & 0xf] & 255) << s;
  2224.     }
  2225.     return l;
  2226. #endif
  2227. #endif
  2228. }
  2229.  
  2230. #endif /* BYTEORDER != 0x4321 */
  2231. #endif /* MYSWAP */
  2232.  
  2233. /*
  2234.  * Little-endian byte order functions - 'v' for 'VAX', or 'reVerse'.
  2235.  * If these functions are defined,
  2236.  * the BYTEORDER is neither 0x1234 nor 0x4321.
  2237.  * However, this is not assumed.
  2238.  * -DWS
  2239.  */
  2240.  
  2241. #define HTOV(name,type)                        \
  2242.     type                            \
  2243.     name (register type n)                    \
  2244.     {                            \
  2245.         union {                        \
  2246.         type value;                    \
  2247.         char c[sizeof(type)];                \
  2248.         } u;                        \
  2249.         register I32 i;                    \
  2250.         register I32 s;                    \
  2251.         for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {    \
  2252.         u.c[i] = (n >> s) & 0xFF;            \
  2253.         }                            \
  2254.         return u.value;                    \
  2255.     }
  2256.  
  2257. #define VTOH(name,type)                        \
  2258.     type                            \
  2259.     name (register type n)                    \
  2260.     {                            \
  2261.         union {                        \
  2262.         type value;                    \
  2263.         char c[sizeof(type)];                \
  2264.         } u;                        \
  2265.         register I32 i;                    \
  2266.         register I32 s;                    \
  2267.         u.value = n;                    \
  2268.         n = 0;                        \
  2269.         for (i = 0, s = 0; i < sizeof(u.c); i++, s += 8) {    \
  2270.         n += (u.c[i] & 0xFF) << s;            \
  2271.         }                            \
  2272.         return n;                        \
  2273.     }
  2274.  
  2275. #if defined(HAS_HTOVS) && !defined(htovs)
  2276. HTOV(htovs,short)
  2277. #endif
  2278. #if defined(HAS_HTOVL) && !defined(htovl)
  2279. HTOV(htovl,long)
  2280. #endif
  2281. #if defined(HAS_VTOHS) && !defined(vtohs)
  2282. VTOH(vtohs,short)
  2283. #endif
  2284. #if defined(HAS_VTOHL) && !defined(vtohl)
  2285. VTOH(vtohl,long)
  2286. #endif
  2287.  
  2288.     /* VMS' my_popen() is in VMS.c, same with OS/2. */
  2289. #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
  2290. PerlIO *
  2291. Perl_my_popen(pTHX_ char *cmd, char *mode)
  2292. {
  2293.     int p[2];
  2294.     register I32 This, that;
  2295.     register Pid_t pid;
  2296.     SV *sv;
  2297.     I32 doexec = strNE(cmd,"-");
  2298.     I32 did_pipes = 0;
  2299.     int pp[2];
  2300.  
  2301.     PERL_FLUSHALL_FOR_CHILD;
  2302. #ifdef OS2
  2303.     if (doexec) {
  2304.     return my_syspopen(cmd,mode);
  2305.     }
  2306. #endif 
  2307.     This = (*mode == 'w');
  2308.     that = !This;
  2309.     if (doexec && PL_tainting) {
  2310.     taint_env();
  2311.     taint_proper("Insecure %s%s", "EXEC");
  2312.     }
  2313.     if (PerlProc_pipe(p) < 0)
  2314.     return Nullfp;
  2315.     if (doexec && PerlProc_pipe(pp) >= 0)
  2316.     did_pipes = 1;
  2317.     while ((pid = (doexec?vfork():fork())) < 0) {
  2318.     if (errno != EAGAIN) {
  2319.         PerlLIO_close(p[This]);
  2320.         if (did_pipes) {
  2321.         PerlLIO_close(pp[0]);
  2322.         PerlLIO_close(pp[1]);
  2323.         }
  2324.         if (!doexec)
  2325.         Perl_croak(aTHX_ "Can't fork");
  2326.         return Nullfp;
  2327.     }
  2328.     sleep(5);
  2329.     }
  2330.     if (pid == 0) {
  2331.     GV* tmpgv;
  2332.  
  2333. #undef THIS
  2334. #undef THAT
  2335. #define THIS that
  2336. #define THAT This
  2337.     PerlLIO_close(p[THAT]);
  2338.     if (did_pipes) {
  2339.         PerlLIO_close(pp[0]);
  2340. #if defined(HAS_FCNTL) && defined(F_SETFD)
  2341.         fcntl(pp[1], F_SETFD, FD_CLOEXEC);
  2342. #endif
  2343.     }
  2344.     if (p[THIS] != (*mode == 'r')) {
  2345.         PerlLIO_dup2(p[THIS], *mode == 'r');
  2346.         PerlLIO_close(p[THIS]);
  2347.     }
  2348. #ifndef OS2
  2349.     if (doexec) {
  2350. #if !defined(HAS_FCNTL) || !defined(F_SETFD)
  2351.         int fd;
  2352.  
  2353. #ifndef NOFILE
  2354. #define NOFILE 20
  2355. #endif
  2356.         for (fd = PL_maxsysfd + 1; fd < NOFILE; fd++)
  2357.         if (fd != pp[1])
  2358.             PerlLIO_close(fd);
  2359. #endif
  2360.         do_exec3(cmd,pp[1],did_pipes);    /* may or may not use the shell */
  2361.         PerlProc__exit(1);
  2362.     }
  2363. #endif    /* defined OS2 */
  2364.     /*SUPPRESS 560*/
  2365.     if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
  2366.         sv_setiv(GvSV(tmpgv), PerlProc_getpid());
  2367.     PL_forkprocess = 0;
  2368.     hv_clear(PL_pidstatus);    /* we have no children */
  2369.     return Nullfp;
  2370. #undef THIS
  2371. #undef THAT
  2372.     }
  2373.     do_execfree();    /* free any memory malloced by child on vfork */
  2374.     PerlLIO_close(p[that]);
  2375.     if (did_pipes)
  2376.     PerlLIO_close(pp[1]);
  2377.     if (p[that] < p[This]) {
  2378.     PerlLIO_dup2(p[This], p[that]);
  2379.     PerlLIO_close(p[This]);
  2380.     p[This] = p[that];
  2381.     }
  2382.     sv = *av_fetch(PL_fdpid,p[This],TRUE);
  2383.     (void)SvUPGRADE(sv,SVt_IV);
  2384.     SvIVX(sv) = pid;
  2385.     PL_forkprocess = pid;
  2386.     if (did_pipes && pid > 0) {
  2387.     int errkid;
  2388.     int n = 0, n1;
  2389.  
  2390.     while (n < sizeof(int)) {
  2391.         n1 = PerlLIO_read(pp[0],
  2392.                   (void*)(((char*)&errkid)+n),
  2393.                   (sizeof(int)) - n);
  2394.         if (n1 <= 0)
  2395.         break;
  2396.         n += n1;
  2397.     }
  2398.     PerlLIO_close(pp[0]);
  2399.     did_pipes = 0;
  2400.     if (n) {            /* Error */
  2401.         if (n != sizeof(int))
  2402.         Perl_croak(aTHX_ "panic: kid popen errno read");
  2403.         errno = errkid;        /* Propagate errno from kid */
  2404.         return Nullfp;
  2405.     }
  2406.     }
  2407.     if (did_pipes)
  2408.      PerlLIO_close(pp[0]);
  2409.     return PerlIO_fdopen(p[This], mode);
  2410. }
  2411. #else
  2412. #if defined(atarist) || defined(DJGPP)
  2413. FILE *popen();
  2414. PerlIO *
  2415. Perl_my_popen(pTHX_ char *cmd, char *mode)
  2416. {
  2417.     /* Needs work for PerlIO ! */
  2418.     /* used 0 for 2nd parameter to PerlIO-exportFILE; apparently not used */
  2419.     PERL_FLUSHALL_FOR_CHILD;
  2420.     return popen(PerlIO_exportFILE(cmd, 0), mode);
  2421. }
  2422. #endif
  2423.  
  2424. #endif /* !DOSISH */
  2425.  
  2426. #ifdef DUMP_FDS
  2427. void
  2428. Perl_dump_fds(pTHX_ char *s)
  2429. {
  2430.     int fd;
  2431.     struct stat tmpstatbuf;
  2432.  
  2433.     PerlIO_printf(Perl_debug_log,"%s", s);
  2434.     for (fd = 0; fd < 32; fd++) {
  2435.     if (PerlLIO_fstat(fd,&tmpstatbuf) >= 0)
  2436.         PerlIO_printf(Perl_debug_log," %d",fd);
  2437.     }
  2438.     PerlIO_printf(Perl_debug_log,"\n");
  2439. }
  2440. #endif    /* DUMP_FDS */
  2441.  
  2442. #ifndef HAS_DUP2
  2443. int
  2444. dup2(int oldfd, int newfd)
  2445. {
  2446. #if defined(HAS_FCNTL) && defined(F_DUPFD)
  2447.     if (oldfd == newfd)
  2448.     return oldfd;
  2449.     PerlLIO_close(newfd);
  2450.     return fcntl(oldfd, F_DUPFD, newfd);
  2451. #else
  2452. #define DUP2_MAX_FDS 256
  2453.     int fdtmp[DUP2_MAX_FDS];
  2454.     I32 fdx = 0;
  2455.     int fd;
  2456.  
  2457.     if (oldfd == newfd)
  2458.     return oldfd;
  2459.     PerlLIO_close(newfd);
  2460.     /* good enough for low fd's... */
  2461.     while ((fd = PerlLIO_dup(oldfd)) != newfd && fd >= 0) {
  2462.     if (fdx >= DUP2_MAX_FDS) {
  2463.         PerlLIO_close(fd);
  2464.         fd = -1;
  2465.         break;
  2466.     }
  2467.     fdtmp[fdx++] = fd;
  2468.     }
  2469.     while (fdx > 0)
  2470.     PerlLIO_close(fdtmp[--fdx]);
  2471.     return fd;
  2472. #endif
  2473. }
  2474. #endif
  2475.  
  2476.  
  2477. #ifdef HAS_SIGACTION
  2478.  
  2479. Sighandler_t
  2480. Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
  2481. {
  2482.     struct sigaction act, oact;
  2483.  
  2484.     act.sa_handler = handler;
  2485.     sigemptyset(&act.sa_mask);
  2486.     act.sa_flags = 0;
  2487. #ifdef SA_RESTART
  2488.     act.sa_flags |= SA_RESTART;    /* SVR4, 4.3+BSD */
  2489. #endif
  2490. #ifdef SA_NOCLDWAIT
  2491.     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
  2492.     act.sa_flags |= SA_NOCLDWAIT;
  2493. #endif
  2494.     if (sigaction(signo, &act, &oact) == -1)
  2495.         return SIG_ERR;
  2496.     else
  2497.         return oact.sa_handler;
  2498. }
  2499.  
  2500. Sighandler_t
  2501. Perl_rsignal_state(pTHX_ int signo)
  2502. {
  2503.     struct sigaction oact;
  2504.  
  2505.     if (sigaction(signo, (struct sigaction *)NULL, &oact) == -1)
  2506.         return SIG_ERR;
  2507.     else
  2508.         return oact.sa_handler;
  2509. }
  2510.  
  2511. int
  2512. Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
  2513. {
  2514.     struct sigaction act;
  2515.  
  2516.     act.sa_handler = handler;
  2517.     sigemptyset(&act.sa_mask);
  2518.     act.sa_flags = 0;
  2519. #ifdef SA_RESTART
  2520.     act.sa_flags |= SA_RESTART;    /* SVR4, 4.3+BSD */
  2521. #endif
  2522. #ifdef SA_NOCLDWAIT
  2523.     if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
  2524.     act.sa_flags |= SA_NOCLDWAIT;
  2525. #endif
  2526.     return sigaction(signo, &act, save);
  2527. }
  2528.  
  2529. int
  2530. Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
  2531. {
  2532.     return sigaction(signo, save, (struct sigaction *)NULL);
  2533. }
  2534.  
  2535. #else /* !HAS_SIGACTION */
  2536.  
  2537. Sighandler_t
  2538. Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
  2539. {
  2540.     return PerlProc_signal(signo, handler);
  2541. }
  2542.  
  2543. static int sig_trapped;
  2544.  
  2545. static
  2546. Signal_t
  2547. sig_trap(int signo)
  2548. {
  2549.     sig_trapped++;
  2550. }
  2551.  
  2552. Sighandler_t
  2553. Perl_rsignal_state(pTHX_ int signo)
  2554. {
  2555.     Sighandler_t oldsig;
  2556.  
  2557.     sig_trapped = 0;
  2558.     oldsig = PerlProc_signal(signo, sig_trap);
  2559.     PerlProc_signal(signo, oldsig);
  2560.     if (sig_trapped)
  2561.         PerlProc_kill(PerlProc_getpid(), signo);
  2562.     return oldsig;
  2563. }
  2564.  
  2565. int
  2566. Perl_rsignal_save(pTHX_ int signo, Sighandler_t handler, Sigsave_t *save)
  2567. {
  2568.     *save = PerlProc_signal(signo, handler);
  2569.     return (*save == SIG_ERR) ? -1 : 0;
  2570. }
  2571.  
  2572. int
  2573. Perl_rsignal_restore(pTHX_ int signo, Sigsave_t *save)
  2574. {
  2575.     return (PerlProc_signal(signo, *save) == SIG_ERR) ? -1 : 0;
  2576. }
  2577.  
  2578. #endif /* !HAS_SIGACTION */
  2579.  
  2580.     /* VMS' my_pclose() is in VMS.c; same with OS/2 */
  2581. #if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) && !defined(EPOC) && !defined(MACOS_TRADITIONAL)
  2582. I32
  2583. Perl_my_pclose(pTHX_ PerlIO *ptr)
  2584. {
  2585.     Sigsave_t hstat, istat, qstat;
  2586.     int status;
  2587.     SV **svp;
  2588.     Pid_t pid;
  2589.     Pid_t pid2;
  2590.     bool close_failed;
  2591.     int saved_errno;
  2592. #ifdef VMS
  2593.     int saved_vaxc_errno;
  2594. #endif
  2595. #ifdef WIN32
  2596.     int saved_win32_errno;
  2597. #endif
  2598.  
  2599.     svp = av_fetch(PL_fdpid,PerlIO_fileno(ptr),TRUE);
  2600.     pid = SvIVX(*svp);
  2601.     SvREFCNT_dec(*svp);
  2602.     *svp = &PL_sv_undef;
  2603. #ifdef OS2
  2604.     if (pid == -1) {            /* Opened by popen. */
  2605.     return my_syspclose(ptr);
  2606.     }
  2607. #endif 
  2608.     if ((close_failed = (PerlIO_close(ptr) == EOF))) {
  2609.     saved_errno = errno;
  2610. #ifdef VMS
  2611.     saved_vaxc_errno = vaxc$errno;
  2612. #endif
  2613. #ifdef WIN32
  2614.     saved_win32_errno = GetLastError();
  2615. #endif
  2616.     }
  2617. #ifdef UTS
  2618.     if(PerlProc_kill(pid, 0) < 0) { return(pid); }   /* HOM 12/23/91 */
  2619. #endif
  2620.     rsignal_save(SIGHUP, SIG_IGN, &hstat);
  2621.     rsignal_save(SIGINT, SIG_IGN, &istat);
  2622.     rsignal_save(SIGQUIT, SIG_IGN, &qstat);
  2623.     do {
  2624.     pid2 = wait4pid(pid, &status, 0);
  2625.     } while (pid2 == -1 && errno == EINTR);
  2626.     rsignal_restore(SIGHUP, &hstat);
  2627.     rsignal_restore(SIGINT, &istat);
  2628.     rsignal_restore(SIGQUIT, &qstat);
  2629.     if (close_failed) {
  2630.     SETERRNO(saved_errno, saved_vaxc_errno);
  2631.     return -1;
  2632.     }
  2633.     return(pid2 < 0 ? pid2 : status == 0 ? 0 : (errno = 0, status));
  2634. }
  2635. #endif /* !DOSISH */
  2636.  
  2637. #if  (!defined(DOSISH) || defined(OS2) || defined(WIN32)) && !defined(MACOS_TRADITIONAL)
  2638. I32
  2639. Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags)
  2640. {
  2641.     SV *sv;
  2642.     SV** svp;
  2643.     char spid[TYPE_CHARS(int)];
  2644.  
  2645.     if (!pid)
  2646.     return -1;
  2647.     if (pid > 0) {
  2648.     sprintf(spid, "%"IVdf, (IV)pid);
  2649.     svp = hv_fetch(PL_pidstatus,spid,strlen(spid),FALSE);
  2650.     if (svp && *svp != &PL_sv_undef) {
  2651.         *statusp = SvIVX(*svp);
  2652.         (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
  2653.         return pid;
  2654.     }
  2655.     }
  2656.     else {
  2657.     HE *entry;
  2658.  
  2659.     hv_iterinit(PL_pidstatus);
  2660.     if ((entry = hv_iternext(PL_pidstatus))) {
  2661.         pid = atoi(hv_iterkey(entry,(I32*)statusp));
  2662.         sv = hv_iterval(PL_pidstatus,entry);
  2663.         *statusp = SvIVX(sv);
  2664.         sprintf(spid, "%"IVdf, (IV)pid);
  2665.         (void)hv_delete(PL_pidstatus,spid,strlen(spid),G_DISCARD);
  2666.         return pid;
  2667.     }
  2668.     }
  2669. #ifdef HAS_WAITPID
  2670. #  ifdef HAS_WAITPID_RUNTIME
  2671.     if (!HAS_WAITPID_RUNTIME)
  2672.     goto hard_way;
  2673. #  endif
  2674.     return PerlProc_waitpid(pid,statusp,flags);
  2675. #endif
  2676. #if !defined(HAS_WAITPID) && defined(HAS_WAIT4)
  2677.     return wait4((pid==-1)?0:pid,statusp,flags,Null(struct rusage *));
  2678. #endif
  2679. #if !defined(HAS_WAITPID) && !defined(HAS_WAIT4) || defined(HAS_WAITPID_RUNTIME)
  2680.   hard_way:
  2681.     {
  2682.     I32 result;
  2683.     if (flags)
  2684.         Perl_croak(aTHX_ "Can't do waitpid with flags");
  2685.     else {
  2686.         while ((result = PerlProc_wait(statusp)) != pid && pid > 0 && result >= 0)
  2687.         pidgone(result,*statusp);
  2688.         if (result < 0)
  2689.         *statusp = -1;
  2690.     }
  2691.     return result;
  2692.     }
  2693. #endif
  2694. }
  2695. #endif /* !DOSISH || OS2 || WIN32 */
  2696.  
  2697. void
  2698. /*SUPPRESS 590*/
  2699. Perl_pidgone(pTHX_ Pid_t pid, int status)
  2700. {
  2701.     register SV *sv;
  2702.     char spid[TYPE_CHARS(int)];
  2703.  
  2704.     sprintf(spid, "%"IVdf, (IV)pid);
  2705.     sv = *hv_fetch(PL_pidstatus,spid,strlen(spid),TRUE);
  2706.     (void)SvUPGRADE(sv,SVt_IV);
  2707.     SvIVX(sv) = status;
  2708.     return;
  2709. }
  2710.  
  2711. #if defined(atarist) || defined(OS2) || defined(DJGPP)
  2712. int pclose();
  2713. #ifdef HAS_FORK
  2714. int                    /* Cannot prototype with I32
  2715.                        in os2ish.h. */
  2716. my_syspclose(PerlIO *ptr)
  2717. #else
  2718. I32
  2719. Perl_my_pclose(pTHX_ PerlIO *ptr)
  2720. #endif 
  2721. {
  2722.     /* Needs work for PerlIO ! */
  2723.     FILE *f = PerlIO_findFILE(ptr);
  2724.     I32 result = pclose(f);
  2725. #if defined(DJGPP)
  2726.     result = (result << 8) & 0xff00;
  2727. #endif
  2728.     PerlIO_releaseFILE(ptr,f);
  2729.     return result;
  2730. }
  2731. #endif
  2732.  
  2733. void
  2734. Perl_repeatcpy(pTHX_ register char *to, register const char *from, I32 len, register I32 count)
  2735. {
  2736.     register I32 todo;
  2737.     register const char *frombase = from;
  2738.  
  2739.     if (len == 1) {
  2740.     register const char c = *from;
  2741.     while (count-- > 0)
  2742.         *to++ = c;
  2743.     return;
  2744.     }
  2745.     while (count-- > 0) {
  2746.     for (todo = len; todo > 0; todo--) {
  2747.         *to++ = *from++;
  2748.     }
  2749.     from = frombase;
  2750.     }
  2751. }
  2752.  
  2753. U32
  2754. Perl_cast_ulong(pTHX_ NV f)
  2755. {
  2756.     long along;
  2757.  
  2758. #if CASTFLAGS & 2
  2759. #   define BIGDOUBLE 2147483648.0
  2760.     if (f >= BIGDOUBLE)
  2761.     return (unsigned long)(f-(long)(f/BIGDOUBLE)*BIGDOUBLE)|0x80000000;
  2762. #endif
  2763.     if (f >= 0.0)
  2764.     return (unsigned long)f;
  2765.     along = (long)f;
  2766.     return (unsigned long)along;
  2767. }
  2768. # undef BIGDOUBLE
  2769.  
  2770. /* Unfortunately, on some systems the cast_uv() function doesn't
  2771.    work with the system-supplied definition of ULONG_MAX.  The
  2772.    comparison  (f >= ULONG_MAX) always comes out true.  It must be a
  2773.    problem with the compiler constant folding.
  2774.  
  2775.    In any case, this workaround should be fine on any two's complement
  2776.    system.  If it's not, supply a '-DMY_ULONG_MAX=whatever' in your
  2777.    ccflags.
  2778.            --Andy Dougherty      <doughera@lafcol.lafayette.edu>
  2779. */
  2780.  
  2781. /* Code modified to prefer proper named type ranges, I32, IV, or UV, instead
  2782.    of LONG_(MIN/MAX).
  2783.                            -- Kenneth Albanowski <kjahds@kjahds.com>
  2784. */                                      
  2785.  
  2786. #ifndef MY_UV_MAX
  2787. #  define MY_UV_MAX ((UV)IV_MAX * (UV)2 + (UV)1)
  2788. #endif
  2789.  
  2790. I32
  2791. Perl_cast_i32(pTHX_ NV f)
  2792. {
  2793.     if (f >= I32_MAX)
  2794.     return (I32) I32_MAX;
  2795.     if (f <= I32_MIN)
  2796.     return (I32) I32_MIN;
  2797.     return (I32) f;
  2798. }
  2799.  
  2800. IV
  2801. Perl_cast_iv(pTHX_ NV f)
  2802. {
  2803.     if (f >= IV_MAX) {
  2804.     UV uv;
  2805.     
  2806.     if (f >= (NV)UV_MAX)
  2807.         return (IV) UV_MAX;    
  2808.     uv = (UV) f;
  2809.     return (IV)uv;
  2810.     }
  2811.     if (f <= IV_MIN)
  2812.     return (IV) IV_MIN;
  2813.     return (IV) f;
  2814. }
  2815.  
  2816. UV
  2817. Perl_cast_uv(pTHX_ NV f)
  2818. {
  2819.     if (f >= MY_UV_MAX)
  2820.     return (UV) MY_UV_MAX;
  2821.     if (f < 0) {
  2822.     IV iv;
  2823.     
  2824.     if (f < IV_MIN)
  2825.         return (UV)IV_MIN;
  2826.     iv = (IV) f;
  2827.     return (UV) iv;
  2828.     }
  2829.     return (UV) f;
  2830. }
  2831.  
  2832. #ifndef HAS_RENAME
  2833. I32
  2834. Perl_same_dirent(pTHX_ char *a, char *b)
  2835. {
  2836.     char *fa = strrchr(a,'/');
  2837.     char *fb = strrchr(b,'/');
  2838.     struct stat tmpstatbuf1;
  2839.     struct stat tmpstatbuf2;
  2840.     SV *tmpsv = sv_newmortal();
  2841.  
  2842.     if (fa)
  2843.     fa++;
  2844.     else
  2845.     fa = a;
  2846.     if (fb)
  2847.     fb++;
  2848.     else
  2849.     fb = b;
  2850.     if (strNE(a,b))
  2851.     return FALSE;
  2852.     if (fa == a)
  2853.     sv_setpv(tmpsv, ".");
  2854.     else
  2855.     sv_setpvn(tmpsv, a, fa - a);
  2856.     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf1) < 0)
  2857.     return FALSE;
  2858.     if (fb == b)
  2859.     sv_setpv(tmpsv, ".");
  2860.     else
  2861.     sv_setpvn(tmpsv, b, fb - b);
  2862.     if (PerlLIO_stat(SvPVX(tmpsv), &tmpstatbuf2) < 0)
  2863.     return FALSE;
  2864.     return tmpstatbuf1.st_dev == tmpstatbuf2.st_dev &&
  2865.        tmpstatbuf1.st_ino == tmpstatbuf2.st_ino;
  2866. }
  2867. #endif /* !HAS_RENAME */
  2868.  
  2869. NV
  2870. Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen)
  2871. {
  2872.     register char *s = start;
  2873.     register NV rnv = 0.0;
  2874.     register UV ruv = 0;
  2875.     register bool seenb = FALSE;
  2876.     register bool overflowed = FALSE;
  2877.  
  2878.     for (; len-- && *s; s++) {
  2879.     if (!(*s == '0' || *s == '1')) {
  2880.         if (*s == '_')
  2881.         continue; /* Note: does not check for __ and the like. */
  2882.         if (seenb == FALSE && *s == 'b' && ruv == 0) {
  2883.         /* Disallow 0bbb0b0bbb... */
  2884.         seenb = TRUE;
  2885.         continue;
  2886.         }
  2887.         else {
  2888.         dTHR;
  2889.         if (ckWARN(WARN_DIGIT))
  2890.             Perl_warner(aTHX_ WARN_DIGIT,
  2891.                 "Illegal binary digit '%c' ignored", *s);
  2892.         break;
  2893.         }
  2894.     }
  2895.     if (!overflowed) {
  2896.         register UV xuv = ruv << 1;
  2897.  
  2898.         if ((xuv >> 1) != ruv) {
  2899.         dTHR;
  2900.         overflowed = TRUE;
  2901.         rnv = (NV) ruv;
  2902.         if (ckWARN_d(WARN_OVERFLOW))
  2903.             Perl_warner(aTHX_ WARN_OVERFLOW,
  2904.                 "Integer overflow in binary number");
  2905.         } else
  2906.         ruv = xuv | (*s - '0');
  2907.     }
  2908.     if (overflowed) {
  2909.         rnv *= 2;
  2910.         /* If an NV has not enough bits in its mantissa to
  2911.          * represent an UV this summing of small low-order numbers
  2912.          * is a waste of time (because the NV cannot preserve
  2913.          * the low-order bits anyway): we could just remember when
  2914.          * did we overflow and in the end just multiply rnv by the
  2915.          * right amount. */
  2916.         rnv += (*s - '0');
  2917.     }
  2918.     }
  2919.     if (!overflowed)
  2920.     rnv = (NV) ruv;
  2921.     if (   ( overflowed && rnv > 4294967295.0)
  2922. #if UVSIZE > 4
  2923.     || (!overflowed && ruv > 0xffffffff  )
  2924. #endif
  2925.     ) { 
  2926.     dTHR;
  2927.     if (ckWARN(WARN_PORTABLE))
  2928.         Perl_warner(aTHX_ WARN_PORTABLE,
  2929.             "Binary number > 0b11111111111111111111111111111111 non-portable");
  2930.     }
  2931.     *retlen = s - start;
  2932.     return rnv;
  2933. }
  2934.  
  2935. NV
  2936. Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen)
  2937. {
  2938.     register char *s = start;
  2939.     register NV rnv = 0.0;
  2940.     register UV ruv = 0;
  2941.     register bool overflowed = FALSE;
  2942.  
  2943.     for (; len-- && *s; s++) {
  2944.     if (!(*s >= '0' && *s <= '7')) {
  2945.         if (*s == '_')
  2946.         continue; /* Note: does not check for __ and the like. */
  2947.         else {
  2948.         /* Allow \octal to work the DWIM way (that is, stop scanning
  2949.          * as soon as non-octal characters are seen, complain only iff
  2950.          * someone seems to want to use the digits eight and nine). */
  2951.         if (*s == '8' || *s == '9') {
  2952.             dTHR;
  2953.             if (ckWARN(WARN_DIGIT))
  2954.             Perl_warner(aTHX_ WARN_DIGIT,
  2955.                     "Illegal octal digit '%c' ignored", *s);
  2956.         }
  2957.         break;
  2958.         }
  2959.     }
  2960.     if (!overflowed) {
  2961.         register UV xuv = ruv << 3;
  2962.  
  2963.         if ((xuv >> 3) != ruv) {
  2964.         dTHR;
  2965.         overflowed = TRUE;
  2966.         rnv = (NV) ruv;
  2967.         if (ckWARN_d(WARN_OVERFLOW))
  2968.             Perl_warner(aTHX_ WARN_OVERFLOW,
  2969.                 "Integer overflow in octal number");
  2970.         } else
  2971.         ruv = xuv | (*s - '0');
  2972.     }
  2973.     if (overflowed) {
  2974.         rnv *= 8.0;
  2975.         /* If an NV has not enough bits in its mantissa to
  2976.          * represent an UV this summing of small low-order numbers
  2977.          * is a waste of time (because the NV cannot preserve
  2978.          * the low-order bits anyway): we could just remember when
  2979.          * did we overflow and in the end just multiply rnv by the
  2980.          * right amount of 8-tuples. */
  2981.         rnv += (NV)(*s - '0');
  2982.     }
  2983.     }
  2984.     if (!overflowed)
  2985.     rnv = (NV) ruv;
  2986.     if (   ( overflowed && rnv > 4294967295.0)
  2987. #if UVSIZE > 4
  2988.     || (!overflowed && ruv > 0xffffffff  )
  2989. #endif
  2990.     ) {
  2991.     dTHR;
  2992.     if (ckWARN(WARN_PORTABLE))
  2993.         Perl_warner(aTHX_ WARN_PORTABLE,
  2994.             "Octal number > 037777777777 non-portable");
  2995.     }
  2996.     *retlen = s - start;
  2997.     return rnv;
  2998. }
  2999.  
  3000. NV
  3001. Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen)
  3002. {
  3003.     register char *s = start;
  3004.     register NV rnv = 0.0;
  3005.     register UV ruv = 0;
  3006.     register bool seenx = FALSE;
  3007.     register bool overflowed = FALSE;
  3008.     char *hexdigit;
  3009.  
  3010.     for (; len-- && *s; s++) {
  3011.     hexdigit = strchr((char *) PL_hexdigit, *s);
  3012.     if (!hexdigit) {
  3013.         if (*s == '_')
  3014.         continue; /* Note: does not check for __ and the like. */
  3015.         if (seenx == FALSE && *s == 'x' && ruv == 0) {
  3016.         /* Disallow 0xxx0x0xxx... */
  3017.         seenx = TRUE;
  3018.         continue;
  3019.         }
  3020.         else {
  3021.         dTHR;
  3022.         if (ckWARN(WARN_DIGIT))
  3023.             Perl_warner(aTHX_ WARN_DIGIT,
  3024.                 "Illegal hexadecimal digit '%c' ignored", *s);
  3025.         break;
  3026.         }
  3027.     }
  3028.     if (!overflowed) {
  3029.         register UV xuv = ruv << 4;
  3030.  
  3031.         if ((xuv >> 4) != ruv) {
  3032.         dTHR;
  3033.         overflowed = TRUE;
  3034.         rnv = (NV) ruv;
  3035.         if (ckWARN_d(WARN_OVERFLOW))
  3036.             Perl_warner(aTHX_ WARN_OVERFLOW,
  3037.                 "Integer overflow in hexadecimal number");
  3038.         } else
  3039.         ruv = xuv | ((hexdigit - PL_hexdigit) & 15);
  3040.     }
  3041.     if (overflowed) {
  3042.         rnv *= 16.0;
  3043.         /* If an NV has not enough bits in its mantissa to
  3044.          * represent an UV this summing of small low-order numbers
  3045.          * is a waste of time (because the NV cannot preserve
  3046.          * the low-order bits anyway): we could just remember when
  3047.          * did we overflow and in the end just multiply rnv by the
  3048.          * right amount of 16-tuples. */
  3049.         rnv += (NV)((hexdigit - PL_hexdigit) & 15);
  3050.     }
  3051.     }
  3052.     if (!overflowed)
  3053.     rnv = (NV) ruv;
  3054.     if (   ( overflowed && rnv > 4294967295.0)
  3055. #if UVSIZE > 4
  3056.     || (!overflowed && ruv > 0xffffffff  )
  3057. #endif
  3058.     ) { 
  3059.     dTHR;
  3060.     if (ckWARN(WARN_PORTABLE))
  3061.         Perl_warner(aTHX_ WARN_PORTABLE,
  3062.             "Hexadecimal number > 0xffffffff non-portable");
  3063.     }
  3064.     *retlen = s - start;
  3065.     return rnv;
  3066. }
  3067.  
  3068. char*
  3069. Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 flags)
  3070. {
  3071.     dTHR;
  3072.     char *xfound = Nullch;
  3073.     char *xfailed = Nullch;
  3074.     char tmpbuf[MAXPATHLEN];
  3075.     register char *s;
  3076.     I32 len;
  3077.     int retval;
  3078. #if defined(DOSISH) && !defined(OS2) && !defined(atarist)
  3079. #  define SEARCH_EXTS ".bat", ".cmd", NULL
  3080. #  define MAX_EXT_LEN 4
  3081. #endif
  3082. #ifdef OS2
  3083. #  define SEARCH_EXTS ".cmd", ".btm", ".bat", ".pl", NULL
  3084. #  define MAX_EXT_LEN 4
  3085. #endif
  3086. #ifdef VMS
  3087. #  define SEARCH_EXTS ".pl", ".com", NULL
  3088. #  define MAX_EXT_LEN 4
  3089. #endif
  3090.     /* additional extensions to try in each dir if scriptname not found */
  3091. #ifdef SEARCH_EXTS
  3092.     char *exts[] = { SEARCH_EXTS };
  3093.     char **ext = search_ext ? search_ext : exts;
  3094.     int extidx = 0, i = 0;
  3095.     char *curext = Nullch;
  3096. #else
  3097. #  define MAX_EXT_LEN 0
  3098. #endif
  3099.  
  3100.     /*
  3101.      * If dosearch is true and if scriptname does not contain path
  3102.      * delimiters, search the PATH for scriptname.
  3103.      *
  3104.      * If SEARCH_EXTS is also defined, will look for each
  3105.      * scriptname{SEARCH_EXTS} whenever scriptname is not found
  3106.      * while searching the PATH.
  3107.      *
  3108.      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
  3109.      * proceeds as follows:
  3110.      *   If DOSISH or VMSISH:
  3111.      *     + look for ./scriptname{,.foo,.bar}
  3112.      *     + search the PATH for scriptname{,.foo,.bar}
  3113.      *
  3114.      *   If !DOSISH:
  3115.      *     + look *only* in the PATH for scriptname{,.foo,.bar} (note
  3116.      *       this will not look in '.' if it's not in the PATH)
  3117.      */
  3118.     tmpbuf[0] = '\0';
  3119.  
  3120. #ifdef VMS
  3121. #  ifdef ALWAYS_DEFTYPES
  3122.     len = strlen(scriptname);
  3123.     if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
  3124.     int hasdir, idx = 0, deftypes = 1;
  3125.     bool seen_dot = 1;
  3126.  
  3127.     hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
  3128. #  else
  3129.     if (dosearch) {
  3130.     int hasdir, idx = 0, deftypes = 1;
  3131.     bool seen_dot = 1;
  3132.  
  3133.     hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
  3134. #  endif
  3135.     /* The first time through, just add SEARCH_EXTS to whatever we
  3136.      * already have, so we can check for default file types. */
  3137.     while (deftypes ||
  3138.            (!hasdir && my_trnlnm("DCL$PATH",tmpbuf,idx++)) )
  3139.     {
  3140.         if (deftypes) {
  3141.         deftypes = 0;
  3142.         *tmpbuf = '\0';
  3143.         }
  3144.         if ((strlen(tmpbuf) + strlen(scriptname)
  3145.          + MAX_EXT_LEN) >= sizeof tmpbuf)
  3146.         continue;    /* don't search dir with too-long name */
  3147.         strcat(tmpbuf, scriptname);
  3148. #else  /* !VMS */
  3149.  
  3150. #ifdef DOSISH
  3151.     if (strEQ(scriptname, "-"))
  3152.      dosearch = 0;
  3153.     if (dosearch) {        /* Look in '.' first. */
  3154.     char *cur = scriptname;
  3155. #ifdef SEARCH_EXTS
  3156.     if ((curext = strrchr(scriptname,'.')))    /* possible current ext */
  3157.         while (ext[i])
  3158.         if (strEQ(ext[i++],curext)) {
  3159.             extidx = -1;        /* already has an ext */
  3160.             break;
  3161.         }
  3162.     do {
  3163. #endif
  3164.         DEBUG_p(PerlIO_printf(Perl_debug_log,
  3165.                   "Looking for %s\n",cur));
  3166.         if (PerlLIO_stat(cur,&PL_statbuf) >= 0
  3167.         && !S_ISDIR(PL_statbuf.st_mode)) {
  3168.         dosearch = 0;
  3169.         scriptname = cur;
  3170. #ifdef SEARCH_EXTS
  3171.         break;
  3172. #endif
  3173.         }
  3174. #ifdef SEARCH_EXTS
  3175.         if (cur == scriptname) {
  3176.         len = strlen(scriptname);
  3177.         if (len+MAX_EXT_LEN+1 >= sizeof(tmpbuf))
  3178.             break;
  3179.         cur = strcpy(tmpbuf, scriptname);
  3180.         }
  3181.     } while (extidx >= 0 && ext[extidx]    /* try an extension? */
  3182.          && strcpy(tmpbuf+len, ext[extidx++]));
  3183. #endif
  3184.     }
  3185. #endif
  3186.  
  3187. #ifdef MACOS_TRADITIONAL
  3188.     if (dosearch && !strchr(scriptname, ':') &&
  3189.     (s = PerlEnv_getenv("Commands")))
  3190. #else
  3191.     if (dosearch && !strchr(scriptname, '/')
  3192. #ifdef DOSISH
  3193.          && !strchr(scriptname, '\\')
  3194. #endif
  3195.          && (s = PerlEnv_getenv("PATH")))
  3196. #endif
  3197.     {
  3198.     bool seen_dot = 0;
  3199.     
  3200.     PL_bufend = s + strlen(s);
  3201.     while (s < PL_bufend) {
  3202. #ifdef MACOS_TRADITIONAL
  3203.         s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
  3204.             ',',
  3205.             &len);
  3206. #else
  3207. #if defined(atarist) || defined(DOSISH)
  3208.         for (len = 0; *s
  3209. #  ifdef atarist
  3210.             && *s != ','
  3211. #  endif
  3212.             && *s != ';'; len++, s++) {
  3213.         if (len < sizeof tmpbuf)
  3214.             tmpbuf[len] = *s;
  3215.         }
  3216.         if (len < sizeof tmpbuf)
  3217.         tmpbuf[len] = '\0';
  3218. #else  /* ! (atarist || DOSISH) */
  3219.         s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf, s, PL_bufend,
  3220.             ':',
  3221.             &len);
  3222. #endif /* ! (atarist || DOSISH) */
  3223. #endif /* MACOS_TRADITIONAL */
  3224.         if (s < PL_bufend)
  3225.         s++;
  3226.         if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf)
  3227.         continue;    /* don't search dir with too-long name */
  3228. #ifdef MACOS_TRADITIONAL
  3229.         if (len && tmpbuf[len - 1] != ':')
  3230.             tmpbuf[len++] = ':';
  3231. #else
  3232.         if (len
  3233. #if defined(atarist) || defined(__MINT__) || defined(DOSISH)
  3234.         && tmpbuf[len - 1] != '/'
  3235.         && tmpbuf[len - 1] != '\\'
  3236. #endif
  3237.            )
  3238.         tmpbuf[len++] = '/';
  3239.         if (len == 2 && tmpbuf[0] == '.')
  3240.         seen_dot = 1;
  3241. #endif
  3242.         (void)strcpy(tmpbuf + len, scriptname);
  3243. #endif  /* !VMS */
  3244.  
  3245. #ifdef SEARCH_EXTS
  3246.         len = strlen(tmpbuf);
  3247.         if (extidx > 0)    /* reset after previous loop */
  3248.         extidx = 0;
  3249.         do {
  3250. #endif
  3251.             DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf));
  3252.         retval = PerlLIO_stat(tmpbuf,&PL_statbuf);
  3253.         if (S_ISDIR(PL_statbuf.st_mode)) {
  3254.             retval = -1;
  3255.         }
  3256. #ifdef SEARCH_EXTS
  3257.         } while (  retval < 0        /* not there */
  3258.             && extidx>=0 && ext[extidx]    /* try an extension? */
  3259.             && strcpy(tmpbuf+len, ext[extidx++])
  3260.         );
  3261. #endif
  3262.         if (retval < 0)
  3263.         continue;
  3264.         if (S_ISREG(PL_statbuf.st_mode)
  3265.         && cando(S_IRUSR,TRUE,&PL_statbuf)
  3266. #if !defined(DOSISH) && !defined(MACOS_TRADITIONAL)
  3267.         && cando(S_IXUSR,TRUE,&PL_statbuf)
  3268. #endif
  3269.         )
  3270.         {
  3271.         xfound = tmpbuf;              /* bingo! */
  3272.         break;
  3273.         }
  3274.         if (!xfailed)
  3275.         xfailed = savepv(tmpbuf);
  3276.     }
  3277. #ifndef DOSISH
  3278.     if (!xfound && !seen_dot && !xfailed &&
  3279.         (PerlLIO_stat(scriptname,&PL_statbuf) < 0 
  3280.          || S_ISDIR(PL_statbuf.st_mode)))
  3281. #endif
  3282.         seen_dot = 1;            /* Disable message. */
  3283.     if (!xfound) {
  3284.         if (flags & 1) {            /* do or die? */
  3285.             Perl_croak(aTHX_ "Can't %s %s%s%s",
  3286.               (xfailed ? "execute" : "find"),
  3287.               (xfailed ? xfailed : scriptname),
  3288.               (xfailed ? "" : " on PATH"),
  3289.               (xfailed || seen_dot) ? "" : ", '.' not in PATH");
  3290.         }
  3291.         scriptname = Nullch;
  3292.     }
  3293.     if (xfailed)
  3294.         Safefree(xfailed);
  3295.     scriptname = xfound;
  3296.     }
  3297.     return (scriptname ? savepv(scriptname) : Nullch);
  3298. }
  3299.  
  3300. #ifndef PERL_GET_CONTEXT_DEFINED
  3301.  
  3302. void *
  3303. Perl_get_context(void)
  3304. {
  3305. #if defined(USE_THREADS) || defined(USE_ITHREADS)
  3306. #  ifdef OLD_PTHREADS_API
  3307.     pthread_addr_t t;
  3308.     if (pthread_getspecific(PL_thr_key, &t))
  3309.     Perl_croak_nocontext("panic: pthread_getspecific");
  3310.     return (void*)t;
  3311. #  else
  3312. #  ifdef I_MACH_CTHREADS
  3313.     return (void*)cthread_data(cthread_self());
  3314. #  else
  3315.     return (void*)pthread_getspecific(PL_thr_key);
  3316. #  endif
  3317. #  endif
  3318. #else
  3319.     return (void*)NULL;
  3320. #endif
  3321. }
  3322.  
  3323. void
  3324. Perl_set_context(void *t)
  3325. {
  3326. #if defined(USE_THREADS) || defined(USE_ITHREADS)
  3327. #  ifdef I_MACH_CTHREADS
  3328.     cthread_set_data(cthread_self(), t);
  3329. #  else
  3330.     if (pthread_setspecific(PL_thr_key, t))
  3331.     Perl_croak_nocontext("panic: pthread_setspecific");
  3332. #  endif
  3333. #endif
  3334. }
  3335.  
  3336. #endif /* !PERL_GET_CONTEXT_DEFINED */
  3337.  
  3338. #ifdef USE_THREADS
  3339.  
  3340. #ifdef FAKE_THREADS
  3341. /* Very simplistic scheduler for now */
  3342. void
  3343. schedule(void)
  3344. {
  3345.     thr = thr->i.next_run;
  3346. }
  3347.  
  3348. void
  3349. Perl_cond_init(pTHX_ perl_cond *cp)
  3350. {
  3351.     *cp = 0;
  3352. }
  3353.  
  3354. void
  3355. Perl_cond_signal(pTHX_ perl_cond *cp)
  3356. {
  3357.     perl_os_thread t;
  3358.     perl_cond cond = *cp;
  3359.     
  3360.     if (!cond)
  3361.     return;
  3362.     t = cond->thread;
  3363.     /* Insert t in the runnable queue just ahead of us */
  3364.     t->i.next_run = thr->i.next_run;
  3365.     thr->i.next_run->i.prev_run = t;
  3366.     t->i.prev_run = thr;
  3367.     thr->i.next_run = t;
  3368.     thr->i.wait_queue = 0;
  3369.     /* Remove from the wait queue */
  3370.     *cp = cond->next;
  3371.     Safefree(cond);
  3372. }
  3373.  
  3374. void
  3375. Perl_cond_broadcast(pTHX_ perl_cond *cp)
  3376. {
  3377.     perl_os_thread t;
  3378.     perl_cond cond, cond_next;
  3379.     
  3380.     for (cond = *cp; cond; cond = cond_next) {
  3381.     t = cond->thread;
  3382.     /* Insert t in the runnable queue just ahead of us */
  3383.     t->i.next_run = thr->i.next_run;
  3384.     thr->i.next_run->i.prev_run = t;
  3385.     t->i.prev_run = thr;
  3386.     thr->i.next_run = t;
  3387.     thr->i.wait_queue = 0;
  3388.     /* Remove from the wait queue */
  3389.     cond_next = cond->next;
  3390.     Safefree(cond);
  3391.     }
  3392.     *cp = 0;
  3393. }
  3394.  
  3395. void
  3396. Perl_cond_wait(pTHX_ perl_cond *cp)
  3397. {
  3398.     perl_cond cond;
  3399.  
  3400.     if (thr->i.next_run == thr)
  3401.     Perl_croak(aTHX_ "panic: perl_cond_wait called by last runnable thread");
  3402.     
  3403.     New(666, cond, 1, struct perl_wait_queue);
  3404.     cond->thread = thr;
  3405.     cond->next = *cp;
  3406.     *cp = cond;
  3407.     thr->i.wait_queue = cond;
  3408.     /* Remove ourselves from runnable queue */
  3409.     thr->i.next_run->i.prev_run = thr->i.prev_run;
  3410.     thr->i.prev_run->i.next_run = thr->i.next_run;
  3411. }
  3412. #endif /* FAKE_THREADS */
  3413.  
  3414. MAGIC *
  3415. Perl_condpair_magic(pTHX_ SV *sv)
  3416. {
  3417.     MAGIC *mg;
  3418.     
  3419.     SvUPGRADE(sv, SVt_PVMG);
  3420.     mg = mg_find(sv, 'm');
  3421.     if (!mg) {
  3422.     condpair_t *cp;
  3423.  
  3424.     New(53, cp, 1, condpair_t);
  3425.     MUTEX_INIT(&cp->mutex);
  3426.     COND_INIT(&cp->owner_cond);
  3427.     COND_INIT(&cp->cond);
  3428.     cp->owner = 0;
  3429.     LOCK_CRED_MUTEX;        /* XXX need separate mutex? */
  3430.     mg = mg_find(sv, 'm');
  3431.     if (mg) {
  3432.         /* someone else beat us to initialising it */
  3433.         UNLOCK_CRED_MUTEX;        /* XXX need separate mutex? */
  3434.         MUTEX_DESTROY(&cp->mutex);
  3435.         COND_DESTROY(&cp->owner_cond);
  3436.         COND_DESTROY(&cp->cond);
  3437.         Safefree(cp);
  3438.     }
  3439.     else {
  3440.         sv_magic(sv, Nullsv, 'm', 0, 0);
  3441.         mg = SvMAGIC(sv);
  3442.         mg->mg_ptr = (char *)cp;
  3443.         mg->mg_len = sizeof(cp);
  3444.         UNLOCK_CRED_MUTEX;        /* XXX need separate mutex? */
  3445.         DEBUG_S(WITH_THR(PerlIO_printf(Perl_debug_log,
  3446.                        "%p: condpair_magic %p\n", thr, sv));)
  3447.     }
  3448.     }
  3449.     return mg;
  3450. }
  3451.  
  3452. /*
  3453.  * Make a new perl thread structure using t as a prototype. Some of the
  3454.  * fields for the new thread are copied from the prototype thread, t,
  3455.  * so t should not be running in perl at the time this function is
  3456.  * called. The use by ext/Thread/Thread.xs in core perl (where t is the
  3457.  * thread calling new_struct_thread) clearly satisfies this constraint.
  3458.  */
  3459. struct perl_thread *
  3460. Perl_new_struct_thread(pTHX_ struct perl_thread *t)
  3461. {
  3462. #if !defined(PERL_IMPLICIT_CONTEXT)
  3463.     struct perl_thread *thr;
  3464. #endif
  3465.     SV *sv;
  3466.     SV **svp;
  3467.     I32 i;
  3468.  
  3469.     sv = newSVpvn("", 0);
  3470.     SvGROW(sv, sizeof(struct perl_thread) + 1);
  3471.     SvCUR_set(sv, sizeof(struct perl_thread));
  3472.     thr = (Thread) SvPVX(sv);
  3473. #ifdef DEBUGGING
  3474.     memset(thr, 0xab, sizeof(struct perl_thread));
  3475.     PL_markstack = 0;
  3476.     PL_scopestack = 0;
  3477.     PL_savestack = 0;
  3478.     PL_retstack = 0;
  3479.     PL_dirty = 0;
  3480.     PL_localizing = 0;
  3481.     Zero(&PL_hv_fetch_ent_mh, 1, HE);
  3482. #else
  3483.     Zero(thr, 1, struct perl_thread);
  3484. #endif
  3485.  
  3486.     thr->oursv = sv;
  3487.     init_stacks();
  3488.  
  3489.     PL_curcop = &PL_compiling;
  3490.     thr->interp = t->interp;
  3491.     thr->cvcache = newHV();
  3492.     thr->threadsv = newAV();
  3493.     thr->specific = newAV();
  3494.     thr->errsv = newSVpvn("", 0);
  3495.     thr->flags = THRf_R_JOINABLE;
  3496.     MUTEX_INIT(&thr->mutex);
  3497.  
  3498.     JMPENV_BOOTSTRAP;
  3499.  
  3500.     PL_in_eval = EVAL_NULL;    /* ~(EVAL_INEVAL|EVAL_WARNONLY|EVAL_KEEPERR) */
  3501.     PL_restartop = 0;
  3502.  
  3503.     PL_statname = NEWSV(66,0);
  3504.     PL_errors = newSVpvn("", 0);
  3505.     PL_maxscream = -1;
  3506.     PL_regcompp = MEMBER_TO_FPTR(Perl_pregcomp);
  3507.     PL_regexecp = MEMBER_TO_FPTR(Perl_regexec_flags);
  3508.     PL_regint_start = MEMBER_TO_FPTR(Perl_re_intuit_start);
  3509.     PL_regint_string = MEMBER_TO_FPTR(Perl_re_intuit_string);
  3510.     PL_regfree = MEMBER_TO_FPTR(Perl_pregfree);
  3511.     PL_regindent = 0;
  3512.     PL_reginterp_cnt = 0;
  3513.     PL_lastscream = Nullsv;
  3514.     PL_screamfirst = 0;
  3515.     PL_screamnext = 0;
  3516.     PL_reg_start_tmp = 0;
  3517.     PL_reg_start_tmpl = 0;
  3518.     PL_reg_poscache = Nullch;
  3519.  
  3520.     /* parent thread's data needs to be locked while we make copy */
  3521.     MUTEX_LOCK(&t->mutex);
  3522.  
  3523. #ifdef PERL_FLEXIBLE_EXCEPTIONS
  3524.     PL_protect = t->Tprotect;
  3525. #endif
  3526.  
  3527.     PL_curcop = t->Tcurcop;       /* XXX As good a guess as any? */
  3528.     PL_defstash = t->Tdefstash;   /* XXX maybe these should */
  3529.     PL_curstash = t->Tcurstash;   /* always be set to main? */
  3530.  
  3531.     PL_tainted = t->Ttainted;
  3532.     PL_curpm = t->Tcurpm;         /* XXX No PMOP ref count */
  3533.     PL_nrs = newSVsv(t->Tnrs);
  3534.     PL_rs = SvREFCNT_inc(PL_nrs);
  3535.     PL_last_in_gv = Nullgv;
  3536.     PL_ofslen = t->Tofslen;
  3537.     PL_ofs = savepvn(t->Tofs, PL_ofslen);
  3538.     PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
  3539.     PL_chopset = t->Tchopset;
  3540.     PL_bodytarget = newSVsv(t->Tbodytarget);
  3541.     PL_toptarget = newSVsv(t->Ttoptarget);
  3542.     if (t->Tformtarget == t->Ttoptarget)
  3543.     PL_formtarget = PL_toptarget;
  3544.     else
  3545.     PL_formtarget = PL_bodytarget;
  3546.  
  3547.     /* Initialise all per-thread SVs that the template thread used */
  3548.     svp = AvARRAY(t->threadsv);
  3549.     for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) {
  3550.     if (*svp && *svp != &PL_sv_undef) {
  3551.         SV *sv = newSVsv(*svp);
  3552.         av_store(thr->threadsv, i, sv);
  3553.         sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1);
  3554.         DEBUG_S(PerlIO_printf(Perl_debug_log,
  3555.         "new_struct_thread: copied threadsv %"IVdf" %p->%p\n",
  3556.                   (IV)i, t, thr));
  3557.     }
  3558.     } 
  3559.     thr->threadsvp = AvARRAY(thr->threadsv);
  3560.  
  3561.     MUTEX_LOCK(&PL_threads_mutex);
  3562.     PL_nthreads++;
  3563.     thr->tid = ++PL_threadnum;
  3564.     thr->next = t->next;
  3565.     thr->prev = t;
  3566.     t->next = thr;
  3567.     thr->next->prev = thr;
  3568.     MUTEX_UNLOCK(&PL_threads_mutex);
  3569.  
  3570.     /* done copying parent's state */
  3571.     MUTEX_UNLOCK(&t->mutex);
  3572.  
  3573. #ifdef HAVE_THREAD_INTERN
  3574.     Perl_init_thread_intern(thr);
  3575. #endif /* HAVE_THREAD_INTERN */
  3576.     return thr;
  3577. }
  3578. #endif /* USE_THREADS */
  3579.  
  3580. #ifdef HUGE_VAL
  3581. /*
  3582.  * This hack is to force load of "huge" support from libm.a
  3583.  * So it is in perl for (say) POSIX to use. 
  3584.  * Needed for SunOS with Sun's 'acc' for example.
  3585.  */
  3586. NV 
  3587. Perl_huge(void)
  3588. {
  3589.  return HUGE_VAL;
  3590. }
  3591. #endif
  3592.  
  3593. #ifdef PERL_GLOBAL_STRUCT
  3594. struct perl_vars *
  3595. Perl_GetVars(pTHX)
  3596. {
  3597.  return &PL_Vars;
  3598. }
  3599. #endif
  3600.  
  3601. char **
  3602. Perl_get_op_names(pTHX)
  3603. {
  3604.  return PL_op_name;
  3605. }
  3606.  
  3607. char **
  3608. Perl_get_op_descs(pTHX)
  3609. {
  3610.  return PL_op_desc;
  3611. }
  3612.  
  3613. char *
  3614. Perl_get_no_modify(pTHX)
  3615. {
  3616.  return (char*)PL_no_modify;
  3617. }
  3618.  
  3619. U32 *
  3620. Perl_get_opargs(pTHX)
  3621. {
  3622.  return PL_opargs;
  3623. }
  3624.  
  3625. PPADDR_t*
  3626. Perl_get_ppaddr(pTHX)
  3627. {
  3628.  return &PL_ppaddr;
  3629. }
  3630.  
  3631. #ifndef HAS_GETENV_LEN
  3632. char *
  3633. Perl_getenv_len(pTHX_ char *env_elem, unsigned long *len)
  3634. {
  3635.     char *env_trans = PerlEnv_getenv(env_elem);
  3636.     if (env_trans)
  3637.     *len = strlen(env_trans);
  3638.     return env_trans;
  3639. }
  3640. #endif
  3641.  
  3642.  
  3643. MGVTBL*
  3644. Perl_get_vtbl(pTHX_ int vtbl_id)
  3645. {
  3646.     MGVTBL* result = Null(MGVTBL*);
  3647.  
  3648.     switch(vtbl_id) {
  3649.     case want_vtbl_sv:
  3650.     result = &PL_vtbl_sv;
  3651.     break;
  3652.     case want_vtbl_env:
  3653.     result = &PL_vtbl_env;
  3654.     break;
  3655.     case want_vtbl_envelem:
  3656.     result = &PL_vtbl_envelem;
  3657.     break;
  3658.     case want_vtbl_sig:
  3659.     result = &PL_vtbl_sig;
  3660.     break;
  3661.     case want_vtbl_sigelem:
  3662.     result = &PL_vtbl_sigelem;
  3663.     break;
  3664.     case want_vtbl_pack:
  3665.     result = &PL_vtbl_pack;
  3666.     break;
  3667.     case want_vtbl_packelem:
  3668.     result = &PL_vtbl_packelem;
  3669.     break;
  3670.     case want_vtbl_dbline:
  3671.     result = &PL_vtbl_dbline;
  3672.     break;
  3673.     case want_vtbl_isa:
  3674.     result = &PL_vtbl_isa;
  3675.     break;
  3676.     case want_vtbl_isaelem:
  3677.     result = &PL_vtbl_isaelem;
  3678.     break;
  3679.     case want_vtbl_arylen:
  3680.     result = &PL_vtbl_arylen;
  3681.     break;
  3682.     case want_vtbl_glob:
  3683.     result = &PL_vtbl_glob;
  3684.     break;
  3685.     case want_vtbl_mglob:
  3686.     result = &PL_vtbl_mglob;
  3687.     break;
  3688.     case want_vtbl_nkeys:
  3689.     result = &PL_vtbl_nkeys;
  3690.     break;
  3691.     case want_vtbl_taint:
  3692.     result = &PL_vtbl_taint;
  3693.     break;
  3694.     case want_vtbl_substr:
  3695.     result = &PL_vtbl_substr;
  3696.     break;
  3697.     case want_vtbl_vec:
  3698.     result = &PL_vtbl_vec;
  3699.     break;
  3700.     case want_vtbl_pos:
  3701.     result = &PL_vtbl_pos;
  3702.     break;
  3703.     case want_vtbl_bm:
  3704.     result = &PL_vtbl_bm;
  3705.     break;
  3706.     case want_vtbl_fm:
  3707.     result = &PL_vtbl_fm;
  3708.     break;
  3709.     case want_vtbl_uvar:
  3710.     result = &PL_vtbl_uvar;
  3711.     break;
  3712. #ifdef USE_THREADS
  3713.     case want_vtbl_mutex:
  3714.     result = &PL_vtbl_mutex;
  3715.     break;
  3716. #endif
  3717.     case want_vtbl_defelem:
  3718.     result = &PL_vtbl_defelem;
  3719.     break;
  3720.     case want_vtbl_regexp:
  3721.     result = &PL_vtbl_regexp;
  3722.     break;
  3723.     case want_vtbl_regdata:
  3724.     result = &PL_vtbl_regdata;
  3725.     break;
  3726.     case want_vtbl_regdatum:
  3727.     result = &PL_vtbl_regdatum;
  3728.     break;
  3729. #ifdef USE_LOCALE_COLLATE
  3730.     case want_vtbl_collxfrm:
  3731.     result = &PL_vtbl_collxfrm;
  3732.     break;
  3733. #endif
  3734.     case want_vtbl_amagic:
  3735.     result = &PL_vtbl_amagic;
  3736.     break;
  3737.     case want_vtbl_amagicelem:
  3738.     result = &PL_vtbl_amagicelem;
  3739.     break;
  3740.     case want_vtbl_backref:
  3741.     result = &PL_vtbl_backref;
  3742.     break;
  3743.     }
  3744.     return result;
  3745. }
  3746.  
  3747. I32
  3748. Perl_my_fflush_all(pTHX)
  3749. {
  3750. #ifdef FFLUSH_NULL
  3751.     return PerlIO_flush(NULL);
  3752. #else
  3753.     long open_max = -1;
  3754. # if defined(FFLUSH_ALL) && defined(HAS_STDIO_STREAM_ARRAY)
  3755. #  ifdef PERL_FFLUSH_ALL_FOPEN_MAX
  3756.     open_max = PERL_FFLUSH_ALL_FOPEN_MAX;
  3757. #  else
  3758. #  if defined(HAS_SYSCONF) && defined(_SC_OPEN_MAX)
  3759.     open_max = sysconf(_SC_OPEN_MAX);
  3760. #  else
  3761. #   ifdef FOPEN_MAX
  3762.     open_max = FOPEN_MAX;
  3763. #   else
  3764. #    ifdef OPEN_MAX
  3765.     open_max = OPEN_MAX;
  3766. #    else
  3767. #     ifdef _NFILE
  3768.     open_max = _NFILE;
  3769. #     endif
  3770. #    endif
  3771. #   endif
  3772. #  endif
  3773. #  endif
  3774.     if (open_max > 0) {
  3775.       long i;
  3776.       for (i = 0; i < open_max; i++)
  3777.         if (STDIO_STREAM_ARRAY[i]._file >= 0 &&
  3778.         STDIO_STREAM_ARRAY[i]._file < open_max &&
  3779.         STDIO_STREAM_ARRAY[i]._flag)
  3780.         PerlIO_flush(&STDIO_STREAM_ARRAY[i]);
  3781.       return 0;
  3782.     }
  3783. # endif
  3784.     SETERRNO(EBADF,RMS$_IFI);
  3785.     return EOF;
  3786. #endif
  3787. }
  3788.  
  3789. NV
  3790. Perl_my_atof(pTHX_ const char* s)
  3791. {
  3792. #ifdef USE_LOCALE_NUMERIC
  3793.     if ((PL_hints & HINT_LOCALE) && PL_numeric_local) {
  3794.     NV x, y;
  3795.  
  3796.     x = Perl_atof(s);
  3797.     SET_NUMERIC_STANDARD();
  3798.     y = Perl_atof(s);
  3799.     SET_NUMERIC_LOCAL();
  3800.     if ((y < 0.0 && y < x) || (y > 0.0 && y > x))
  3801.         return y;
  3802.     return x;
  3803.     }
  3804.     else
  3805.     return Perl_atof(s);
  3806. #else
  3807.     return Perl_atof(s);
  3808. #endif
  3809. }
  3810.  
  3811. void
  3812. Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj)
  3813. {
  3814.     SV *sv;
  3815.     char *name;
  3816.  
  3817.     assert(gv);
  3818.  
  3819.     sv = sv_newmortal();
  3820.     gv_efullname3(sv, gv, Nullch);
  3821.     name = SvPVX(sv);
  3822.  
  3823.     Perl_warner(aTHX_ WARN_CLOSED, "%s() on closed %s %s", func, obj, name);
  3824.  
  3825.     if (io && IoDIRP(io))
  3826.     Perl_warner(aTHX_ WARN_CLOSED,
  3827.             "\t(Are you trying to call %s() on dirhandle %s?)\n",
  3828.             func, name);
  3829. }
  3830.