AV* coerce1D ( SV* arg, int n ) {
/* n is the size of array var[] (n=1 for 1 element, etc.) */
AV* array;
I32 i,m;
/* In ref to scalar case we can do nothing - we can only hope the
caller made the scalar the right size in the first place */
if (is_scalar_ref(arg)) /* Do nothing */
return (AV*)NULL;
/* Check what has been passed and create array reference whether it
exists or not */
if (SvTYPE(arg)==SVt_PVGV) {
array = GvAVn((GV*)arg); /* glob */
}else if (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV) {
array = (AV *) SvRV(arg); /* reference */
}else{
array = newAV(); /* Create */
sv_setsv(arg, newRV((SV*) array));
}
m = av_len(array);
for (i=m+1; i<n; i++) {
av_store( array, i, newSViv( (IV) 0 ) );
}
return array;
}
STATIC void
S_gv_init_sv(pTHX_ GV *gv, I32 sv_type)
{
switch (sv_type) {
case SVt_PVIO:
(void)GvIOn(gv);
break;
case SVt_PVAV:
(void)GvAVn(gv);
break;
case SVt_PVHV:
(void)GvHVn(gv);
break;
}
}
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;
}
void pack_element(SV* work, SV** arg, char packtype) {
I32 i,n;
AV* array;
int iscalar;
float scalar;
short sscalar;
unsigned char uscalar;
double nval;
/* Pack element arg onto work recursively */
/* Is arg a scalar? Pack and return */
if (arg==NULL || (!SvROK(*arg) && SvTYPE(*arg)!=SVt_PVGV)) {
if (arg==NULL)
nval = 0.0;
else
nval = SvNV(*arg);
if (packtype=='f') {
scalar = (float) nval; /* Get the scalar value */
sv_catpvn(work, (char *) &scalar, sizeof(float)); /* Pack it in */
}
if (packtype=='i') {
iscalar = (int) nval; /* Get the scalar value */
sv_catpvn(work, (char *) &iscalar, sizeof(int)); /* Pack it in */
}
if (packtype=='d') {
sv_catpvn(work, (char *) &nval, sizeof(double)); /* Pack it in */
}
if (packtype=='s') {
sscalar = (short) nval; /* Get the scalar value */
sv_catpvn(work, (char *) &sscalar, sizeof(short)); /* Pack it in */
}
if (packtype=='u') {
uscalar = (unsigned char) nval;
sv_catpvn(work, (char *) &uscalar, sizeof(char)); /* Pack it in */
}
return;
}
/* Is it a glob or reference to an array? */
if (SvTYPE(*arg)==SVt_PVGV || (SvROK(*arg) && SvTYPE(SvRV(*arg))==SVt_PVAV)) {
/* Dereference */
if (SvTYPE(*arg)==SVt_PVGV) {
array = GvAVn((GV*)*arg); /* glob */
}else{
array = (AV *) SvRV(*arg); /* reference */
}
/* Pack each array element */
n = av_len(array);
for (i=0; i<=n; i++) {
/* To curse is human, to recurse divine */
pack_element(work, av_fetch(array, i, 0), packtype );
}
return;
}
Perl_croak(aTHX_ "Routine can only handle scalars or refs to N-D arrays of scalars");
}
void* pack2D_sz ( SV* arg, char packtype, int *nx, int *ny ) {
int iscalar;
float scalar;
short sscalar;
double dscalar;
unsigned char uscalar;
AV* array;
AV* array2 = Nullav;
I32 i,j,n,m,m_old;
SV* work;
SV** work2;
double nval = 0.0;
int isref;
STRLEN len;
if (nx != NULL) *nx = -1;
if (ny != NULL) *ny = -1;
m_old = -1;
if (is_scalar_ref(arg)) /* Scalar ref */
return (void*) SvPV(SvRV(arg), len);
if (packtype!='f' && packtype!='i' && packtype!='d' && packtype!='s'
&& packtype!='u')
croak("Programming error: invalid type conversion specified to pack2D");
/* Is arg a scalar? Return pointer to char part */
if (!SvROK(arg) && SvTYPE(arg)!=SVt_PVGV) { return (void *) SvPV(arg, PL_na); }
/*
Create a work char variable - be cunning and make it a mortal *SV
which will go away automagically when we leave the current
context, i.e. no need to malloc and worry about freeing - thus
we can use pack2D in a typemap!
*/
work = sv_2mortal(newSVpv("", 0));
/* Is it a glob or reference to an array? */
if (SvTYPE(arg)==SVt_PVGV || (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV)) {
if (SvTYPE(arg)==SVt_PVGV) {
array = GvAVn((GV*) arg); /* glob */
}else{
array = (AV *) SvRV(arg); /* reference */
}
n = av_len(array);
if (nx != NULL) *nx = n + 1;
/* Pack array into string */
for(i=0; i<=n; i++) { /* Loop over 1st dimension */
work2 = av_fetch( array, i, 0 ); /* Fetch */
isref = work2!=NULL && SvROK(*work2); /* Is is a reference */
if (isref) {
array2 = (AV *) SvRV(*work2); /* array of 2nd dimension */
m = av_len(array2); /* Length */
} else {
m=0; /* 1D array */
nval = SvNV(*work2);
}
/* first time around store value in m_old else compare*/
if (m_old != -1 && m_old != m)
Perl_croak(aTHX_ "2D array is not rectangular. Row %d has %d elements, not %d",(n+1),(m+1),(m_old+1));
m_old = m;
/* Pregrow storage for efficiency on first row - note assumes
array is rectangular but better than nothing */
if (i==0) {
if (packtype=='f')
SvGROW( work, sizeof(float)*(n+1)*(m+1) );
if (packtype=='i')
SvGROW( work, sizeof(int)*(n+1)*(m+1) );
if (packtype=='s')
SvGROW( work, sizeof(short)*(n+1)*(m+1) );
if (packtype=='u')
SvGROW( work, sizeof(char)*(n+1)*(m+1) );
if (packtype=='d')
SvGROW( work, sizeof(double)*(n+1)*(m+1) );
}
for(j=0; j<=m; j++) { /* Loop over 2nd dimension */
if (isref) {
work2 = av_fetch( array2, j, 0 ); /* Fetch element */
if (work2==NULL)
nval = 0.0; /* Undefined */
else {
if (SvROK(*work2))
goto errexit; /* Croak if reference [i.e. not 1D] */
nval = SvNV(*work2);
}
}
if (packtype=='d') {
dscalar = (double) nval;
sv_catpvn( work, (char *) &dscalar, sizeof(double));
}
if (packtype=='f') {
scalar = (float) nval;
sv_catpvn( work, (char *) &scalar, sizeof(float));
}
if (packtype=='i') {
iscalar = (int) nval;
sv_catpvn( work, (char *) &iscalar, sizeof(int));
}
if (packtype=='s') {
sscalar = (short) nval;
sv_catpvn( work, (char *) &sscalar, sizeof(short));
}
if (packtype=='u') {
uscalar = (unsigned char) nval;
sv_catpvn( work, (char *) &uscalar, sizeof(char));
}
}
}
/* Store ny */
if (ny != NULL) *ny = m + 1;
/* Return a pointer to the byte array */
return (void *) SvPV(work, PL_na);
}
errexit:
croak("Routine can only handle scalar packed char values or refs to 1D or 2D arrays");
}
void* pack1D_sz( SV* arg, char packtype, int * nelem) {
int iscalar;
float scalar;
double dscalar;
short sscalar;
unsigned char uscalar;
AV* array;
I32 i,n;
SV* work;
SV** work2;
double nval;
STRLEN len;
/* assume no size known */
if (nelem != NULL) *nelem = -1;
if (is_scalar_ref(arg)) /* Scalar ref */
return (void*) SvPV(SvRV(arg), len);
if (packtype!='f' && packtype!='i' && packtype!='d' && packtype!='s'
&& packtype != 'u')
Perl_croak(aTHX_ "Programming error: invalid type conversion specified to pack1D");
/*
Create a work char variable - be cunning and make it a mortal *SV
which will go away automagically when we leave the current
context, i.e. no need to malloc and worry about freeing - thus
we can use pack1D in a typemap!
*/
work = sv_2mortal(newSVpv("", 0));
/* Is arg a scalar? Return scalar*/
if (!SvROK(arg) && SvTYPE(arg)!=SVt_PVGV) {
if (packtype=='f') {
scalar = (float) SvNV(arg); /* Get the scalar value */
sv_setpvn(work, (char *) &scalar, sizeof(float)); /* Pack it in */
}
if (packtype=='i') {
iscalar = (int) SvNV(arg); /* Get the scalar value */
sv_setpvn(work, (char *) &iscalar, sizeof(int)); /* Pack it in */
}
if (packtype=='d') {
dscalar = (double) SvNV(arg); /*Get the scalar value */
sv_setpvn(work, (char *) &dscalar, sizeof(double)); /* Pack it in */
}
if (packtype=='s') {
sscalar = (short) SvNV(arg); /*Get the scalar value */
sv_setpvn(work, (char *) &sscalar, sizeof(short)); /* Pack it in */
}
if (packtype=='u') {
uscalar = (unsigned char) SvNV(arg); /*Get the scalar value */
sv_setpvn(work, (char *) &uscalar, sizeof(char)); /* Pack it in */
}
return (void *) SvPV(work, PL_na); /* Return the pointer */
}
/* Is it a glob or reference to an array? */
if (SvTYPE(arg)==SVt_PVGV || (SvROK(arg) && SvTYPE(SvRV(arg))==SVt_PVAV)) {
if (SvTYPE(arg)==SVt_PVGV) {
array = (AV *) GvAVn((GV*) arg); /* glob */
}else{
array = (AV *) SvRV(arg); /* reference */
}
n = av_len(array);
if ( nelem != NULL )
*nelem = n + 1;
if (packtype=='f')
SvGROW( work, sizeof(float)*(n+1) ); /* Pregrow for efficiency */
if (packtype=='i')
SvGROW( work, sizeof(int)*(n+1) );
if (packtype=='d')
SvGROW( work, sizeof(double)*(n+1) );
if (packtype=='s')
SvGROW( work, sizeof(short)*(n+1) );
if (packtype=='u')
SvGROW( work, sizeof(char)*(n+1) );
/* Pack array into string */
for(i=0; i<=n; i++) {
work2 = av_fetch( array, i, 0 ); /* Fetch */
if (work2==NULL)
nval = 0.0; /* Undefined */
else {
if (SvROK(*work2))
goto errexit; /* Croak if reference [i.e. not 1D] */
nval = SvNV(*work2);
}
if (packtype=='f') {
scalar = (float) nval;
sv_catpvn( work, (char *) &scalar, sizeof(float));
}
if (packtype=='i') {
iscalar = (int) nval;
sv_catpvn( work, (char *) &iscalar, sizeof(int));
}
if (packtype=='d') {
dscalar = (double) nval;
sv_catpvn( work, (char *) &dscalar, sizeof(double));
}
if (packtype=='s') {
sscalar = (short) nval;
sv_catpvn( work, (char *) &sscalar, sizeof(short));
}
if (packtype=='u') {
uscalar = (unsigned char) nval;
sv_catpvn( work, (char *) &uscalar, sizeof(char));
}
}
/* Return a pointer to the byte array */
return (void *) SvPV(work, PL_na);
}
errexit:
Perl_croak(aTHX_ "Routine can only handle scalar values or refs to 1D arrays of scalars");
}
