/* util.c
*
- * Copyright (c) 1991-2002, Larry Wall
+ * Copyright (c) 1991-2003, Larry Wall
*
* You may distribute under the terms of either the GNU General Public
* License or the Artistic License, as specified in the README file.
I32 rarest = 0;
U32 frequency = 256;
- if (flags & FBMcf_TAIL)
+ if (flags & FBMcf_TAIL) {
+ MAGIC *mg = SvUTF8(sv) && SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL;
sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */
+ if (mg && mg->mg_len >= 0)
+ mg->mg_len++;
+ }
s = (U8*)SvPV_force(sv, len);
(void)SvUPGRADE(sv, SVt_PVBM);
if (len == 0) /* TAIL might be on a zero-length string. */
#ifndef PERL_MICRO
#ifdef HAS_SIGACTION
+#ifdef MACOS_TRADITIONAL
+/* We don't want restart behavior on MacOS */
+#undef SA_RESTART
+#endif
+
Sighandler_t
Perl_rsignal(pTHX_ int signo, Sighandler_t handler)
{
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
-#if defined(PERL_OLD_SIGNALS)
- act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
-#endif
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#ifdef SA_NOCLDWAIT
if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
sigemptyset(&act.sa_mask);
act.sa_flags = 0;
#ifdef SA_RESTART
-#if defined(PERL_OLD_SIGNALS)
- act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
-#endif
+ if (PL_signals & PERL_SIGNALS_UNSAFE_FLAG)
+ act.sa_flags |= SA_RESTART; /* SVR4, 4.3+BSD */
#endif
#ifdef SA_NOCLDWAIT
if (signo == SIGCHLD && handler == (Sighandler_t)SIG_IGN)
case want_vtbl_backref:
result = &PL_vtbl_backref;
break;
+ case want_vtbl_utf8:
+ result = &PL_vtbl_utf8;
+ break;
}
return result;
}
I32
Perl_my_fflush_all(pTHX)
{
-#if defined(FFLUSH_NULL)
+#if defined(USE_PERLIO) || defined(FFLUSH_NULL) || defined(USE_SFIO)
return PerlIO_flush(NULL);
#else
# if defined(HAS__FWALK)
mytm.tm_yday = yday;
mytm.tm_isdst = isdst;
mini_mktime(&mytm);
+ /* use libc to get the values for tm_gmtoff and tm_zone [perl #18238] */
+#if defined(HAS_MKTIME) && (defined(HAS_TM_TM_GMTOFF) || defined(HAS_TM_TM_ZONE))
+ STMT_START {
+ struct tm mytm2;
+ mytm2 = mytm;
+ mktime(&mytm2);
+#ifdef HAS_TM_TM_GMTOFF
+ mytm.tm_gmtoff = mytm2.tm_gmtoff;
+#endif
+#ifdef HAS_TM_TM_ZONE
+ mytm.tm_zone = mytm2.tm_zone;
+#endif
+ } STMT_END;
+#endif
buflen = 64;
New(0, buf, buflen, char);
len = strftime(buf, buflen, fmt, &mytm);
char *
Perl_scan_version(pTHX_ char *s, SV *rv)
{
+ const char *start = s;
char *pos = s;
I32 saw_period = 0;
bool saw_under = 0;
for (;;) {
rev = 0;
{
- /* this is atoi() that delimits on underscores */
- char *end = pos;
- I32 mult = 1;
- if ( s < pos && *(s-1) == '_' ) {
- if ( *s == '0' && *(s+1) != '0')
- mult = 10; /* perl-style */
- else
- mult = -1; /* beta version */
- }
- while (--end >= s) {
- I32 orev;
- orev = rev;
- rev += (*end - '0') * mult;
- mult *= 10;
- if ( abs(orev) > abs(rev) )
- Perl_croak(aTHX_ "Integer overflow in version");
- }
- }
-
- /* Append revision */
+ /* this is atoi() that delimits on underscores */
+ char *end = pos;
+ I32 mult = 1;
+ I32 orev;
+ if ( s < pos && s > start && *(s-1) == '_' ) {
+ mult *= -1; /* beta version */
+ }
+ /* the following if() will only be true after the decimal
+ * point of a version originally created with a bare
+ * floating point number, i.e. not quoted in any way
+ */
+ if ( s > start+1 && saw_period == 1 && !saw_under ) {
+ mult = 100;
+ while ( s < end ) {
+ orev = rev;
+ rev += (*s - '0') * mult;
+ mult /= 10;
+ if ( PERL_ABS(orev) > PERL_ABS(rev) )
+ Perl_croak(aTHX_ "Integer overflow in version");
+ s++;
+ }
+ }
+ else {
+ while (--end >= s) {
+ orev = rev;
+ rev += (*end - '0') * mult;
+ mult *= 10;
+ if ( PERL_ABS(orev) > PERL_ABS(rev) )
+ Perl_croak(aTHX_ "Integer overflow in version");
+ }
+ }
+ }
+
+ /* Append revision */
av_push((AV *)sv, newSViv(rev));
if ( (*pos == '.' || *pos == '_') && isDIGIT(pos[1]))
s = ++pos;
SV *
Perl_new_version(pTHX_ SV *ver)
{
- SV *rv = NEWSV(92,5);
+ SV *rv = newSV(0);
char *version;
if ( SvNOK(ver) ) /* may get too much accuracy */
{
version = savepvn( (const char*)mg->mg_ptr,mg->mg_len );
}
#endif
- else
+ else /* must be a string or something like a string */
{
version = (char *)SvPV(ver,PL_na);
}
return sv;
}
digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
- Perl_sv_setpvf(aTHX_ sv,"%d.",abs(digit));
+ Perl_sv_setpvf(aTHX_ sv,"%d.", PERL_ABS(digit));
for ( i = 1 ; i <= len ; i++ )
{
digit = SvIVX(*av_fetch((AV *)vs, i, 0));
- Perl_sv_catpvf(aTHX_ sv,"%03d",abs(digit));
+ Perl_sv_catpvf(aTHX_ sv,"%03d", PERL_ABS(digit));
}
if ( len == 0 )
Perl_sv_catpv(aTHX_ sv,"000");
+ sv_setnv(sv, SvNV(sv));
return sv;
}
return sv;
}
digit = SvIVX(*av_fetch((AV *)vs, 0, 0));
- Perl_sv_setpvf(aTHX_ sv,"%d",digit);
+ Perl_sv_setpvf(aTHX_ sv,"%"IVdf,(IV)digit);
for ( i = 1 ; i <= len ; i++ )
{
digit = SvIVX(*av_fetch((AV *)vs, i, 0));
if ( digit < 0 )
- Perl_sv_catpvf(aTHX_ sv,"_%d",-digit);
+ Perl_sv_catpvf(aTHX_ sv,"_%"IVdf,(IV)-digit);
else
- Perl_sv_catpvf(aTHX_ sv,".%d",digit);
+ Perl_sv_catpvf(aTHX_ sv,".%"IVdf,(IV)digit);
}
if ( len == 0 )
Perl_sv_catpv(aTHX_ sv,".0");
return sv;
-}
+}
/*
=for apidoc vcmp
I32 right = SvIV(*av_fetch((AV *)rsv,i,0));
bool lbeta = left < 0 ? 1 : 0;
bool rbeta = right < 0 ? 1 : 0;
- left = abs(left);
- right = abs(right);
+ left = PERL_ABS(left);
+ right = PERL_ABS(right);
if ( left < right || (left == right && lbeta && !rbeta) )
retval = -1;
if ( left > right || (left == right && rbeta && !lbeta) )
i++;
}
- if ( l != r && retval == 0 )
- retval = l < r ? -1 : +1;
+ if ( l != r && retval == 0 ) /* possible match except for trailing 0 */
+ {
+ if ( !( l < r && r-l == 1 && SvIV(*av_fetch((AV *)rsv,r,0)) == 0 ) &&
+ !( l-r == 1 && SvIV(*av_fetch((AV *)lsv,l,0)) == 0 ) )
+ {
+ retval = l < r ? -1 : +1; /* not a match after all */
+ }
+ }
return retval;
}
{
}
+U32
+Perl_parse_unicode_opts(pTHX_ char **popt)
+{
+ char *p = *popt;
+ U32 opt = 0;
+
+ if (*p) {
+ if (isDIGIT(*p)) {
+ opt = (U32) atoi(p);
+ while (isDIGIT(*p)) p++;
+ if (*p)
+ Perl_croak(aTHX_ "Unknown Unicode option letter '%c'", *p);
+ }
+ else {
+ for (; *p; p++) {
+ switch (*p) {
+ case PERL_UNICODE_STDIN:
+ opt |= PERL_UNICODE_STDIN_FLAG; break;
+ case PERL_UNICODE_STDOUT:
+ opt |= PERL_UNICODE_STDOUT_FLAG; break;
+ case PERL_UNICODE_STDERR:
+ opt |= PERL_UNICODE_STDERR_FLAG; break;
+ case PERL_UNICODE_STD:
+ opt |= PERL_UNICODE_STD_FLAG; break;
+ case PERL_UNICODE_IN:
+ opt |= PERL_UNICODE_IN_FLAG; break;
+ case PERL_UNICODE_OUT:
+ opt |= PERL_UNICODE_OUT_FLAG; break;
+ case PERL_UNICODE_INOUT:
+ opt |= PERL_UNICODE_INOUT_FLAG; break;
+ case PERL_UNICODE_LOCALE:
+ opt |= PERL_UNICODE_LOCALE_FLAG; break;
+ case PERL_UNICODE_ARGV:
+ opt |= PERL_UNICODE_ARGV_FLAG; break;
+ default:
+ Perl_croak(aTHX_
+ "Unknown Unicode option letter '%c'", *p);
+ }
+ }
+ }
+ }
+ else
+ opt = PERL_UNICODE_DEFAULT_FLAGS;
+
+ if (opt & ~PERL_UNICODE_ALL_FLAGS)
+ Perl_croak(aTHX_ "Unknown Unicode option value %"UVuf,
+ (UV) (opt & ~PERL_UNICODE_ALL_FLAGS));
+
+ *popt = p;
+
+ return opt;
+}
+