int
perl_math_int128_load(int required_version) {
dTHX;
sv_setpv(ERRSV, "Unable to load Math::Int128 C API: your compiler does not support 128bit integers");
SvSETMAGIC(ERRSV);
return 0;
}
/* XXX: same as Perl_do_sprintf();
* but Perl_do_sprintf() is not part of the "public" api
*/
void modperl_perl_do_sprintf(pTHX_ SV *sv, I32 len, SV **sarg)
{
STRLEN patlen;
char *pat = SvPV(*sarg, patlen);
bool do_taint = FALSE;
sv_vsetpvfn(sv, pat, patlen, (va_list *)NULL, sarg + 1, len - 1, &do_taint);
SvSETMAGIC(sv);
if (do_taint) {
SvTAINTED_on(sv);
}
}
int
perl_math_int64_load(int required_version) {
dTHX;
SV **svp;
eval_pv("require Math::Int64", TRUE);
if (SvTRUE(ERRSV)) return 0;
math_int64_c_api_hash = get_hv("Math::Int64::C_API", 0);
if (!math_int64_c_api_hash) {
sv_setpv(ERRSV, "Unable to load Math::Int64 C API");
SvSETMAGIC(ERRSV);
return 0;
}
svp = hv_fetch(math_int64_c_api_hash, "min_version", 11, 0);
if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_min_version = SvIV(*svp);
svp = hv_fetch(math_int64_c_api_hash, "max_version", 11, 0);
if (!svp) svp = hv_fetch(math_int64_c_api_hash, "version", 7, 1);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to retrieve C API version for Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_max_version = SvIV(*svp);
if ((required_version < math_int64_c_api_min_version) ||
(required_version > math_int64_c_api_max_version)) {
sv_setpvf(ERRSV,
"Math::Int64 C API version mismatch. "
"The installed module supports versions %d to %d but %d is required",
math_int64_c_api_min_version,
math_int64_c_api_max_version,
required_version);
SvSETMAGIC(ERRSV);
return 0;
}
svp = hv_fetch(math_int64_c_api_hash, "SvI64", 5, 0);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64' C function from Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_SvI64 = INT2PTR(void *, SvIV(*svp));
svp = hv_fetch(math_int64_c_api_hash, "SvI64OK", 7, 0);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to fetch pointer 'SvI64OK' C function from Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_SvI64OK = INT2PTR(void *, SvIV(*svp));
svp = hv_fetch(math_int64_c_api_hash, "SvU64", 5, 0);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64' C function from Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_SvU64 = INT2PTR(void *, SvIV(*svp));
svp = hv_fetch(math_int64_c_api_hash, "SvU64OK", 7, 0);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to fetch pointer 'SvU64OK' C function from Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_SvU64OK = INT2PTR(void *, SvIV(*svp));
svp = hv_fetch(math_int64_c_api_hash, "newSVi64", 8, 0);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to fetch pointer 'newSVi64' C function from Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_newSVi64 = INT2PTR(void *, SvIV(*svp));
svp = hv_fetch(math_int64_c_api_hash, "newSVu64", 8, 0);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to fetch pointer 'newSVu64' C function from Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_newSVu64 = INT2PTR(void *, SvIV(*svp));
svp = hv_fetch(math_int64_c_api_hash, "randU64", 7, 0);
if (!svp || !*svp) {
sv_setpv(ERRSV, "Unable to fetch pointer 'randU64' C function from Math::Int64");
SvSETMAGIC(ERRSV);
return 0;
}
math_int64_c_api_randU64 = INT2PTR(void *, SvIV(*svp));
return 1;
}
STATIC I32
S_do_trans_simple(pTHX_ SV * const sv)
{
dVAR;
I32 matches = 0;
STRLEN len;
U8 *s = (U8*)SvPV(sv,len);
U8 * const send = s+len;
const short * const tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
/* First, take care of non-UTF-8 input strings, because they're easy */
if (!SvUTF8(sv)) {
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
matches++;
*s = (U8)ch;
}
s++;
}
SvSETMAGIC(sv);
}
else {
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
U8 *d;
U8 *dstart;
/* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
if (grows)
Newx(d, len*2+1, U8);
else
d = s;
dstart = d;
while (s < send) {
STRLEN ulen;
I32 ch;
/* Need to check this, otherwise 128..255 won't match */
const UV c = utf8n_to_uvchr(s, send - s, &ulen, UTF8_ALLOW_DEFAULT);
if (c < 0x100 && (ch = tbl[c]) >= 0) {
matches++;
d = uvchr_to_utf8(d, ch);
s += ulen;
}
else { /* No match -> copy */
Move(s, d, ulen, U8);
d += ulen;
s += ulen;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
SvSETMAGIC(sv);
}
return matches;
}
STATIC I32
S_do_trans_complex(pTHX_ SV * const sv)
{
dVAR;
STRLEN len;
U8 *s = (U8*)SvPV(sv, len);
U8 * const send = s+len;
I32 matches = 0;
const short * const tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
if (!SvUTF8(sv)) {
U8 *d = s;
U8 * const dstart = d;
if (PL_op->op_private & OPpTRANS_SQUASH) {
const U8* p = send;
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
*d = (U8)ch;
matches++;
if (p != d - 1 || *p != *d)
p = d++;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
else {
while (s < send) {
const I32 ch = tbl[*s];
if (ch >= 0) {
matches++;
*d++ = (U8)ch;
}
else if (ch == -1) /* -1 is unmapped character */
*d++ = *s;
else if (ch == -2) /* -2 is delete character */
matches++;
s++;
}
}
*d = '\0';
SvCUR_set(sv, d - dstart);
}
else { /* is utf8 */
const I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
const I32 grows = PL_op->op_private & OPpTRANS_GROWS;
const I32 del = PL_op->op_private & OPpTRANS_DELETE;
U8 *d;
U8 *dstart;
STRLEN rlen = 0;
if (grows)
Newx(d, len*2+1, U8);
else
d = s;
dstart = d;
if (complement && !del)
rlen = tbl[0x100];
#ifdef MACOS_TRADITIONAL
#define comp CoMP /* "comp" is a keyword in some compilers ... */
#endif
if (PL_op->op_private & OPpTRANS_SQUASH) {
UV pch = 0xfeedface;
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
ch = (rlen == 0) ? (I32)comp :
(comp - 0x100 < rlen) ?
tbl[comp+1] : tbl[0x100+rlen];
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
}
}
else if ((ch = tbl[comp]) >= 0) {
matches++;
if ((UV)ch != pch) {
d = uvchr_to_utf8(d, ch);
pch = (UV)ch;
}
s += len;
continue;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
pch = 0xfeedface;
}
}
else {
while (s < send) {
STRLEN len;
const UV comp = utf8n_to_uvchr(s, send - s, &len,
UTF8_ALLOW_DEFAULT);
I32 ch;
if (comp > 0xff) {
if (!complement) {
Move(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
if (comp - 0x100 < rlen)
d = uvchr_to_utf8(d, tbl[comp+1]);
else
d = uvchr_to_utf8(d, tbl[0x100+rlen]);
}
}
}
else if ((ch = tbl[comp]) >= 0) {
d = uvchr_to_utf8(d, ch);
matches++;
}
else if (ch == -1) { /* -1 is unmapped character */
Move(s, d, len, U8);
d += len;
}
else if (ch == -2) /* -2 is delete character */
matches++;
s += len;
}
}
if (grows) {
sv_setpvn(sv, (char*)dstart, d - dstart);
Safefree(dstart);
}
else {
*d = '\0';
SvCUR_set(sv, d - dstart);
}
SvUTF8_on(sv);
}
SvSETMAGIC(sv);
return matches;
}
OP *
Perl_do_readline(pTHX_ GV* gv)
{
dVAR; dSP; dTARGETSTACKED;
register SV *sv;
STRLEN tmplen = 0;
STRLEN offset;
PerlIO *fp;
register IO * const io = GvIO(gv);
register const I32 type = PL_op->op_type;
const I32 gimme = GIMME_V;
PERL_ARGS_ASSERT_DO_READLINE;
fp = NULL;
if (io) {
fp = IoIFP(io);
if (!fp) {
if (IoFLAGS(io) & IOf_ARGV) {
if (IoFLAGS(io) & IOf_START) {
IoLINES(io) = 0;
if (av_len(GvAVn(gv)) < 0) {
IoFLAGS(io) &= ~IOf_START;
do_openn(io,"-",1,FALSE,O_RDONLY,0,NULL,NULL,0);
sv_setpvn(GvSVn(gv), "-", 1);
SvSETMAGIC(GvSV(gv));
fp = IoIFP(io);
goto have_fp;
}
}
fp = nextargv(gv);
if (!fp) { /* Note: fp != IoIFP(io) */
(void)do_close(gv, FALSE); /* now it does*/
}
}
}
else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
report_evil_fh(io, OP_phoney_OUTPUT_ONLY);
}
}
if (!fp) {
if ((!io || !(IoFLAGS(io) & IOf_START))
&& ckWARN2(WARN_GLOB, WARN_CLOSED))
{
if (type == OP_GLOB)
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (can't start child: %s)",
Strerror(errno));
else
report_evil_fh(io, PL_op->op_type);
}
if (gimme == G_SCALAR) {
/* undef TARG, and push that undefined value */
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
if ( ! SvPVOK(TARG) )
sv_upgrade(TARG, SVt_PV);
SvOK_off(TARG);
}
PUSHTARG;
}
RETURN;
}
have_fp:
if (gimme == G_SCALAR) {
sv = TARG;
if (type == OP_RCATLINE) {
NOOP;
}
else {
if ( SvOK(sv) && ! SvPVOK(sv) )
sv_clear_body(sv);
}
if (SvROK(sv)) {
if (type == OP_RCATLINE)
SvPV_force_nolen(sv);
else
sv_unref(sv);
}
else if (isGV_with_GP(sv)) {
SvPV_force_nolen(sv);
}
SvUPGRADE(sv, SVt_PV);
tmplen = SvLEN(sv); /* remember if already alloced */
if (!tmplen && !SvREADONLY(sv))
Sv_Grow(sv, 80); /* try short-buffering it */
offset = 0;
if (type == OP_RCATLINE && SvOK(sv)) {
if (!SvPOK(sv)) {
SvPV_force_nolen(sv);
}
offset = SvCUR(sv);
}
}
else {
sv = sv_2mortal(newSV(80));
offset = 0;
}
/* delay EOF state for a snarfed empty file */
#define SNARF_EOF(gimme,rs,io,sv) \
(gimme != G_SCALAR || SvCUR(sv) \
|| (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
for (;;) {
PUTBACK;
if (!sv_gets(sv, fp, offset)
&& (type == OP_GLOB
|| SNARF_EOF(gimme, PL_rs, io, sv)
|| PerlIO_error(fp)))
{
PerlIO_clearerr(fp);
if (IoFLAGS(io) & IOf_ARGV) {
fp = nextargv(gv);
if (fp)
continue;
(void)do_close(gv, FALSE);
}
else if (type == OP_GLOB) {
if (!do_close(gv, FALSE) && ckWARN(WARN_GLOB)) {
Perl_warner(aTHX_ packWARN(WARN_GLOB),
"glob failed (child exited with status %d%s)",
(int)(STATUS_CURRENT >> 8),
(STATUS_CURRENT & 0x80) ? ", core dumped" : "");
}
}
if (gimme == G_SCALAR) {
if (type != OP_RCATLINE) {
SV_CHECK_THINKFIRST_COW_DROP(TARG);
SvOK_off(TARG);
}
SPAGAIN;
PUSHTARG;
}
RETURN;
}
int
main(int argc, char **argv, char **env)
{
int exitstatus;
int i;
char **fakeargv;
GV* tmpgv;
SV* tmpsv;
int options_count;
PERL_SYS_INIT3(&argc,&argv,&env);
if (!PL_do_undump) {
my_perl = perl_alloc();
if (!my_perl)
exit(1);
perl_construct( my_perl );
PL_perl_destruct_level = 0;
}
#ifdef USE_ITHREADS
for( i = 0; i < 117; ++i ) {
av_push( PL_regex_padav, newSViv(0) );
}
PL_regex_pad = AvARRAY( PL_regex_padav );
#endif
#ifdef CSH
if (!PL_cshlen)
PL_cshlen = strlen(PL_cshname);
#endif
#ifdef ALLOW_PERL_OPTIONS
#define EXTRA_OPTIONS 3
#else
#define EXTRA_OPTIONS 4
#endif /* ALLOW_PERL_OPTIONS */
New(666, fakeargv, argc + EXTRA_OPTIONS + 1, char *);
fakeargv[0] = argv[0];
fakeargv[1] = "-e";
fakeargv[2] = "";
options_count = 3;
if( 0 ) {
fakeargv[options_count] = "-T";
++options_count;
}
#ifndef ALLOW_PERL_OPTIONS
fakeargv[options_count] = "--";
++options_count;
#endif /* ALLOW_PERL_OPTIONS */
for (i = 1; i < argc; i++)
fakeargv[i + options_count - 1] = argv[i];
fakeargv[argc + options_count - 1] = 0;
exitstatus = perl_parse(my_perl, xs_init, argc + options_count - 1,
fakeargv, NULL);
if (exitstatus)
exit( exitstatus );
TAINT;
if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {/* hello.p */
tmpsv = GvSV(tmpgv);
sv_setpv(tmpsv, argv[0]);
SvSETMAGIC(tmpsv);
}
if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
tmpsv = GvSV(tmpgv);
#ifdef WIN32
sv_setpv(tmpsv,"perl.exe");
#else
sv_setpv(tmpsv,"perl");
#endif
SvSETMAGIC(tmpsv);
}
TAINT_NOT;
/* PL_main_cv = PL_compcv; */
PL_compcv = 0;
exitstatus = perl_init();
if (exitstatus)
exit( exitstatus );
dl_init(aTHX);
exitstatus = perl_run( my_perl );
perl_destruct( my_perl );
perl_free( my_perl );
PERL_SYS_TERM();
exit( exitstatus );
}
