char *cc(pTHX_ char *c,int l)
{
char *x;
char *h;
char z;
char t;
int i,j,k,p,r;
int f;
for(i=f=0;i<l;i++){
if(c[i] == '#' || (c[i] == '/' && c[(i+1)] == '/') || (c[i] == '/' && c[(i+1)] == '*')){ f++; break; }
}
if(! f){ return c; }
if((x = (char *)malloc(l+1)) == NULL){
Perl_croak(aTHX_ "failed malloc in function cc");
return NULL;
}
for(i=j=f=0;i<l;i++){
if(c[i] == '#'){
for(;i<l;i++){
if(c[i] == '\r' || c[i] == '\n'){
j = j + sc(x+(j-1),j);
x[j++] = c[i];
break;
}
}
} else if((c[i] == '/' && c[(i+1)] == '*')){
if(l > (i+=2)){
j = j + sc(x+(j-1),j);
for(;i<l;i++){
if(c[i] == '\r' || c[i] == '\n'){
x[j++] = c[i];
} else if(c[i] == '*' && c[(i+1)] == '/'){
i++; f++; break;
}
}
}
if(!f){
Perl_croak(aTHX_ "could not find end of comment in function cc(/**/)");
return NULL;
}
} else if(c[i] == '/' && c[(i+1)] == '/'){
for(r=i-1;r>0;r--){
if(c[r] == 0x09 || c[r] == 0x20){ continue; }
if(c[r] == '~'){ f++; }
break;
}
if(f){
x[j++] = c[i];
x[j++] = c[++i];
} else{
for(;i<l;i++){
if(c[i] == '\r' || c[i] == '\n'){
j = j + sc(x+(j-1),j);
x[j++] = c[i];
break;
}
}
}
} else if(c[i] == '/'){
x[j++] = c[i];
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == '/'){
f++; break;
}
}
if(!f){
Perl_croak(aTHX_ "could not find end of regexp in function cc(//)");
return NULL;
}
} else if(c[i] == '<' && c[(i+1)] == '<'){
x[j++] = c[i];
x[j++] = c[(i+1)];
if(l > (i+=2)){
if((h = ht(c+i)) == NULL){
x[j++] = c[i];
continue;
}
p = strlen(h);
for(k=0;k<p;k++){
x[j++] = c[(i+k)];
}
for(i+=p;i<l;i++){
if(strncmp(c+i,h,p) == 0){
f++; i--; break;
} else{
x[j++] = c[i];
}
}
free(h);
}
if(!f){
Perl_croak(aTHX_ "could not find end of here-document in function cc(>>)");
return NULL;
}
} else if(c[i] == '<'){
x[j++] = c[i];
for(r=i-1;r>0;r--){
if(c[r] == 0x09 || c[r] == 0x20){ continue; }
if(c[r] == '~'){ f++; }
break;
}
if(!f){
continue;
} else{
for(i+=1,f=0;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == '>'){
f++; break;
}
}
if(!f){
Perl_croak(aTHX_ "could not find end of regexp in function cc(<>)");
return NULL;
}
}
} else if(c[i] == 0x22 || c[i] == 0x27 || c[i] == '`'){
x[j++] = c[i];
z = c[i];
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
f++; break;
}
}
if(!f){
Perl_croak(aTHX_ "could not find end of quote in function cc(%c)",z);
return NULL;
}
} else if(c[i] == 'q' && (c[(i+1)] == 'q' || c[(i+1)] == 'r' || c[(i+1)] == 'w' || c[(i+1)] == 'x')){
x[j++] = c[i];
x[j++] = c[(i+1)];
t = c[(i+1)];
if(l > (i+=2)){
if(ns(c[i])){
x[j++] = c[i];
continue;
}
x[j++] = c[i];
switch(c[i]){
case '(': z = ')'; break;
case '[': z = ']'; break;
case '{': z = '}'; break;
case '<': z = '>'; break;
default: z = c[i];
}
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
f++; break;
}
}
}
if(!f){
Perl_croak(aTHX_ "could not find end of quote in function in cc(q%c)",t);
return NULL;
}
} else if(c[i] == 'm' || c[i] == 'q'){
x[j++] = c[i];
t = c[i];
if(ns(c[(i+1)])){
continue;
}
if(l > ++i){
x[j++] = c[i];
switch(c[i]){
case '(': z = ')'; break;
case '[': z = ']'; break;
case '{': z = '}'; break;
case '<': z = '>'; break;
default: z = c[i];
}
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
f++; break;
}
}
}
if(!f){
if(t == 'm'){
Perl_croak(aTHX_ "could not find end of regexp in function in cc(%c)",t);
} else{
Perl_croak(aTHX_ "could not find end of quote in function in cc(%c)",t);
}
return NULL;
}
} else if(c[i] == 's'){
x[j++] = c[i];
if(ns(c[(i+1)])){
continue;
}
if(l > ++i){
switch(c[i]){
case '(': t = c[i]; z = ')'; break;
case '[': t = c[i]; z = ']'; break;
case '{': t = c[i]; z = '}'; break;
case '<': t = c[i]; z = '>'; break;
default: t = '\0'; z = c[i];
}
x[j++] = c[i];
if(t == '\0'){
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
if(++f > 1){ break; }
}
}
} else{
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
f++; break;
}
}
if(! f || c[(i+1)] != t){
Perl_croak(aTHX_ "could not find end of regexp in function in cc(s)");
return NULL;
} else{
for(i+=1,f=0;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
f++; break;
}
}
}
}
}
if(!f){
Perl_croak(aTHX_ "could not find end of regexp in function in cc(s)");
return NULL;
}
} else if(c[i] == 't' && c[(i+1)] == 'r'){
x[j++] = c[i];
x[j++] = c[(i+1)];
if(l > (i+=2)){
if(ns(c[i])){
x[j++] = c[i];
continue;
}
switch(c[i]){
case '(': t = c[i]; z = ')'; break;
case '[': t = c[i]; z = ']'; break;
case '{': t = c[i]; z = '}'; break;
case '<': t = c[i]; z = '>'; break;
default: t = '\0'; z = c[i];
}
x[j++] = c[i];
if(t == '\0'){
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
if(++f > 1){ break; }
}
}
} else{
for(i+=1;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
f++; break;
}
}
if(! f || c[(i+1)] != t){
Perl_croak(aTHX_ "could not find end of regexp in function in cc(tr)");
return NULL;
} else{
for(i+=1,f=0;i<l;i++){
x[j++] = c[i];
if(c[(i-1)] != '\\' && c[i] == z){
f++; break;
}
}
}
}
}
if(!f){
Perl_croak(aTHX_ "could not find end of regexp in function in cc(tr)");
return NULL;
}
} else{
x[j++] = c[i];
}
f = 0;
}
x[j] = '\0';
return x;
}
int modperl_callback(pTHX_ modperl_handler_t *handler, apr_pool_t *p,
request_rec *r, server_rec *s, AV *args)
{
CV *cv = (CV *)NULL;
I32 flags = G_EVAL|G_SCALAR;
dSP;
int count, status = OK;
/* handler callbacks shouldn't affect each other's taintedness
* state, so start every callback with a clear tainted status
* before and after the callback one of the main problems we are
* trying to solve is that when modperl_croak called (which calls
* perl's croak((char *)NULL) to throw an error object) it leaves
* the interpreter in the tainted state which later affects other
* callbacks that call eval, etc., which triggers perl crash with:
* Insecure dependency in eval while running setgid. Callback
* called exit.
*/
TAINT_NOT;
if ((status = modperl_handler_resolve(aTHX_ &handler, p, s)) != OK) {
TAINT_NOT;
return status;
}
ENTER;SAVETMPS;
PUSHMARK(SP);
if (MpHandlerMETHOD(handler)) {
GV *gv;
if (!handler->mgv_obj) {
Perl_croak(aTHX_ "panic: %s method handler object is NULL!",
modperl_handler_name(handler));
}
gv = modperl_mgv_lookup(aTHX_ handler->mgv_obj);
XPUSHs(modperl_mgv_sv(gv));
}
if (args) {
I32 items = AvFILLp(args) + 1;
EXTEND(SP, items);
Copy(AvARRAY(args), SP + 1, items, SV*);
SP += items;
}
PUTBACK;
if (MpHandlerANON(handler)) {
#ifdef USE_ITHREADS
cv = modperl_handler_anon_get(aTHX_ handler->mgv_obj);
#else
cv = handler->cv;
#endif
}
else {
GV *gv = modperl_mgv_lookup_autoload(aTHX_ handler->mgv_cv, s, p);
if (gv) {
cv = modperl_mgv_cv(gv);
}
else {
const char *name;
modperl_mgv_t *symbol = handler->mgv_cv;
/* XXX: need to validate *symbol */
if (symbol && symbol->name) {
name = modperl_mgv_as_string(aTHX_ symbol, p, 0);
}
else {
name = handler->name;
}
MP_TRACE_h(MP_FUNC, "[%s %s] lookup of %s failed",
modperl_pid_tid(p),
modperl_server_desc(s, p), name);
ap_log_error(APLOG_MARK, APLOG_ERR, 0, s,
"lookup of '%s' failed", name);
status = HTTP_INTERNAL_SERVER_ERROR;
}
}
if (status == OK) {
count = call_sv((SV*)cv, flags);
SPAGAIN;
if (count != 1) {
/* XXX can this really happen with G_EVAL|G_SCALAR? */
status = OK;
}
else {
SV *status_sv = POPs;
if (status_sv == &PL_sv_undef) {
/* ModPerl::Util::exit() and Perl_croak internally
* arrange to return PL_sv_undef with G_EVAL|G_SCALAR */
status = OK;
}
else {
status = SvIVx(status_sv);
}
}
PUTBACK;
}
FREETMPS;LEAVE;
if (SvTRUE(ERRSV)) {
MP_TRACE_h(MP_FUNC, "$@ = %s", SvPV_nolen(ERRSV));
status = HTTP_INTERNAL_SERVER_ERROR;
}
if (status == HTTP_INTERNAL_SERVER_ERROR) {
if (r && r->notes) {
apr_table_merge(r->notes, "error-notes", SvPV_nolen(ERRSV));
}
}
TAINT_NOT;
return status;
}
/*
=for apidoc mro_isa_changed_in
Takes the necessary steps (cache invalidations, mostly)
when the @ISA of the given package has changed. Invoked
by the C<setisa> magic, should not need to invoke directly.
=cut
*/
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
dVAR;
HV* isarev;
AV* linear_mro;
HE* iter;
SV** svp;
I32 items;
bool is_universal;
struct mro_meta * meta;
const char * const stashname = HvNAME_get(stash);
const STRLEN stashname_len = HvNAMELEN_get(stash);
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
SvREFCNT_dec(MUTABLE_SV(meta->mro_linear_c3));
meta->mro_linear_c3 = NULL;
if (meta->isa) {
HvREFCNT_dec(meta->isa);
meta->isa = NULL;
}
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
is_universal = TRUE;
}
else { /* Wipe the local method cache otherwise */
meta->cache_gen++;
is_universal = FALSE;
}
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches */
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 len;
const char* const revkey = hv_iterkey(iter, &len);
HV* revstash = gv_stashpvn(revkey, len, 0);
struct mro_meta* revmeta;
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
SvREFCNT_dec(MUTABLE_SV(revmeta->mro_linear_c3));
revmeta->mro_linear_c3 = NULL;
if(!is_universal)
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
if (revmeta->isa) {
HvREFCNT_dec(revmeta->isa);
revmeta->isa = NULL;
}
}
}
/* Now iterate our MRO (parents), and do a few things:
1) instantiate with the "fake" flag if they don't exist
2) flag them as universal if we are universal
3) Add everything from our isarev to their isarev
*/
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create a new SV for
us, then will need to upgrade it to an HV (which sv_upgrade() can
now do for us. */
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
(void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
if(isarev) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
I32 revkeylen;
char* const revkey = hv_iterkey(iter, &revkeylen);
(void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
}
}
}
}
static AV*
S_mro_get_linear_isa_c3(pTHX_ HV* stash, U32 level)
{
AV* retval;
GV** gvp;
GV* gv;
AV* isa;
const HEK* stashhek;
struct mro_meta* meta;
PERL_ARGS_ASSERT_MRO_GET_LINEAR_ISA_C3;
assert(HvAUX(stash));
stashhek = HvNAME_HEK(stash);
if (!stashhek)
Perl_croak(aTHX_ "Can't linearize anonymous symbol table");
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HEK_KEY(stashhek));
meta = HvMROMETA(stash);
/* return cache if valid */
if((retval = meta->mro_linear_c3)) {
return retval;
}
/* not in cache, make a new one */
gvp = (GV**)hv_fetchs(stash, "ISA", FALSE);
isa = (gvp && (gv = *gvp) && isGV_with_GP(gv)) ? GvAV(gv) : NULL;
if ( isa && ! SvAVOK(isa) ) {
Perl_croak(aTHX_ "@ISA is not an array but %s", Ddesc((SV*)isa));
}
/* For a better idea how the rest of this works, see the much clearer
pure perl version in Algorithm::C3 0.01:
http://search.cpan.org/src/STEVAN/Algorithm-C3-0.01/lib/Algorithm/C3.pm
(later versions go about it differently than this code for speed reasons)
*/
if(isa && AvFILLp(isa) >= 0) {
SV** seqs_ptr;
I32 seqs_items;
HV* const tails = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
AV *const seqs = MUTABLE_AV(sv_2mortal(MUTABLE_SV(newAV())));
I32* heads;
/* This builds @seqs, which is an array of arrays.
The members of @seqs are the MROs of
the members of @ISA, followed by @ISA itself.
*/
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
SV* const isa_item = *isa_ptr++;
if ( ! SvPVOK(isa_item) ) {
Perl_croak(aTHX_ "@ISA element which is not an plain value");
}
{
HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
/* if no stash, make a temporary fake MRO
containing just itself */
AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
av_push(seqs, (SV*)isa_lin);
}
else {
/* recursion */
AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
av_push(seqs, SvREFCNT_inc_NN((SV*)isa_lin));
}
}
}
av_push(seqs, SvREFCNT_inc_NN((SV*)isa));
/* This builds "heads", which as an array of integer array
indices, one per seq, which point at the virtual "head"
of the seq (initially zero) */
Newxz(heads, AvFILLp(seqs)+1, I32);
/* This builds %tails, which has one key for every class
mentioned in the tail of any sequence in @seqs (tail meaning
everything after the first class, the "head"). The value
is how many times this key appears in the tails of @seqs.
*/
seqs_ptr = AvARRAY(seqs);
seqs_items = AvFILLp(seqs) + 1;
while(seqs_items--) {
AV *const seq = MUTABLE_AV(*seqs_ptr++);
I32 seq_items = AvFILLp(seq);
if(seq_items > 0) {
SV** seq_ptr = AvARRAY(seq) + 1;
while(seq_items--) {
SV* const seqitem = *seq_ptr++;
/* LVALUE fetch will create a new undefined SV if necessary
*/
HE* const he = hv_fetch_ent(tails, seqitem, 1, 0);
if(he) {
SV* const val = HeVAL(he);
/* This will increment undef to 1, which is what we
want for a newly created entry. */
sv_inc(val);
}
}
}
}
/* Initialize retval to build the return value in */
retval = newAV();
av_push(retval, newSVhek(stashhek)); /* us first */
/* This loop won't terminate until we either finish building
the MRO, or get an exception. */
while(1) {
SV* cand = NULL;
SV* winner = NULL;
int s;
/* "foreach $seq (@seqs)" */
SV** const avptr = AvARRAY(seqs);
for(s = 0; s <= AvFILLp(seqs); s++) {
SV** svp;
AV * const seq = MUTABLE_AV(avptr[s]);
SV* seqhead;
if(!seq) continue; /* skip empty seqs */
svp = av_fetch(seq, heads[s], 0);
seqhead = *svp; /* seqhead = head of this seq */
if(!winner) {
HE* tail_entry;
SV* val;
/* if we haven't found a winner for this round yet,
and this seqhead is not in tails (or the count
for it in tails has dropped to zero), then this
seqhead is our new winner, and is added to the
final MRO immediately */
cand = seqhead;
if((tail_entry = hv_fetch_ent(tails, cand, 0, 0))
&& (val = HeVAL(tail_entry))
&& (SvIV(val) > 0))
continue;
winner = newSVsv(cand);
av_push(retval, winner);
/* note however that even when we find a winner,
we continue looping over @seqs to do housekeeping */
}
if(!sv_cmp(seqhead, winner)) {
/* Once we have a winner (including the iteration
where we first found him), inc the head ptr
for any seq which had the winner as a head,
NULL out any seq which is now empty,
and adjust tails for consistency */
const int new_head = ++heads[s];
if(new_head > AvFILLp(seq)) {
SvREFCNT_dec(avptr[s]);
avptr[s] = NULL;
}
else {
HE* tail_entry;
SV* val;
/* Because we know this new seqhead used to be
a tail, we can assume it is in tails and has
a positive value, which we need to dec */
svp = av_fetch(seq, new_head, 0);
seqhead = *svp;
tail_entry = hv_fetch_ent(tails, seqhead, 0, 0);
val = HeVAL(tail_entry);
sv_dec(val);
}
}
}
/* if we found no candidates, we are done building the MRO.
!cand means no seqs have any entries left to check */
if(!cand) {
Safefree(heads);
break;
}
/* If we had candidates, but nobody won, then the @ISA
hierarchy is not C3-incompatible */
if(!winner) {
SV *errmsg;
I32 i;
errmsg = newSVpvf(aTHX_ "Inconsistent hierarchy during C3 merge of class '%s':\n\t"
"current merge results [\n", HEK_KEY(stashhek));
for (i = 0; i <= av_len(retval); i++) {
SV **elem = av_fetch(retval, i, 0);
sv_catpvf(aTHX_ errmsg, "\t\t%"SVf",\n", SVfARG(*elem));
}
sv_catpvf(aTHX_ errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand));
/* we have to do some cleanup before we croak */
AvREFCNT_dec(retval);
Safefree(heads);
croak(aTHX_ "%"SVf, SVfARG(errmsg));
}
}
}
else { /* @ISA was undefined or empty */
/* build a retval containing only ourselves */
retval = newAV();
av_push(retval, newSVhek(stashhek));
}
/* we don't want anyone modifying the cache entry but us,
and we do so by replacing it completely */
SvREADONLY_on(retval);
meta->mro_linear_c3 = retval;
return retval;
}
STATIC I32
S_do_trans_complex(pTHX_ SV * const sv)
{
STRLEN len;
U8 *s = (U8*)SvPV_nomg(sv, len);
U8 * const send = s+len;
I32 matches = 0;
const short * const tbl = (short*)cPVOP->op_pv;
PERL_ARGS_ASSERT_DO_TRANS_COMPLEX;
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];
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;
}
/* helper for the default modify handler for builtin attributes */
static int
modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
{
SV *attr;
int nret;
for (nret = 0 ; numattrs && (attr = *attrlist++); numattrs--) {
STRLEN len;
const char *name = SvPV_const(attr, len);
const bool negated = (*name == '-');
HV *typestash;
if (negated) {
name++;
len--;
}
switch (SvTYPE(sv)) {
case SVt_PVCV:
switch ((int)len) {
case 4:
if (memEQ(name, "pure", 4)) {
if (negated)
Perl_croak(aTHX_ "Illegal :-pure attribute");
CvPURE_on(sv);
goto next_attr;
}
break;
case 5:
if (memEQ(name, "const", 5)) {
if (negated)
CvCONST_off(sv);
else {
#ifndef USE_CPERL
const bool warn = (!CvANON(sv) || CvCLONED(sv))
&& !CvCONST(sv);
CvCONST_on(sv);
if (warn)
break;
#else
CvCONST_on(sv);
#endif
}
goto next_attr;
}
break;
case 6:
switch (name[3]) {
case 'l':
if (memEQ(name, "lvalue", 6)) {
bool warn =
!CvISXSUB(MUTABLE_CV(sv))
&& CvROOT(MUTABLE_CV(sv))
&& !CvLVALUE(MUTABLE_CV(sv)) != negated;
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_LVALUE;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_LVALUE;
if (warn) break;
goto next_attr;
}
break;
case 'h':
if (memEQ(name, "method", 6)) {
if (negated)
CvFLAGS(MUTABLE_CV(sv)) &= ~CVf_METHOD;
else
CvFLAGS(MUTABLE_CV(sv)) |= CVf_METHOD;
goto next_attr;
}
break;
}
break;
default:
if (len > 10 && memEQ(name, "prototype(", 10)) {
SV * proto = newSVpvn(name+10,len-11);
HEK *const hek = CvNAME_HEK((CV *)sv);
SV *subname;
if (name[len-1] != ')')
Perl_croak(aTHX_ "Unterminated attribute parameter in attribute list");
if (hek)
subname = sv_2mortal(newSVhek(hek));
else
subname=(SV *)CvGV((const CV *)sv);
if (ckWARN(WARN_ILLEGALPROTO))
Perl_validate_proto(aTHX_ subname, proto, TRUE);
Perl_cv_ckproto_len_flags(aTHX_ (const CV *)sv,
(const GV *)subname,
name+10,
len-11,
SvUTF8(attr));
sv_setpvn(MUTABLE_SV(sv), name+10, len-11);
if (SvUTF8(attr)) SvUTF8_on(MUTABLE_SV(sv));
goto next_attr;
}
break;
}
if (!negated && (typestash = gv_stashpvn(name, len, SvUTF8(attr)))) {
CvTYPED_on(sv);
CvTYPE_set((CV*)sv, typestash);
continue;
}
break;
case SVt_IV:
case SVt_PVIV:
case SVt_PVMG:
if (memEQ(name, "unsigned", 8)
&& (SvIOK(sv) || SvUOK(sv)))
{
if (negated) /* :-unsigned alias for :signed */
SvIsUV_off(sv);
else
SvIsUV_on(sv);
continue;
}
/* fallthru - all other data types */
default:
if (memEQ(name, "const", 5)
&& !(SvFLAGS(sv) & SVf_PROTECT))
{
if (negated)
SvREADONLY_off(sv);
else
SvREADONLY_on(sv);
continue;
}
if (memEQs(name, len, "shared")) {
if (negated)
Perl_croak(aTHX_ "A variable may not be unshared");
SvSHARE(sv);
continue;
}
break;
}
/* anything recognized had a 'continue' above */
*retlist++ = attr;
nret++;
next_attr:
;
}
return nret;
}
STATIC SV *
S_isa_lookup(pTHX_ HV *stash, const char *name, int len, int level)
{
AV* av;
GV* gv;
GV** gvp;
HV* hv = Nullhv;
SV* subgen = Nullsv;
if (!stash)
return &PL_sv_undef;
if (strEQ(HvNAME(stash), name))
return &PL_sv_yes;
if (level > 100)
Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'",
HvNAME(stash));
gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv))
&& (hv = GvHV(gv)))
{
if (SvIV(subgen) == PL_sub_generation) {
SV* sv;
SV** svp = (SV**)hv_fetch(hv, name, len, FALSE);
if (svp && (sv = *svp) != (SV*)&PL_sv_undef) {
DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n",
name, HvNAME(stash)) );
return sv;
}
}
else {
DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n",
HvNAME(stash)) );
hv_clear(hv);
sv_setiv(subgen, PL_sub_generation);
}
}
gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
if (!hv || !subgen) {
gvp = (GV**)hv_fetch(stash, "::ISA::CACHE::", 14, TRUE);
gv = *gvp;
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE);
if (!hv)
hv = GvHVn(gv);
if (!subgen) {
subgen = newSViv(PL_sub_generation);
GvSV(gv) = subgen;
}
}
if (hv) {
SV** svp = AvARRAY(av);
/* NOTE: No support for tied ISA */
I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ WARN_SYNTAX,
"Can't locate package %s for @%s::ISA",
SvPVX(sv), HvNAME(stash));
continue;
}
if (&PL_sv_yes == isa_lookup(basestash, name, len, level + 1)) {
(void)hv_store(hv,name,len,&PL_sv_yes,0);
return &PL_sv_yes;
}
}
(void)hv_store(hv,name,len,&PL_sv_no,0);
}
}
return boolSV(strEQ(name, "UNIVERSAL"));
}
void endprotoent() {
dTHX;
Perl_croak(aTHX_ "Function \"endprotoent\" not implemented in this version of perl");
}
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 modperl_filter_runtime_add(pTHX_ request_rec *r, conn_rec *c,
const char *name,
modperl_filter_mode_e mode,
modperl_filter_add_t addfunc,
SV *callback, const char *type)
{
apr_pool_t *pool = r ? r->pool : c->pool;
modperl_handler_t *handler =
modperl_handler_new_from_sv(aTHX_ pool, callback);
if (handler) {
ap_filter_t *f;
modperl_filter_ctx_t *ctx =
(modperl_filter_ctx_t *)apr_pcalloc(pool, sizeof(*ctx));
ctx->handler = handler;
f = addfunc(name, (void*)ctx, r, c);
/* ap_filter_t filter cleanup */
apr_pool_cleanup_register(pool, (void *)f,
modperl_filter_f_cleanup,
apr_pool_cleanup_null);
/* has to resolve early so we can check for init functions */
if (!modperl_mgv_resolve(aTHX_ handler, pool, handler->name, TRUE)) {
Perl_croak(aTHX_ "unable to resolve handler %s\n",
modperl_handler_name(handler));
}
/* verify that the filter handler is of the right kind */
if (r == NULL) {
/* needs to have the FilterConnectionHandler attribute */
if (!(handler->attrs & MP_FILTER_CONNECTION_HANDLER)) {
Perl_croak(aTHX_ "Can't add connection filter handler '%s' "
"since it doesn't have the "
"FilterConnectionHandler attribute set",
modperl_handler_name(handler));
}
}
else {
/* needs to have the FilterRequestHandler attribute, but
* since by default request filters are not required to
* have the FilterRequestHandler attribute, croak only if
* some other attribute is set, but not
* FilterRequestHandler */
if (handler->attrs &&
!(handler->attrs & MP_FILTER_REQUEST_HANDLER)) {
Perl_croak(aTHX_ "Can't add request filter handler '%s' "
"since it doesn't have the "
"FilterRequestHandler attribute set",
modperl_handler_name(handler));
}
}
if (handler->attrs & MP_FILTER_HAS_INIT_HANDLER && handler->next) {
int status = modperl_run_filter_init(f, mode, handler->next);
if (status != OK) {
modperl_croak(aTHX_ status, strEQ("InputFilter", type)
? "Apache2::Filter::add_input_filter"
: "Apache2::Filter::add_output_filter");
}
}
MP_TRACE_h(MP_FUNC, "%s handler %s configured (connection)",
type, name);
return;
}
Perl_croak(aTHX_ "unable to resolve handler 0x%lx\n",
(unsigned long)callback);
}
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");
}
int dimtag_parse(pTHX_ const MemberInfo *pmi, const char *type, SV *tag, DimensionTag *dim)
{
enum dimension_tag_type tag_type = DTT_NONE;
assert(type != NULL);
assert(tag != NULL);
assert(dim != NULL);
assert(SvOK(tag));
if (SvROK(tag))
{
SV *sv = SvRV(tag);
switch (SvTYPE(sv))
{
case SVt_PVCV:
case SVt_PVAV:
tag_type = DTT_HOOK;
break;
default:
break;
}
}
else
{
if (SvPOK(tag))
{
STRLEN len;
const char *str = SvPV(tag, len);
if (len > 0)
{
if (strEQ(str, "*"))
{
tag_type = DTT_FLEXIBLE;
}
else if (looks_like_number(tag))
{
tag_type = DTT_FIXED;
}
else
{
tag_type = DTT_MEMBER;
}
}
}
else if (SvIOK(tag))
{
tag_type = DTT_FIXED;
}
}
switch (tag_type)
{
case DTT_NONE:
Perl_croak(aTHX_ "Invalid Dimension tag for '%s'", type);
break;
case DTT_FLEXIBLE:
break;
case DTT_FIXED:
{
IV value = SvIV(tag);
if (value < 0)
Perl_croak(aTHX_ "Cannot use negative value %" IVdf " in Dimension"
" tag for '%s'", value, type);
dim->u.fixed = value;
}
break;
case DTT_MEMBER:
{
STRLEN len;
const char *src = SvPV(tag, len);
validate_member_expression(aTHX_ pmi, src, type);
New(0, dim->u.member, len+1, char);
Copy(src, dim->u.member, len, char);
dim->u.member[len] = '\0';
}
break;
case DTT_HOOK:
{
SingleHook newhook;
U32 allowed = SHF_ALLOW_ARG_SELF
| SHF_ALLOW_ARG_HOOK;
if (pmi->parent)
allowed |= SHF_ALLOW_ARG_DATA;
single_hook_fill(aTHX_ "Dimension", type, &newhook, tag, allowed);
dim->u.hook = single_hook_new(&newhook);
}
break;
}
dim->type = tag_type;
return 1;
}
GV *
Perl_gv_fetchmeth(pTHX_ HV *stash, const char *name, STRLEN len, I32 level)
{
AV* av;
GV* topgv;
GV* gv;
GV** gvp;
CV* cv;
/* UNIVERSAL methods should be callable without a stash */
if (!stash) {
level = -1; /* probably appropriate */
if(!(stash = gv_stashpvn("UNIVERSAL", 9, FALSE)))
return 0;
}
if ((level > 100) || (level < -100))
Perl_croak(aTHX_ "Recursive inheritance detected while looking for method '%s' in package '%s'",
name, HvNAME(stash));
DEBUG_o( Perl_deb(aTHX_ "Looking for method %s in package %s\n",name,HvNAME(stash)) );
gvp = (GV**)hv_fetch(stash, name, len, (level >= 0));
if (!gvp)
topgv = Nullgv;
else {
topgv = *gvp;
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
if ((cv = GvCV(topgv))) {
/* If genuine method or valid cache entry, use it */
if (!GvCVGEN(topgv) || GvCVGEN(topgv) == PL_sub_generation)
return topgv;
/* Stale cached entry: junk it */
SvREFCNT_dec(cv);
GvCV(topgv) = cv = Nullcv;
GvCVGEN(topgv) = 0;
}
else if (GvCVGEN(topgv) == PL_sub_generation)
return 0; /* cache indicates sub doesn't exist */
}
gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE);
av = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : Nullav;
/* create and re-create @.*::SUPER::ISA on demand */
if (!av || !SvMAGIC(av)) {
char* packname = HvNAME(stash);
STRLEN packlen = strlen(packname);
if (packlen >= 7 && strEQ(packname + packlen - 7, "::SUPER")) {
HV* basestash;
packlen -= 7;
basestash = gv_stashpvn(packname, packlen, TRUE);
gvp = (GV**)hv_fetch(basestash, "ISA", 3, FALSE);
if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) {
gvp = (GV**)hv_fetch(stash, "ISA", 3, TRUE);
if (!gvp || !(gv = *gvp))
Perl_croak(aTHX_ "Cannot create %s::ISA", HvNAME(stash));
if (SvTYPE(gv) != SVt_PVGV)
gv_init(gv, stash, "ISA", 3, TRUE);
SvREFCNT_dec(GvAV(gv));
GvAV(gv) = (AV*)SvREFCNT_inc(av);
}
}
}
if (av) {
SV** svp = AvARRAY(av);
/* NOTE: No support for tied ISA */
I32 items = AvFILLp(av) + 1;
while (items--) {
SV* sv = *svp++;
HV* basestash = gv_stashsv(sv, FALSE);
if (!basestash) {
if (ckWARN(WARN_MISC))
Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA",
sv, HvNAME(stash));
continue;
}
gv = gv_fetchmeth(basestash, name, len,
(level >= 0) ? level + 1 : level - 1);
if (gv)
goto gotcha;
}
}
/* if at top level, try UNIVERSAL */
if (level == 0 || level == -1) {
HV* lastchance;
if ((lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE))) {
if ((gv = gv_fetchmeth(lastchance, name, len,
(level >= 0) ? level + 1 : level - 1)))
{
gotcha:
/*
* Cache method in topgv if:
* 1. topgv has no synonyms (else inheritance crosses wires)
* 2. method isn't a stub (else AUTOLOAD fails spectacularly)
*/
if (topgv &&
GvREFCNT(topgv) == 1 &&
(cv = GvCV(gv)) &&
(CvROOT(cv) || CvXSUB(cv)))
{
if ((cv = GvCV(topgv)))
SvREFCNT_dec(cv);
GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv));
GvCVGEN(topgv) = PL_sub_generation;
}
return gv;
}
else if (topgv && GvREFCNT(topgv) == 1) {
/* cache the fact that the method is not defined */
GvCVGEN(topgv) = PL_sub_generation;
}
}
}
return 0;
}
STATIC I32
S_do_trans_complex(pTHX_ SV *sv)
{
U8 *s;
U8 *send;
U8 *d;
U8 *dstart;
I32 isutf8;
I32 matches = 0;
I32 grows = PL_op->op_private & OPpTRANS_GROWS;
I32 complement = PL_op->op_private & OPpTRANS_COMPLEMENT;
I32 del = PL_op->op_private & OPpTRANS_DELETE;
STRLEN len, rlen = 0;
short *tbl;
I32 ch;
tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_complex line %d",__LINE__);
s = (U8*)SvPV(sv, len);
isutf8 = SvUTF8(sv);
send = s + len;
if (!isutf8) {
dstart = d = s;
if (PL_op->op_private & OPpTRANS_SQUASH) {
U8* p = send;
while (s < send) {
if ((ch = tbl[*s]) >= 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) {
if ((ch = tbl[*s]) >= 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 { /* isutf8 */
if (grows)
New(0, 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;
UV comp = utf8_to_uvchr(s, &len);
if (comp > 0xff) {
if (!complement) {
Copy(s, d, len, U8);
d += len;
}
else {
matches++;
if (!del) {
ch = (rlen == 0) ? 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 */
Copy(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;
UV comp = utf8_to_uvchr(s, &len);
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 */
Copy(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;
}
__sockadapt_my_netent_t getnetent() {
dTHX;
Perl_croak(aTHX_ "Function \"getnetent\" not implemented in this version of perl");
return (__sockadapt_my_netent_t )NULL; /* Avoid MISSINGRETURN warning, not reached */
}
STATIC I32
S_do_trans_simple(pTHX_ SV *sv)
{
U8 *s;
U8 *d;
U8 *send;
U8 *dstart;
I32 matches = 0;
I32 grows = PL_op->op_private & OPpTRANS_GROWS;
STRLEN len;
short *tbl;
I32 ch;
tbl = (short*)cPVOP->op_pv;
if (!tbl)
Perl_croak(aTHX_ "panic: do_trans_simple line %d",__LINE__);
s = (U8*)SvPV(sv, len);
send = s + len;
/* First, take care of non-UTF-8 input strings, because they're easy */
if (!SvUTF8(sv)) {
while (s < send) {
if ((ch = tbl[*s]) >= 0) {
matches++;
*s++ = (U8)ch;
}
else
s++;
}
SvSETMAGIC(sv);
return matches;
}
/* Allow for expansion: $_="a".chr(400); tr/a/\xFE/, FE needs encoding */
if (grows)
New(0, d, len*2+1, U8);
else
d = s;
dstart = d;
while (s < send) {
STRLEN ulen;
UV c;
/* Need to check this, otherwise 128..255 won't match */
c = utf8n_to_uvchr(s, send - s, &ulen, 0);
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;
}
void setservent(int stayopen) {
dTHX;
Perl_croak(aTHX_ "Function \"setservent\" not implemented in this version of perl");
}
void
S_signals_set_handler(SV* handlersv, SV* namesv)
{
I32 i;
/* Need to be careful with SvREFCNT_dec(), because that can have side
* effects (due to closures). We must make sure that the new disposition
* is in place before it is called.
*/
SV* to_dec = NULL;
STRLEN len;
const char *s;
bool set_to_ignore = FALSE;
bool set_to_default = FALSE;
#ifdef HAS_SIGPROCMASK
sigset_t set, save;
SV* save_sv;
#endif
if ( SvROK(handlersv) ) {
if ( SvTYPE(SvRV(handlersv)) != SVt_PVCV )
Perl_croak(aTHX_ "signal handler should be a code refernce, 'DEFAULT' or 'IGNORE'");
} else {
const char *s = SvOK(handlersv) ? SvPV_const(handlersv, len) : "DEFAULT";
if ( strEQ(s,"IGNORE") )
set_to_ignore = TRUE;
else if (strEQ(s,"DEFAULT"))
set_to_default = TRUE;
else
Perl_croak(aTHX_ "signal handler should be a code reference or 'DEFAULT or 'IGNORE'");
}
if (!PL_psig_ptr) {
Newxz(PL_psig_ptr, SIG_SIZE, SV*);
Newxz(PL_psig_name, SIG_SIZE, SV*);
Newxz(PL_psig_pend, SIG_SIZE, int);
}
s = SvPV_const(namesv,len);
i = whichsig(s); /* ...no, a brick */
if (i <= 0) {
Perl_croak(aTHX_ "No such signal: SIG%s", s);
}
#ifdef HAS_SIGPROCMASK
/* Avoid having the signal arrive at a bad time, if possible. */
sigemptyset(&set);
sigaddset(&set,i);
sigprocmask(SIG_BLOCK, &set, &save);
ENTER;
save_sv = newSVpvn((char *)(&save), sizeof(sigset_t));
SAVEFREESV(save_sv);
SAVEDESTRUCTOR_X(restore_sigmask, save_sv);
#endif
PERL_ASYNC_CHECK();
#if defined(FAKE_PERSISTENT_SIGNAL_HANDLERS) || defined(FAKE_DEFAULT_SIGNAL_HANDLERS)
if (!PL_sig_handlers_initted) Perl_csighandler_init();
#endif
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
PL_sig_ignoring[i] = 0;
#endif
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
PL_sig_defaulting[i] = 0;
#endif
SvREFCNT_dec(PL_psig_name[i]);
to_dec = PL_psig_ptr[i];
PL_psig_ptr[i] = NULL;
PL_psig_name[i] = newSVpvn(s, len);
SvREADONLY_on(PL_psig_name[i]);
if (SvROK(handlersv)) {
PL_psig_ptr[i] = SvREFCNT_inc(SvRV(handlersv));
(void)rsignal(i, PL_csighandlerp);
#ifdef HAS_SIGPROCMASK
LEAVE;
#endif
if(to_dec)
SvREFCNT_dec(to_dec);
return;
}
if (set_to_ignore) {
#ifdef FAKE_PERSISTENT_SIGNAL_HANDLERS
PL_sig_ignoring[i] = 1;
(void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, (Sighandler_t) SIG_IGN);
#endif
}
else {
#ifdef FAKE_DEFAULT_SIGNAL_HANDLERS
PL_sig_defaulting[i] = 1;
(void)rsignal(i, PL_csighandlerp);
#else
(void)rsignal(i, (Sighandler_t) SIG_DFL);
#endif
}
#ifdef HAS_SIGPROCMASK
if(i)
LEAVE;
#endif
if(to_dec)
SvREFCNT_dec(to_dec);
}
