1*0Sstevel@tonic-gate /* pp_pack.c 2*0Sstevel@tonic-gate * 3*0Sstevel@tonic-gate * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 4*0Sstevel@tonic-gate * 2000, 2001, 2002, 2003, 2004, by Larry Wall and others 5*0Sstevel@tonic-gate * 6*0Sstevel@tonic-gate * You may distribute under the terms of either the GNU General Public 7*0Sstevel@tonic-gate * License or the Artistic License, as specified in the README file. 8*0Sstevel@tonic-gate * 9*0Sstevel@tonic-gate */ 10*0Sstevel@tonic-gate 11*0Sstevel@tonic-gate /* 12*0Sstevel@tonic-gate * He still hopefully carried some of his gear in his pack: a small tinder-box, 13*0Sstevel@tonic-gate * two small shallow pans, the smaller fitting into the larger; inside them a 14*0Sstevel@tonic-gate * wooden spoon, a short two-pronged fork and some skewers were stowed; and 15*0Sstevel@tonic-gate * hidden at the bottom of the pack in a flat wooden box a dwindling treasure, 16*0Sstevel@tonic-gate * some salt. 17*0Sstevel@tonic-gate */ 18*0Sstevel@tonic-gate 19*0Sstevel@tonic-gate #include "EXTERN.h" 20*0Sstevel@tonic-gate #define PERL_IN_PP_PACK_C 21*0Sstevel@tonic-gate #include "perl.h" 22*0Sstevel@tonic-gate 23*0Sstevel@tonic-gate /* 24*0Sstevel@tonic-gate * The compiler on Concurrent CX/UX systems has a subtle bug which only 25*0Sstevel@tonic-gate * seems to show up when compiling pp.c - it generates the wrong double 26*0Sstevel@tonic-gate * precision constant value for (double)UV_MAX when used inline in the body 27*0Sstevel@tonic-gate * of the code below, so this makes a static variable up front (which the 28*0Sstevel@tonic-gate * compiler seems to get correct) and uses it in place of UV_MAX below. 29*0Sstevel@tonic-gate */ 30*0Sstevel@tonic-gate #ifdef CXUX_BROKEN_CONSTANT_CONVERT 31*0Sstevel@tonic-gate static double UV_MAX_cxux = ((double)UV_MAX); 32*0Sstevel@tonic-gate #endif 33*0Sstevel@tonic-gate 34*0Sstevel@tonic-gate /* 35*0Sstevel@tonic-gate * Offset for integer pack/unpack. 36*0Sstevel@tonic-gate * 37*0Sstevel@tonic-gate * On architectures where I16 and I32 aren't really 16 and 32 bits, 38*0Sstevel@tonic-gate * which for now are all Crays, pack and unpack have to play games. 39*0Sstevel@tonic-gate */ 40*0Sstevel@tonic-gate 41*0Sstevel@tonic-gate /* 42*0Sstevel@tonic-gate * These values are required for portability of pack() output. 43*0Sstevel@tonic-gate * If they're not right on your machine, then pack() and unpack() 44*0Sstevel@tonic-gate * wouldn't work right anyway; you'll need to apply the Cray hack. 45*0Sstevel@tonic-gate * (I'd like to check them with #if, but you can't use sizeof() in 46*0Sstevel@tonic-gate * the preprocessor.) --??? 47*0Sstevel@tonic-gate */ 48*0Sstevel@tonic-gate /* 49*0Sstevel@tonic-gate The appropriate SHORTSIZE, INTSIZE, LONGSIZE, and LONGLONGSIZE 50*0Sstevel@tonic-gate defines are now in config.h. --Andy Dougherty April 1998 51*0Sstevel@tonic-gate */ 52*0Sstevel@tonic-gate #define SIZE16 2 53*0Sstevel@tonic-gate #define SIZE32 4 54*0Sstevel@tonic-gate 55*0Sstevel@tonic-gate /* CROSSCOMPILE and MULTIARCH are going to affect pp_pack() and pp_unpack(). 56*0Sstevel@tonic-gate --jhi Feb 1999 */ 57*0Sstevel@tonic-gate 58*0Sstevel@tonic-gate #if SHORTSIZE != SIZE16 || LONGSIZE != SIZE32 59*0Sstevel@tonic-gate # define PERL_NATINT_PACK 60*0Sstevel@tonic-gate #endif 61*0Sstevel@tonic-gate 62*0Sstevel@tonic-gate #if LONGSIZE > 4 && defined(_CRAY) 63*0Sstevel@tonic-gate # if BYTEORDER == 0x12345678 64*0Sstevel@tonic-gate # define OFF16(p) (char*)(p) 65*0Sstevel@tonic-gate # define OFF32(p) (char*)(p) 66*0Sstevel@tonic-gate # else 67*0Sstevel@tonic-gate # if BYTEORDER == 0x87654321 68*0Sstevel@tonic-gate # define OFF16(p) ((char*)(p) + (sizeof(U16) - SIZE16)) 69*0Sstevel@tonic-gate # define OFF32(p) ((char*)(p) + (sizeof(U32) - SIZE32)) 70*0Sstevel@tonic-gate # else 71*0Sstevel@tonic-gate }}}} bad cray byte order 72*0Sstevel@tonic-gate # endif 73*0Sstevel@tonic-gate # endif 74*0Sstevel@tonic-gate # define COPY16(s,p) (*(p) = 0, Copy(s, OFF16(p), SIZE16, char)) 75*0Sstevel@tonic-gate # define COPY32(s,p) (*(p) = 0, Copy(s, OFF32(p), SIZE32, char)) 76*0Sstevel@tonic-gate # define COPYNN(s,p,n) (*(p) = 0, Copy(s, (char *)(p), n, char)) 77*0Sstevel@tonic-gate # define CAT16(sv,p) sv_catpvn(sv, OFF16(p), SIZE16) 78*0Sstevel@tonic-gate # define CAT32(sv,p) sv_catpvn(sv, OFF32(p), SIZE32) 79*0Sstevel@tonic-gate #else 80*0Sstevel@tonic-gate # define COPY16(s,p) Copy(s, p, SIZE16, char) 81*0Sstevel@tonic-gate # define COPY32(s,p) Copy(s, p, SIZE32, char) 82*0Sstevel@tonic-gate # define COPYNN(s,p,n) Copy(s, (char *)(p), n, char) 83*0Sstevel@tonic-gate # define CAT16(sv,p) sv_catpvn(sv, (char*)(p), SIZE16) 84*0Sstevel@tonic-gate # define CAT32(sv,p) sv_catpvn(sv, (char*)(p), SIZE32) 85*0Sstevel@tonic-gate #endif 86*0Sstevel@tonic-gate 87*0Sstevel@tonic-gate /* Avoid stack overflow due to pathological templates. 100 should be plenty. */ 88*0Sstevel@tonic-gate #define MAX_SUB_TEMPLATE_LEVEL 100 89*0Sstevel@tonic-gate 90*0Sstevel@tonic-gate /* flags */ 91*0Sstevel@tonic-gate #define FLAG_UNPACK_ONLY_ONE 0x10 92*0Sstevel@tonic-gate #define FLAG_UNPACK_DO_UTF8 0x08 93*0Sstevel@tonic-gate #define FLAG_SLASH 0x04 94*0Sstevel@tonic-gate #define FLAG_COMMA 0x02 95*0Sstevel@tonic-gate #define FLAG_PACK 0x01 96*0Sstevel@tonic-gate 97*0Sstevel@tonic-gate STATIC SV * 98*0Sstevel@tonic-gate S_mul128(pTHX_ SV *sv, U8 m) 99*0Sstevel@tonic-gate { 100*0Sstevel@tonic-gate STRLEN len; 101*0Sstevel@tonic-gate char *s = SvPV(sv, len); 102*0Sstevel@tonic-gate char *t; 103*0Sstevel@tonic-gate U32 i = 0; 104*0Sstevel@tonic-gate 105*0Sstevel@tonic-gate if (!strnEQ(s, "0000", 4)) { /* need to grow sv */ 106*0Sstevel@tonic-gate SV *tmpNew = newSVpvn("0000000000", 10); 107*0Sstevel@tonic-gate 108*0Sstevel@tonic-gate sv_catsv(tmpNew, sv); 109*0Sstevel@tonic-gate SvREFCNT_dec(sv); /* free old sv */ 110*0Sstevel@tonic-gate sv = tmpNew; 111*0Sstevel@tonic-gate s = SvPV(sv, len); 112*0Sstevel@tonic-gate } 113*0Sstevel@tonic-gate t = s + len - 1; 114*0Sstevel@tonic-gate while (!*t) /* trailing '\0'? */ 115*0Sstevel@tonic-gate t--; 116*0Sstevel@tonic-gate while (t > s) { 117*0Sstevel@tonic-gate i = ((*t - '0') << 7) + m; 118*0Sstevel@tonic-gate *(t--) = '0' + (char)(i % 10); 119*0Sstevel@tonic-gate m = (char)(i / 10); 120*0Sstevel@tonic-gate } 121*0Sstevel@tonic-gate return (sv); 122*0Sstevel@tonic-gate } 123*0Sstevel@tonic-gate 124*0Sstevel@tonic-gate /* Explosives and implosives. */ 125*0Sstevel@tonic-gate 126*0Sstevel@tonic-gate #if 'I' == 73 && 'J' == 74 127*0Sstevel@tonic-gate /* On an ASCII/ISO kind of system */ 128*0Sstevel@tonic-gate #define ISUUCHAR(ch) ((ch) >= ' ' && (ch) < 'a') 129*0Sstevel@tonic-gate #else 130*0Sstevel@tonic-gate /* 131*0Sstevel@tonic-gate Some other sort of character set - use memchr() so we don't match 132*0Sstevel@tonic-gate the null byte. 133*0Sstevel@tonic-gate */ 134*0Sstevel@tonic-gate #define ISUUCHAR(ch) (memchr(PL_uuemap, (ch), sizeof(PL_uuemap)-1) || (ch) == ' ') 135*0Sstevel@tonic-gate #endif 136*0Sstevel@tonic-gate 137*0Sstevel@tonic-gate #define TYPE_IS_SHRIEKING 0x100 138*0Sstevel@tonic-gate 139*0Sstevel@tonic-gate /* Returns the sizeof() struct described by pat */ 140*0Sstevel@tonic-gate STATIC I32 141*0Sstevel@tonic-gate S_measure_struct(pTHX_ register tempsym_t* symptr) 142*0Sstevel@tonic-gate { 143*0Sstevel@tonic-gate register I32 len = 0; 144*0Sstevel@tonic-gate register I32 total = 0; 145*0Sstevel@tonic-gate int star; 146*0Sstevel@tonic-gate 147*0Sstevel@tonic-gate register int size; 148*0Sstevel@tonic-gate 149*0Sstevel@tonic-gate while (next_symbol(symptr)) { 150*0Sstevel@tonic-gate 151*0Sstevel@tonic-gate switch( symptr->howlen ){ 152*0Sstevel@tonic-gate case e_no_len: 153*0Sstevel@tonic-gate case e_number: 154*0Sstevel@tonic-gate len = symptr->length; 155*0Sstevel@tonic-gate break; 156*0Sstevel@tonic-gate case e_star: 157*0Sstevel@tonic-gate Perl_croak(aTHX_ "Within []-length '*' not allowed in %s", 158*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 159*0Sstevel@tonic-gate break; 160*0Sstevel@tonic-gate } 161*0Sstevel@tonic-gate 162*0Sstevel@tonic-gate switch(symptr->code) { 163*0Sstevel@tonic-gate default: 164*0Sstevel@tonic-gate Perl_croak(aTHX_ "Invalid type '%c' in %s", 165*0Sstevel@tonic-gate (int)symptr->code, 166*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 167*0Sstevel@tonic-gate case '@': 168*0Sstevel@tonic-gate case '/': 169*0Sstevel@tonic-gate case 'U': /* XXXX Is it correct? */ 170*0Sstevel@tonic-gate case 'w': 171*0Sstevel@tonic-gate case 'u': 172*0Sstevel@tonic-gate Perl_croak(aTHX_ "Within []-length '%c' not allowed in %s", 173*0Sstevel@tonic-gate (int)symptr->code, 174*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 175*0Sstevel@tonic-gate case '%': 176*0Sstevel@tonic-gate size = 0; 177*0Sstevel@tonic-gate break; 178*0Sstevel@tonic-gate case '(': 179*0Sstevel@tonic-gate { 180*0Sstevel@tonic-gate tempsym_t savsym = *symptr; 181*0Sstevel@tonic-gate symptr->patptr = savsym.grpbeg; 182*0Sstevel@tonic-gate symptr->patend = savsym.grpend; 183*0Sstevel@tonic-gate /* XXXX Theoretically, we need to measure many times at different 184*0Sstevel@tonic-gate positions, since the subexpression may contain 185*0Sstevel@tonic-gate alignment commands, but be not of aligned length. 186*0Sstevel@tonic-gate Need to detect this and croak(). */ 187*0Sstevel@tonic-gate size = measure_struct(symptr); 188*0Sstevel@tonic-gate *symptr = savsym; 189*0Sstevel@tonic-gate break; 190*0Sstevel@tonic-gate } 191*0Sstevel@tonic-gate case 'X' | TYPE_IS_SHRIEKING: 192*0Sstevel@tonic-gate /* XXXX Is this useful? Then need to treat MEASURE_BACKWARDS. */ 193*0Sstevel@tonic-gate if (!len) /* Avoid division by 0 */ 194*0Sstevel@tonic-gate len = 1; 195*0Sstevel@tonic-gate len = total % len; /* Assumed: the start is aligned. */ 196*0Sstevel@tonic-gate /* FALL THROUGH */ 197*0Sstevel@tonic-gate case 'X': 198*0Sstevel@tonic-gate size = -1; 199*0Sstevel@tonic-gate if (total < len) 200*0Sstevel@tonic-gate Perl_croak(aTHX_ "'X' outside of string in %s", 201*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 202*0Sstevel@tonic-gate break; 203*0Sstevel@tonic-gate case 'x' | TYPE_IS_SHRIEKING: 204*0Sstevel@tonic-gate if (!len) /* Avoid division by 0 */ 205*0Sstevel@tonic-gate len = 1; 206*0Sstevel@tonic-gate star = total % len; /* Assumed: the start is aligned. */ 207*0Sstevel@tonic-gate if (star) /* Other portable ways? */ 208*0Sstevel@tonic-gate len = len - star; 209*0Sstevel@tonic-gate else 210*0Sstevel@tonic-gate len = 0; 211*0Sstevel@tonic-gate /* FALL THROUGH */ 212*0Sstevel@tonic-gate case 'x': 213*0Sstevel@tonic-gate case 'A': 214*0Sstevel@tonic-gate case 'Z': 215*0Sstevel@tonic-gate case 'a': 216*0Sstevel@tonic-gate case 'c': 217*0Sstevel@tonic-gate case 'C': 218*0Sstevel@tonic-gate size = 1; 219*0Sstevel@tonic-gate break; 220*0Sstevel@tonic-gate case 'B': 221*0Sstevel@tonic-gate case 'b': 222*0Sstevel@tonic-gate len = (len + 7)/8; 223*0Sstevel@tonic-gate size = 1; 224*0Sstevel@tonic-gate break; 225*0Sstevel@tonic-gate case 'H': 226*0Sstevel@tonic-gate case 'h': 227*0Sstevel@tonic-gate len = (len + 1)/2; 228*0Sstevel@tonic-gate size = 1; 229*0Sstevel@tonic-gate break; 230*0Sstevel@tonic-gate case 's' | TYPE_IS_SHRIEKING: 231*0Sstevel@tonic-gate #if SHORTSIZE != SIZE16 232*0Sstevel@tonic-gate size = sizeof(short); 233*0Sstevel@tonic-gate break; 234*0Sstevel@tonic-gate #else 235*0Sstevel@tonic-gate /* FALL THROUGH */ 236*0Sstevel@tonic-gate #endif 237*0Sstevel@tonic-gate case 's': 238*0Sstevel@tonic-gate size = SIZE16; 239*0Sstevel@tonic-gate break; 240*0Sstevel@tonic-gate case 'S' | TYPE_IS_SHRIEKING: 241*0Sstevel@tonic-gate #if SHORTSIZE != SIZE16 242*0Sstevel@tonic-gate size = sizeof(unsigned short); 243*0Sstevel@tonic-gate break; 244*0Sstevel@tonic-gate #else 245*0Sstevel@tonic-gate /* FALL THROUGH */ 246*0Sstevel@tonic-gate #endif 247*0Sstevel@tonic-gate case 'v': 248*0Sstevel@tonic-gate case 'n': 249*0Sstevel@tonic-gate case 'S': 250*0Sstevel@tonic-gate size = SIZE16; 251*0Sstevel@tonic-gate break; 252*0Sstevel@tonic-gate case 'i' | TYPE_IS_SHRIEKING: 253*0Sstevel@tonic-gate case 'i': 254*0Sstevel@tonic-gate size = sizeof(int); 255*0Sstevel@tonic-gate break; 256*0Sstevel@tonic-gate case 'I' | TYPE_IS_SHRIEKING: 257*0Sstevel@tonic-gate case 'I': 258*0Sstevel@tonic-gate size = sizeof(unsigned int); 259*0Sstevel@tonic-gate break; 260*0Sstevel@tonic-gate case 'j': 261*0Sstevel@tonic-gate size = IVSIZE; 262*0Sstevel@tonic-gate break; 263*0Sstevel@tonic-gate case 'J': 264*0Sstevel@tonic-gate size = UVSIZE; 265*0Sstevel@tonic-gate break; 266*0Sstevel@tonic-gate case 'l' | TYPE_IS_SHRIEKING: 267*0Sstevel@tonic-gate #if LONGSIZE != SIZE32 268*0Sstevel@tonic-gate size = sizeof(long); 269*0Sstevel@tonic-gate break; 270*0Sstevel@tonic-gate #else 271*0Sstevel@tonic-gate /* FALL THROUGH */ 272*0Sstevel@tonic-gate #endif 273*0Sstevel@tonic-gate case 'l': 274*0Sstevel@tonic-gate size = SIZE32; 275*0Sstevel@tonic-gate break; 276*0Sstevel@tonic-gate case 'L' | TYPE_IS_SHRIEKING: 277*0Sstevel@tonic-gate #if LONGSIZE != SIZE32 278*0Sstevel@tonic-gate size = sizeof(unsigned long); 279*0Sstevel@tonic-gate break; 280*0Sstevel@tonic-gate #else 281*0Sstevel@tonic-gate /* FALL THROUGH */ 282*0Sstevel@tonic-gate #endif 283*0Sstevel@tonic-gate case 'V': 284*0Sstevel@tonic-gate case 'N': 285*0Sstevel@tonic-gate case 'L': 286*0Sstevel@tonic-gate size = SIZE32; 287*0Sstevel@tonic-gate break; 288*0Sstevel@tonic-gate case 'P': 289*0Sstevel@tonic-gate len = 1; 290*0Sstevel@tonic-gate /* FALL THROUGH */ 291*0Sstevel@tonic-gate case 'p': 292*0Sstevel@tonic-gate size = sizeof(char*); 293*0Sstevel@tonic-gate break; 294*0Sstevel@tonic-gate #ifdef HAS_QUAD 295*0Sstevel@tonic-gate case 'q': 296*0Sstevel@tonic-gate size = sizeof(Quad_t); 297*0Sstevel@tonic-gate break; 298*0Sstevel@tonic-gate case 'Q': 299*0Sstevel@tonic-gate size = sizeof(Uquad_t); 300*0Sstevel@tonic-gate break; 301*0Sstevel@tonic-gate #endif 302*0Sstevel@tonic-gate case 'f': 303*0Sstevel@tonic-gate size = sizeof(float); 304*0Sstevel@tonic-gate break; 305*0Sstevel@tonic-gate case 'd': 306*0Sstevel@tonic-gate size = sizeof(double); 307*0Sstevel@tonic-gate break; 308*0Sstevel@tonic-gate case 'F': 309*0Sstevel@tonic-gate size = NVSIZE; 310*0Sstevel@tonic-gate break; 311*0Sstevel@tonic-gate #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 312*0Sstevel@tonic-gate case 'D': 313*0Sstevel@tonic-gate size = LONG_DOUBLESIZE; 314*0Sstevel@tonic-gate break; 315*0Sstevel@tonic-gate #endif 316*0Sstevel@tonic-gate } 317*0Sstevel@tonic-gate total += len * size; 318*0Sstevel@tonic-gate } 319*0Sstevel@tonic-gate return total; 320*0Sstevel@tonic-gate } 321*0Sstevel@tonic-gate 322*0Sstevel@tonic-gate 323*0Sstevel@tonic-gate /* locate matching closing parenthesis or bracket 324*0Sstevel@tonic-gate * returns char pointer to char after match, or NULL 325*0Sstevel@tonic-gate */ 326*0Sstevel@tonic-gate STATIC char * 327*0Sstevel@tonic-gate S_group_end(pTHX_ register char *patptr, register char *patend, char ender) 328*0Sstevel@tonic-gate { 329*0Sstevel@tonic-gate while (patptr < patend) { 330*0Sstevel@tonic-gate char c = *patptr++; 331*0Sstevel@tonic-gate 332*0Sstevel@tonic-gate if (isSPACE(c)) 333*0Sstevel@tonic-gate continue; 334*0Sstevel@tonic-gate else if (c == ender) 335*0Sstevel@tonic-gate return patptr-1; 336*0Sstevel@tonic-gate else if (c == '#') { 337*0Sstevel@tonic-gate while (patptr < patend && *patptr != '\n') 338*0Sstevel@tonic-gate patptr++; 339*0Sstevel@tonic-gate continue; 340*0Sstevel@tonic-gate } else if (c == '(') 341*0Sstevel@tonic-gate patptr = group_end(patptr, patend, ')') + 1; 342*0Sstevel@tonic-gate else if (c == '[') 343*0Sstevel@tonic-gate patptr = group_end(patptr, patend, ']') + 1; 344*0Sstevel@tonic-gate } 345*0Sstevel@tonic-gate Perl_croak(aTHX_ "No group ending character '%c' found in template", 346*0Sstevel@tonic-gate ender); 347*0Sstevel@tonic-gate return 0; 348*0Sstevel@tonic-gate } 349*0Sstevel@tonic-gate 350*0Sstevel@tonic-gate 351*0Sstevel@tonic-gate /* Convert unsigned decimal number to binary. 352*0Sstevel@tonic-gate * Expects a pointer to the first digit and address of length variable 353*0Sstevel@tonic-gate * Advances char pointer to 1st non-digit char and returns number 354*0Sstevel@tonic-gate */ 355*0Sstevel@tonic-gate STATIC char * 356*0Sstevel@tonic-gate S_get_num(pTHX_ register char *patptr, I32 *lenptr ) 357*0Sstevel@tonic-gate { 358*0Sstevel@tonic-gate I32 len = *patptr++ - '0'; 359*0Sstevel@tonic-gate while (isDIGIT(*patptr)) { 360*0Sstevel@tonic-gate if (len >= 0x7FFFFFFF/10) 361*0Sstevel@tonic-gate Perl_croak(aTHX_ "pack/unpack repeat count overflow"); 362*0Sstevel@tonic-gate len = (len * 10) + (*patptr++ - '0'); 363*0Sstevel@tonic-gate } 364*0Sstevel@tonic-gate *lenptr = len; 365*0Sstevel@tonic-gate return patptr; 366*0Sstevel@tonic-gate } 367*0Sstevel@tonic-gate 368*0Sstevel@tonic-gate /* The marvellous template parsing routine: Using state stored in *symptr, 369*0Sstevel@tonic-gate * locates next template code and count 370*0Sstevel@tonic-gate */ 371*0Sstevel@tonic-gate STATIC bool 372*0Sstevel@tonic-gate S_next_symbol(pTHX_ register tempsym_t* symptr ) 373*0Sstevel@tonic-gate { 374*0Sstevel@tonic-gate register char* patptr = symptr->patptr; 375*0Sstevel@tonic-gate register char* patend = symptr->patend; 376*0Sstevel@tonic-gate 377*0Sstevel@tonic-gate symptr->flags &= ~FLAG_SLASH; 378*0Sstevel@tonic-gate 379*0Sstevel@tonic-gate while (patptr < patend) { 380*0Sstevel@tonic-gate if (isSPACE(*patptr)) 381*0Sstevel@tonic-gate patptr++; 382*0Sstevel@tonic-gate else if (*patptr == '#') { 383*0Sstevel@tonic-gate patptr++; 384*0Sstevel@tonic-gate while (patptr < patend && *patptr != '\n') 385*0Sstevel@tonic-gate patptr++; 386*0Sstevel@tonic-gate if (patptr < patend) 387*0Sstevel@tonic-gate patptr++; 388*0Sstevel@tonic-gate } else { 389*0Sstevel@tonic-gate /* We should have found a template code */ 390*0Sstevel@tonic-gate I32 code = *patptr++ & 0xFF; 391*0Sstevel@tonic-gate 392*0Sstevel@tonic-gate if (code == ','){ /* grandfather in commas but with a warning */ 393*0Sstevel@tonic-gate if (((symptr->flags & FLAG_COMMA) == 0) && ckWARN(WARN_UNPACK)){ 394*0Sstevel@tonic-gate symptr->flags |= FLAG_COMMA; 395*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_UNPACK), 396*0Sstevel@tonic-gate "Invalid type ',' in %s", 397*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 398*0Sstevel@tonic-gate } 399*0Sstevel@tonic-gate continue; 400*0Sstevel@tonic-gate } 401*0Sstevel@tonic-gate 402*0Sstevel@tonic-gate /* for '(', skip to ')' */ 403*0Sstevel@tonic-gate if (code == '(') { 404*0Sstevel@tonic-gate if( isDIGIT(*patptr) || *patptr == '*' || *patptr == '[' ) 405*0Sstevel@tonic-gate Perl_croak(aTHX_ "()-group starts with a count in %s", 406*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 407*0Sstevel@tonic-gate symptr->grpbeg = patptr; 408*0Sstevel@tonic-gate patptr = 1 + ( symptr->grpend = group_end(patptr, patend, ')') ); 409*0Sstevel@tonic-gate if( symptr->level >= MAX_SUB_TEMPLATE_LEVEL ) 410*0Sstevel@tonic-gate Perl_croak(aTHX_ "Too deeply nested ()-groups in %s", 411*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 412*0Sstevel@tonic-gate } 413*0Sstevel@tonic-gate 414*0Sstevel@tonic-gate /* test for '!' modifier */ 415*0Sstevel@tonic-gate if (patptr < patend && *patptr == '!') { 416*0Sstevel@tonic-gate static const char natstr[] = "sSiIlLxX"; 417*0Sstevel@tonic-gate patptr++; 418*0Sstevel@tonic-gate if (strchr(natstr, code)) 419*0Sstevel@tonic-gate code |= TYPE_IS_SHRIEKING; 420*0Sstevel@tonic-gate else 421*0Sstevel@tonic-gate Perl_croak(aTHX_ "'!' allowed only after types %s in %s", 422*0Sstevel@tonic-gate natstr, symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 423*0Sstevel@tonic-gate } 424*0Sstevel@tonic-gate 425*0Sstevel@tonic-gate /* look for count and/or / */ 426*0Sstevel@tonic-gate if (patptr < patend) { 427*0Sstevel@tonic-gate if (isDIGIT(*patptr)) { 428*0Sstevel@tonic-gate patptr = get_num( patptr, &symptr->length ); 429*0Sstevel@tonic-gate symptr->howlen = e_number; 430*0Sstevel@tonic-gate 431*0Sstevel@tonic-gate } else if (*patptr == '*') { 432*0Sstevel@tonic-gate patptr++; 433*0Sstevel@tonic-gate symptr->howlen = e_star; 434*0Sstevel@tonic-gate 435*0Sstevel@tonic-gate } else if (*patptr == '[') { 436*0Sstevel@tonic-gate char* lenptr = ++patptr; 437*0Sstevel@tonic-gate symptr->howlen = e_number; 438*0Sstevel@tonic-gate patptr = group_end( patptr, patend, ']' ) + 1; 439*0Sstevel@tonic-gate /* what kind of [] is it? */ 440*0Sstevel@tonic-gate if (isDIGIT(*lenptr)) { 441*0Sstevel@tonic-gate lenptr = get_num( lenptr, &symptr->length ); 442*0Sstevel@tonic-gate if( *lenptr != ']' ) 443*0Sstevel@tonic-gate Perl_croak(aTHX_ "Malformed integer in [] in %s", 444*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack"); 445*0Sstevel@tonic-gate } else { 446*0Sstevel@tonic-gate tempsym_t savsym = *symptr; 447*0Sstevel@tonic-gate symptr->patend = patptr-1; 448*0Sstevel@tonic-gate symptr->patptr = lenptr; 449*0Sstevel@tonic-gate savsym.length = measure_struct(symptr); 450*0Sstevel@tonic-gate *symptr = savsym; 451*0Sstevel@tonic-gate } 452*0Sstevel@tonic-gate } else { 453*0Sstevel@tonic-gate symptr->howlen = e_no_len; 454*0Sstevel@tonic-gate symptr->length = 1; 455*0Sstevel@tonic-gate } 456*0Sstevel@tonic-gate 457*0Sstevel@tonic-gate /* try to find / */ 458*0Sstevel@tonic-gate while (patptr < patend) { 459*0Sstevel@tonic-gate if (isSPACE(*patptr)) 460*0Sstevel@tonic-gate patptr++; 461*0Sstevel@tonic-gate else if (*patptr == '#') { 462*0Sstevel@tonic-gate patptr++; 463*0Sstevel@tonic-gate while (patptr < patend && *patptr != '\n') 464*0Sstevel@tonic-gate patptr++; 465*0Sstevel@tonic-gate if (patptr < patend) 466*0Sstevel@tonic-gate patptr++; 467*0Sstevel@tonic-gate } else { 468*0Sstevel@tonic-gate if( *patptr == '/' ){ 469*0Sstevel@tonic-gate symptr->flags |= FLAG_SLASH; 470*0Sstevel@tonic-gate patptr++; 471*0Sstevel@tonic-gate if( patptr < patend && 472*0Sstevel@tonic-gate (isDIGIT(*patptr) || *patptr == '*' || *patptr == '[') ) 473*0Sstevel@tonic-gate Perl_croak(aTHX_ "'/' does not take a repeat count in %s", 474*0Sstevel@tonic-gate symptr->flags & FLAG_PACK ? "pack" : "unpack" ); 475*0Sstevel@tonic-gate } 476*0Sstevel@tonic-gate break; 477*0Sstevel@tonic-gate } 478*0Sstevel@tonic-gate } 479*0Sstevel@tonic-gate } else { 480*0Sstevel@tonic-gate /* at end - no count, no / */ 481*0Sstevel@tonic-gate symptr->howlen = e_no_len; 482*0Sstevel@tonic-gate symptr->length = 1; 483*0Sstevel@tonic-gate } 484*0Sstevel@tonic-gate 485*0Sstevel@tonic-gate symptr->code = code; 486*0Sstevel@tonic-gate symptr->patptr = patptr; 487*0Sstevel@tonic-gate return TRUE; 488*0Sstevel@tonic-gate } 489*0Sstevel@tonic-gate } 490*0Sstevel@tonic-gate symptr->patptr = patptr; 491*0Sstevel@tonic-gate return FALSE; 492*0Sstevel@tonic-gate } 493*0Sstevel@tonic-gate 494*0Sstevel@tonic-gate /* 495*0Sstevel@tonic-gate =for apidoc unpack_str 496*0Sstevel@tonic-gate 497*0Sstevel@tonic-gate The engine implementing unpack() Perl function. Note: parameters strbeg, new_s 498*0Sstevel@tonic-gate and ocnt are not used. This call should not be used, use unpackstring instead. 499*0Sstevel@tonic-gate 500*0Sstevel@tonic-gate =cut */ 501*0Sstevel@tonic-gate 502*0Sstevel@tonic-gate I32 503*0Sstevel@tonic-gate Perl_unpack_str(pTHX_ char *pat, register char *patend, register char *s, char *strbeg, char *strend, char **new_s, I32 ocnt, U32 flags) 504*0Sstevel@tonic-gate { 505*0Sstevel@tonic-gate tempsym_t sym = { 0 }; 506*0Sstevel@tonic-gate sym.patptr = pat; 507*0Sstevel@tonic-gate sym.patend = patend; 508*0Sstevel@tonic-gate sym.flags = flags; 509*0Sstevel@tonic-gate 510*0Sstevel@tonic-gate return unpack_rec(&sym, s, s, strend, NULL ); 511*0Sstevel@tonic-gate } 512*0Sstevel@tonic-gate 513*0Sstevel@tonic-gate /* 514*0Sstevel@tonic-gate =for apidoc unpackstring 515*0Sstevel@tonic-gate 516*0Sstevel@tonic-gate The engine implementing unpack() Perl function. C<unpackstring> puts the 517*0Sstevel@tonic-gate extracted list items on the stack and returns the number of elements. 518*0Sstevel@tonic-gate Issue C<PUTBACK> before and C<SPAGAIN> after the call to this function. 519*0Sstevel@tonic-gate 520*0Sstevel@tonic-gate =cut */ 521*0Sstevel@tonic-gate 522*0Sstevel@tonic-gate I32 523*0Sstevel@tonic-gate Perl_unpackstring(pTHX_ char *pat, register char *patend, register char *s, char *strend, U32 flags) 524*0Sstevel@tonic-gate { 525*0Sstevel@tonic-gate tempsym_t sym = { 0 }; 526*0Sstevel@tonic-gate sym.patptr = pat; 527*0Sstevel@tonic-gate sym.patend = patend; 528*0Sstevel@tonic-gate sym.flags = flags; 529*0Sstevel@tonic-gate 530*0Sstevel@tonic-gate return unpack_rec(&sym, s, s, strend, NULL ); 531*0Sstevel@tonic-gate } 532*0Sstevel@tonic-gate 533*0Sstevel@tonic-gate STATIC 534*0Sstevel@tonic-gate I32 535*0Sstevel@tonic-gate S_unpack_rec(pTHX_ register tempsym_t* symptr, register char *s, char *strbeg, char *strend, char **new_s ) 536*0Sstevel@tonic-gate { 537*0Sstevel@tonic-gate dSP; 538*0Sstevel@tonic-gate I32 datumtype; 539*0Sstevel@tonic-gate register I32 len = 0; 540*0Sstevel@tonic-gate register I32 bits = 0; 541*0Sstevel@tonic-gate register char *str; 542*0Sstevel@tonic-gate SV *sv; 543*0Sstevel@tonic-gate I32 start_sp_offset = SP - PL_stack_base; 544*0Sstevel@tonic-gate howlen_t howlen; 545*0Sstevel@tonic-gate 546*0Sstevel@tonic-gate /* These must not be in registers: */ 547*0Sstevel@tonic-gate short ashort; 548*0Sstevel@tonic-gate int aint; 549*0Sstevel@tonic-gate long along; 550*0Sstevel@tonic-gate #ifdef HAS_QUAD 551*0Sstevel@tonic-gate Quad_t aquad; 552*0Sstevel@tonic-gate #endif 553*0Sstevel@tonic-gate U16 aushort; 554*0Sstevel@tonic-gate unsigned int auint; 555*0Sstevel@tonic-gate U32 aulong; 556*0Sstevel@tonic-gate #ifdef HAS_QUAD 557*0Sstevel@tonic-gate Uquad_t auquad; 558*0Sstevel@tonic-gate #endif 559*0Sstevel@tonic-gate char *aptr; 560*0Sstevel@tonic-gate float afloat; 561*0Sstevel@tonic-gate double adouble; 562*0Sstevel@tonic-gate I32 checksum = 0; 563*0Sstevel@tonic-gate UV cuv = 0; 564*0Sstevel@tonic-gate NV cdouble = 0.0; 565*0Sstevel@tonic-gate const int bits_in_uv = 8 * sizeof(cuv); 566*0Sstevel@tonic-gate char* strrelbeg = s; 567*0Sstevel@tonic-gate bool beyond = FALSE; 568*0Sstevel@tonic-gate bool unpack_only_one = (symptr->flags & FLAG_UNPACK_ONLY_ONE) != 0; 569*0Sstevel@tonic-gate 570*0Sstevel@tonic-gate IV aiv; 571*0Sstevel@tonic-gate UV auv; 572*0Sstevel@tonic-gate NV anv; 573*0Sstevel@tonic-gate #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 574*0Sstevel@tonic-gate long double aldouble; 575*0Sstevel@tonic-gate #endif 576*0Sstevel@tonic-gate 577*0Sstevel@tonic-gate while (next_symbol(symptr)) { 578*0Sstevel@tonic-gate datumtype = symptr->code; 579*0Sstevel@tonic-gate /* do first one only unless in list context 580*0Sstevel@tonic-gate / is implemented by unpacking the count, then poping it from the 581*0Sstevel@tonic-gate stack, so must check that we're not in the middle of a / */ 582*0Sstevel@tonic-gate if ( unpack_only_one 583*0Sstevel@tonic-gate && (SP - PL_stack_base == start_sp_offset + 1) 584*0Sstevel@tonic-gate && (datumtype != '/') ) /* XXX can this be omitted */ 585*0Sstevel@tonic-gate break; 586*0Sstevel@tonic-gate 587*0Sstevel@tonic-gate switch( howlen = symptr->howlen ){ 588*0Sstevel@tonic-gate case e_no_len: 589*0Sstevel@tonic-gate case e_number: 590*0Sstevel@tonic-gate len = symptr->length; 591*0Sstevel@tonic-gate break; 592*0Sstevel@tonic-gate case e_star: 593*0Sstevel@tonic-gate len = strend - strbeg; /* long enough */ 594*0Sstevel@tonic-gate break; 595*0Sstevel@tonic-gate } 596*0Sstevel@tonic-gate 597*0Sstevel@tonic-gate redo_switch: 598*0Sstevel@tonic-gate beyond = s >= strend; 599*0Sstevel@tonic-gate switch(datumtype) { 600*0Sstevel@tonic-gate default: 601*0Sstevel@tonic-gate Perl_croak(aTHX_ "Invalid type '%c' in unpack", (int)datumtype ); 602*0Sstevel@tonic-gate 603*0Sstevel@tonic-gate case '%': 604*0Sstevel@tonic-gate if (howlen == e_no_len) 605*0Sstevel@tonic-gate len = 16; /* len is not specified */ 606*0Sstevel@tonic-gate checksum = len; 607*0Sstevel@tonic-gate cuv = 0; 608*0Sstevel@tonic-gate cdouble = 0; 609*0Sstevel@tonic-gate continue; 610*0Sstevel@tonic-gate break; 611*0Sstevel@tonic-gate case '(': 612*0Sstevel@tonic-gate { 613*0Sstevel@tonic-gate char *ss = s; /* Move from register */ 614*0Sstevel@tonic-gate tempsym_t savsym = *symptr; 615*0Sstevel@tonic-gate symptr->patend = savsym.grpend; 616*0Sstevel@tonic-gate symptr->level++; 617*0Sstevel@tonic-gate PUTBACK; 618*0Sstevel@tonic-gate while (len--) { 619*0Sstevel@tonic-gate symptr->patptr = savsym.grpbeg; 620*0Sstevel@tonic-gate unpack_rec(symptr, ss, strbeg, strend, &ss ); 621*0Sstevel@tonic-gate if (ss == strend && savsym.howlen == e_star) 622*0Sstevel@tonic-gate break; /* No way to continue */ 623*0Sstevel@tonic-gate } 624*0Sstevel@tonic-gate SPAGAIN; 625*0Sstevel@tonic-gate s = ss; 626*0Sstevel@tonic-gate savsym.flags = symptr->flags; 627*0Sstevel@tonic-gate *symptr = savsym; 628*0Sstevel@tonic-gate break; 629*0Sstevel@tonic-gate } 630*0Sstevel@tonic-gate case '@': 631*0Sstevel@tonic-gate if (len > strend - strrelbeg) 632*0Sstevel@tonic-gate Perl_croak(aTHX_ "'@' outside of string in unpack"); 633*0Sstevel@tonic-gate s = strrelbeg + len; 634*0Sstevel@tonic-gate break; 635*0Sstevel@tonic-gate case 'X' | TYPE_IS_SHRIEKING: 636*0Sstevel@tonic-gate if (!len) /* Avoid division by 0 */ 637*0Sstevel@tonic-gate len = 1; 638*0Sstevel@tonic-gate len = (s - strbeg) % len; 639*0Sstevel@tonic-gate /* FALL THROUGH */ 640*0Sstevel@tonic-gate case 'X': 641*0Sstevel@tonic-gate if (len > s - strbeg) 642*0Sstevel@tonic-gate Perl_croak(aTHX_ "'X' outside of string in unpack" ); 643*0Sstevel@tonic-gate s -= len; 644*0Sstevel@tonic-gate break; 645*0Sstevel@tonic-gate case 'x' | TYPE_IS_SHRIEKING: 646*0Sstevel@tonic-gate if (!len) /* Avoid division by 0 */ 647*0Sstevel@tonic-gate len = 1; 648*0Sstevel@tonic-gate aint = (s - strbeg) % len; 649*0Sstevel@tonic-gate if (aint) /* Other portable ways? */ 650*0Sstevel@tonic-gate len = len - aint; 651*0Sstevel@tonic-gate else 652*0Sstevel@tonic-gate len = 0; 653*0Sstevel@tonic-gate /* FALL THROUGH */ 654*0Sstevel@tonic-gate case 'x': 655*0Sstevel@tonic-gate if (len > strend - s) 656*0Sstevel@tonic-gate Perl_croak(aTHX_ "'x' outside of string in unpack"); 657*0Sstevel@tonic-gate s += len; 658*0Sstevel@tonic-gate break; 659*0Sstevel@tonic-gate case '/': 660*0Sstevel@tonic-gate Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); 661*0Sstevel@tonic-gate break; 662*0Sstevel@tonic-gate case 'A': 663*0Sstevel@tonic-gate case 'Z': 664*0Sstevel@tonic-gate case 'a': 665*0Sstevel@tonic-gate if (len > strend - s) 666*0Sstevel@tonic-gate len = strend - s; 667*0Sstevel@tonic-gate if (checksum) 668*0Sstevel@tonic-gate goto uchar_checksum; 669*0Sstevel@tonic-gate sv = NEWSV(35, len); 670*0Sstevel@tonic-gate sv_setpvn(sv, s, len); 671*0Sstevel@tonic-gate if (len > 0 && (datumtype == 'A' || datumtype == 'Z')) { 672*0Sstevel@tonic-gate aptr = s; /* borrow register */ 673*0Sstevel@tonic-gate if (datumtype == 'Z') { /* 'Z' strips stuff after first null */ 674*0Sstevel@tonic-gate s = SvPVX(sv); 675*0Sstevel@tonic-gate while (*s) 676*0Sstevel@tonic-gate s++; 677*0Sstevel@tonic-gate if (howlen == e_star) /* exact for 'Z*' */ 678*0Sstevel@tonic-gate len = s - SvPVX(sv) + 1; 679*0Sstevel@tonic-gate } 680*0Sstevel@tonic-gate else { /* 'A' strips both nulls and spaces */ 681*0Sstevel@tonic-gate s = SvPVX(sv) + len - 1; 682*0Sstevel@tonic-gate while (s >= SvPVX(sv) && (!*s || isSPACE(*s))) 683*0Sstevel@tonic-gate s--; 684*0Sstevel@tonic-gate *++s = '\0'; 685*0Sstevel@tonic-gate } 686*0Sstevel@tonic-gate SvCUR_set(sv, s - SvPVX(sv)); 687*0Sstevel@tonic-gate s = aptr; /* unborrow register */ 688*0Sstevel@tonic-gate } 689*0Sstevel@tonic-gate s += len; 690*0Sstevel@tonic-gate XPUSHs(sv_2mortal(sv)); 691*0Sstevel@tonic-gate break; 692*0Sstevel@tonic-gate case 'B': 693*0Sstevel@tonic-gate case 'b': 694*0Sstevel@tonic-gate if (howlen == e_star || len > (strend - s) * 8) 695*0Sstevel@tonic-gate len = (strend - s) * 8; 696*0Sstevel@tonic-gate if (checksum) { 697*0Sstevel@tonic-gate if (!PL_bitcount) { 698*0Sstevel@tonic-gate Newz(601, PL_bitcount, 256, char); 699*0Sstevel@tonic-gate for (bits = 1; bits < 256; bits++) { 700*0Sstevel@tonic-gate if (bits & 1) PL_bitcount[bits]++; 701*0Sstevel@tonic-gate if (bits & 2) PL_bitcount[bits]++; 702*0Sstevel@tonic-gate if (bits & 4) PL_bitcount[bits]++; 703*0Sstevel@tonic-gate if (bits & 8) PL_bitcount[bits]++; 704*0Sstevel@tonic-gate if (bits & 16) PL_bitcount[bits]++; 705*0Sstevel@tonic-gate if (bits & 32) PL_bitcount[bits]++; 706*0Sstevel@tonic-gate if (bits & 64) PL_bitcount[bits]++; 707*0Sstevel@tonic-gate if (bits & 128) PL_bitcount[bits]++; 708*0Sstevel@tonic-gate } 709*0Sstevel@tonic-gate } 710*0Sstevel@tonic-gate while (len >= 8) { 711*0Sstevel@tonic-gate cuv += PL_bitcount[*(unsigned char*)s++]; 712*0Sstevel@tonic-gate len -= 8; 713*0Sstevel@tonic-gate } 714*0Sstevel@tonic-gate if (len) { 715*0Sstevel@tonic-gate bits = *s; 716*0Sstevel@tonic-gate if (datumtype == 'b') { 717*0Sstevel@tonic-gate while (len-- > 0) { 718*0Sstevel@tonic-gate if (bits & 1) cuv++; 719*0Sstevel@tonic-gate bits >>= 1; 720*0Sstevel@tonic-gate } 721*0Sstevel@tonic-gate } 722*0Sstevel@tonic-gate else { 723*0Sstevel@tonic-gate while (len-- > 0) { 724*0Sstevel@tonic-gate if (bits & 128) cuv++; 725*0Sstevel@tonic-gate bits <<= 1; 726*0Sstevel@tonic-gate } 727*0Sstevel@tonic-gate } 728*0Sstevel@tonic-gate } 729*0Sstevel@tonic-gate break; 730*0Sstevel@tonic-gate } 731*0Sstevel@tonic-gate sv = NEWSV(35, len + 1); 732*0Sstevel@tonic-gate SvCUR_set(sv, len); 733*0Sstevel@tonic-gate SvPOK_on(sv); 734*0Sstevel@tonic-gate str = SvPVX(sv); 735*0Sstevel@tonic-gate if (datumtype == 'b') { 736*0Sstevel@tonic-gate aint = len; 737*0Sstevel@tonic-gate for (len = 0; len < aint; len++) { 738*0Sstevel@tonic-gate if (len & 7) /*SUPPRESS 595*/ 739*0Sstevel@tonic-gate bits >>= 1; 740*0Sstevel@tonic-gate else 741*0Sstevel@tonic-gate bits = *s++; 742*0Sstevel@tonic-gate *str++ = '0' + (bits & 1); 743*0Sstevel@tonic-gate } 744*0Sstevel@tonic-gate } 745*0Sstevel@tonic-gate else { 746*0Sstevel@tonic-gate aint = len; 747*0Sstevel@tonic-gate for (len = 0; len < aint; len++) { 748*0Sstevel@tonic-gate if (len & 7) 749*0Sstevel@tonic-gate bits <<= 1; 750*0Sstevel@tonic-gate else 751*0Sstevel@tonic-gate bits = *s++; 752*0Sstevel@tonic-gate *str++ = '0' + ((bits & 128) != 0); 753*0Sstevel@tonic-gate } 754*0Sstevel@tonic-gate } 755*0Sstevel@tonic-gate *str = '\0'; 756*0Sstevel@tonic-gate XPUSHs(sv_2mortal(sv)); 757*0Sstevel@tonic-gate break; 758*0Sstevel@tonic-gate case 'H': 759*0Sstevel@tonic-gate case 'h': 760*0Sstevel@tonic-gate if (howlen == e_star || len > (strend - s) * 2) 761*0Sstevel@tonic-gate len = (strend - s) * 2; 762*0Sstevel@tonic-gate sv = NEWSV(35, len + 1); 763*0Sstevel@tonic-gate SvCUR_set(sv, len); 764*0Sstevel@tonic-gate SvPOK_on(sv); 765*0Sstevel@tonic-gate str = SvPVX(sv); 766*0Sstevel@tonic-gate if (datumtype == 'h') { 767*0Sstevel@tonic-gate aint = len; 768*0Sstevel@tonic-gate for (len = 0; len < aint; len++) { 769*0Sstevel@tonic-gate if (len & 1) 770*0Sstevel@tonic-gate bits >>= 4; 771*0Sstevel@tonic-gate else 772*0Sstevel@tonic-gate bits = *s++; 773*0Sstevel@tonic-gate *str++ = PL_hexdigit[bits & 15]; 774*0Sstevel@tonic-gate } 775*0Sstevel@tonic-gate } 776*0Sstevel@tonic-gate else { 777*0Sstevel@tonic-gate aint = len; 778*0Sstevel@tonic-gate for (len = 0; len < aint; len++) { 779*0Sstevel@tonic-gate if (len & 1) 780*0Sstevel@tonic-gate bits <<= 4; 781*0Sstevel@tonic-gate else 782*0Sstevel@tonic-gate bits = *s++; 783*0Sstevel@tonic-gate *str++ = PL_hexdigit[(bits >> 4) & 15]; 784*0Sstevel@tonic-gate } 785*0Sstevel@tonic-gate } 786*0Sstevel@tonic-gate *str = '\0'; 787*0Sstevel@tonic-gate XPUSHs(sv_2mortal(sv)); 788*0Sstevel@tonic-gate break; 789*0Sstevel@tonic-gate case 'c': 790*0Sstevel@tonic-gate if (len > strend - s) 791*0Sstevel@tonic-gate len = strend - s; 792*0Sstevel@tonic-gate if (checksum) { 793*0Sstevel@tonic-gate while (len-- > 0) { 794*0Sstevel@tonic-gate aint = *s++; 795*0Sstevel@tonic-gate if (aint >= 128) /* fake up signed chars */ 796*0Sstevel@tonic-gate aint -= 256; 797*0Sstevel@tonic-gate if (checksum > bits_in_uv) 798*0Sstevel@tonic-gate cdouble += (NV)aint; 799*0Sstevel@tonic-gate else 800*0Sstevel@tonic-gate cuv += aint; 801*0Sstevel@tonic-gate } 802*0Sstevel@tonic-gate } 803*0Sstevel@tonic-gate else { 804*0Sstevel@tonic-gate if (len && unpack_only_one) 805*0Sstevel@tonic-gate len = 1; 806*0Sstevel@tonic-gate EXTEND(SP, len); 807*0Sstevel@tonic-gate EXTEND_MORTAL(len); 808*0Sstevel@tonic-gate while (len-- > 0) { 809*0Sstevel@tonic-gate aint = *s++; 810*0Sstevel@tonic-gate if (aint >= 128) /* fake up signed chars */ 811*0Sstevel@tonic-gate aint -= 256; 812*0Sstevel@tonic-gate sv = NEWSV(36, 0); 813*0Sstevel@tonic-gate sv_setiv(sv, (IV)aint); 814*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 815*0Sstevel@tonic-gate } 816*0Sstevel@tonic-gate } 817*0Sstevel@tonic-gate break; 818*0Sstevel@tonic-gate case 'C': 819*0Sstevel@tonic-gate unpack_C: /* unpack U will jump here if not UTF-8 */ 820*0Sstevel@tonic-gate if (len == 0) { 821*0Sstevel@tonic-gate symptr->flags &= ~FLAG_UNPACK_DO_UTF8; 822*0Sstevel@tonic-gate break; 823*0Sstevel@tonic-gate } 824*0Sstevel@tonic-gate if (len > strend - s) 825*0Sstevel@tonic-gate len = strend - s; 826*0Sstevel@tonic-gate if (checksum) { 827*0Sstevel@tonic-gate uchar_checksum: 828*0Sstevel@tonic-gate while (len-- > 0) { 829*0Sstevel@tonic-gate auint = *s++ & 255; 830*0Sstevel@tonic-gate cuv += auint; 831*0Sstevel@tonic-gate } 832*0Sstevel@tonic-gate } 833*0Sstevel@tonic-gate else { 834*0Sstevel@tonic-gate if (len && unpack_only_one) 835*0Sstevel@tonic-gate len = 1; 836*0Sstevel@tonic-gate EXTEND(SP, len); 837*0Sstevel@tonic-gate EXTEND_MORTAL(len); 838*0Sstevel@tonic-gate while (len-- > 0) { 839*0Sstevel@tonic-gate auint = *s++ & 255; 840*0Sstevel@tonic-gate sv = NEWSV(37, 0); 841*0Sstevel@tonic-gate sv_setiv(sv, (IV)auint); 842*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 843*0Sstevel@tonic-gate } 844*0Sstevel@tonic-gate } 845*0Sstevel@tonic-gate break; 846*0Sstevel@tonic-gate case 'U': 847*0Sstevel@tonic-gate if (len == 0) { 848*0Sstevel@tonic-gate symptr->flags |= FLAG_UNPACK_DO_UTF8; 849*0Sstevel@tonic-gate break; 850*0Sstevel@tonic-gate } 851*0Sstevel@tonic-gate if ((symptr->flags & FLAG_UNPACK_DO_UTF8) == 0) 852*0Sstevel@tonic-gate goto unpack_C; 853*0Sstevel@tonic-gate if (len > strend - s) 854*0Sstevel@tonic-gate len = strend - s; 855*0Sstevel@tonic-gate if (checksum) { 856*0Sstevel@tonic-gate while (len-- > 0 && s < strend) { 857*0Sstevel@tonic-gate STRLEN alen; 858*0Sstevel@tonic-gate auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV)); 859*0Sstevel@tonic-gate along = alen; 860*0Sstevel@tonic-gate s += along; 861*0Sstevel@tonic-gate if (checksum > bits_in_uv) 862*0Sstevel@tonic-gate cdouble += (NV)auint; 863*0Sstevel@tonic-gate else 864*0Sstevel@tonic-gate cuv += auint; 865*0Sstevel@tonic-gate } 866*0Sstevel@tonic-gate } 867*0Sstevel@tonic-gate else { 868*0Sstevel@tonic-gate if (len && unpack_only_one) 869*0Sstevel@tonic-gate len = 1; 870*0Sstevel@tonic-gate EXTEND(SP, len); 871*0Sstevel@tonic-gate EXTEND_MORTAL(len); 872*0Sstevel@tonic-gate while (len-- > 0 && s < strend) { 873*0Sstevel@tonic-gate STRLEN alen; 874*0Sstevel@tonic-gate auint = NATIVE_TO_UNI(utf8n_to_uvchr((U8*)s, strend - s, &alen, ckWARN(WARN_UTF8) ? 0 : UTF8_ALLOW_ANYUV)); 875*0Sstevel@tonic-gate along = alen; 876*0Sstevel@tonic-gate s += along; 877*0Sstevel@tonic-gate sv = NEWSV(37, 0); 878*0Sstevel@tonic-gate sv_setuv(sv, (UV)auint); 879*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 880*0Sstevel@tonic-gate } 881*0Sstevel@tonic-gate } 882*0Sstevel@tonic-gate break; 883*0Sstevel@tonic-gate case 's' | TYPE_IS_SHRIEKING: 884*0Sstevel@tonic-gate #if SHORTSIZE != SIZE16 885*0Sstevel@tonic-gate along = (strend - s) / sizeof(short); 886*0Sstevel@tonic-gate if (len > along) 887*0Sstevel@tonic-gate len = along; 888*0Sstevel@tonic-gate if (checksum) { 889*0Sstevel@tonic-gate short ashort; 890*0Sstevel@tonic-gate while (len-- > 0) { 891*0Sstevel@tonic-gate COPYNN(s, &ashort, sizeof(short)); 892*0Sstevel@tonic-gate s += sizeof(short); 893*0Sstevel@tonic-gate if (checksum > bits_in_uv) 894*0Sstevel@tonic-gate cdouble += (NV)ashort; 895*0Sstevel@tonic-gate else 896*0Sstevel@tonic-gate cuv += ashort; 897*0Sstevel@tonic-gate 898*0Sstevel@tonic-gate } 899*0Sstevel@tonic-gate } 900*0Sstevel@tonic-gate else { 901*0Sstevel@tonic-gate short ashort; 902*0Sstevel@tonic-gate if (len && unpack_only_one) 903*0Sstevel@tonic-gate len = 1; 904*0Sstevel@tonic-gate EXTEND(SP, len); 905*0Sstevel@tonic-gate EXTEND_MORTAL(len); 906*0Sstevel@tonic-gate while (len-- > 0) { 907*0Sstevel@tonic-gate COPYNN(s, &ashort, sizeof(short)); 908*0Sstevel@tonic-gate s += sizeof(short); 909*0Sstevel@tonic-gate sv = NEWSV(38, 0); 910*0Sstevel@tonic-gate sv_setiv(sv, (IV)ashort); 911*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 912*0Sstevel@tonic-gate } 913*0Sstevel@tonic-gate } 914*0Sstevel@tonic-gate break; 915*0Sstevel@tonic-gate #else 916*0Sstevel@tonic-gate /* Fallthrough! */ 917*0Sstevel@tonic-gate #endif 918*0Sstevel@tonic-gate case 's': 919*0Sstevel@tonic-gate along = (strend - s) / SIZE16; 920*0Sstevel@tonic-gate if (len > along) 921*0Sstevel@tonic-gate len = along; 922*0Sstevel@tonic-gate if (checksum) { 923*0Sstevel@tonic-gate while (len-- > 0) { 924*0Sstevel@tonic-gate COPY16(s, &ashort); 925*0Sstevel@tonic-gate #if SHORTSIZE > SIZE16 926*0Sstevel@tonic-gate if (ashort > 32767) 927*0Sstevel@tonic-gate ashort -= 65536; 928*0Sstevel@tonic-gate #endif 929*0Sstevel@tonic-gate s += SIZE16; 930*0Sstevel@tonic-gate if (checksum > bits_in_uv) 931*0Sstevel@tonic-gate cdouble += (NV)ashort; 932*0Sstevel@tonic-gate else 933*0Sstevel@tonic-gate cuv += ashort; 934*0Sstevel@tonic-gate } 935*0Sstevel@tonic-gate } 936*0Sstevel@tonic-gate else { 937*0Sstevel@tonic-gate if (len && unpack_only_one) 938*0Sstevel@tonic-gate len = 1; 939*0Sstevel@tonic-gate EXTEND(SP, len); 940*0Sstevel@tonic-gate EXTEND_MORTAL(len); 941*0Sstevel@tonic-gate 942*0Sstevel@tonic-gate while (len-- > 0) { 943*0Sstevel@tonic-gate COPY16(s, &ashort); 944*0Sstevel@tonic-gate #if SHORTSIZE > SIZE16 945*0Sstevel@tonic-gate if (ashort > 32767) 946*0Sstevel@tonic-gate ashort -= 65536; 947*0Sstevel@tonic-gate #endif 948*0Sstevel@tonic-gate s += SIZE16; 949*0Sstevel@tonic-gate sv = NEWSV(38, 0); 950*0Sstevel@tonic-gate sv_setiv(sv, (IV)ashort); 951*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 952*0Sstevel@tonic-gate } 953*0Sstevel@tonic-gate } 954*0Sstevel@tonic-gate break; 955*0Sstevel@tonic-gate case 'S' | TYPE_IS_SHRIEKING: 956*0Sstevel@tonic-gate #if SHORTSIZE != SIZE16 957*0Sstevel@tonic-gate along = (strend - s) / sizeof(unsigned short); 958*0Sstevel@tonic-gate if (len > along) 959*0Sstevel@tonic-gate len = along; 960*0Sstevel@tonic-gate if (checksum) { 961*0Sstevel@tonic-gate unsigned short aushort; 962*0Sstevel@tonic-gate while (len-- > 0) { 963*0Sstevel@tonic-gate COPYNN(s, &aushort, sizeof(unsigned short)); 964*0Sstevel@tonic-gate s += sizeof(unsigned short); 965*0Sstevel@tonic-gate if (checksum > bits_in_uv) 966*0Sstevel@tonic-gate cdouble += (NV)aushort; 967*0Sstevel@tonic-gate else 968*0Sstevel@tonic-gate cuv += aushort; 969*0Sstevel@tonic-gate } 970*0Sstevel@tonic-gate } 971*0Sstevel@tonic-gate else { 972*0Sstevel@tonic-gate if (len && unpack_only_one) 973*0Sstevel@tonic-gate len = 1; 974*0Sstevel@tonic-gate EXTEND(SP, len); 975*0Sstevel@tonic-gate EXTEND_MORTAL(len); 976*0Sstevel@tonic-gate while (len-- > 0) { 977*0Sstevel@tonic-gate unsigned short aushort; 978*0Sstevel@tonic-gate COPYNN(s, &aushort, sizeof(unsigned short)); 979*0Sstevel@tonic-gate s += sizeof(unsigned short); 980*0Sstevel@tonic-gate sv = NEWSV(39, 0); 981*0Sstevel@tonic-gate sv_setiv(sv, (UV)aushort); 982*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 983*0Sstevel@tonic-gate } 984*0Sstevel@tonic-gate } 985*0Sstevel@tonic-gate break; 986*0Sstevel@tonic-gate #else 987*0Sstevel@tonic-gate /* Fallhrough! */ 988*0Sstevel@tonic-gate #endif 989*0Sstevel@tonic-gate case 'v': 990*0Sstevel@tonic-gate case 'n': 991*0Sstevel@tonic-gate case 'S': 992*0Sstevel@tonic-gate along = (strend - s) / SIZE16; 993*0Sstevel@tonic-gate if (len > along) 994*0Sstevel@tonic-gate len = along; 995*0Sstevel@tonic-gate if (checksum) { 996*0Sstevel@tonic-gate while (len-- > 0) { 997*0Sstevel@tonic-gate COPY16(s, &aushort); 998*0Sstevel@tonic-gate s += SIZE16; 999*0Sstevel@tonic-gate #ifdef HAS_NTOHS 1000*0Sstevel@tonic-gate if (datumtype == 'n') 1001*0Sstevel@tonic-gate aushort = PerlSock_ntohs(aushort); 1002*0Sstevel@tonic-gate #endif 1003*0Sstevel@tonic-gate #ifdef HAS_VTOHS 1004*0Sstevel@tonic-gate if (datumtype == 'v') 1005*0Sstevel@tonic-gate aushort = vtohs(aushort); 1006*0Sstevel@tonic-gate #endif 1007*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1008*0Sstevel@tonic-gate cdouble += (NV)aushort; 1009*0Sstevel@tonic-gate else 1010*0Sstevel@tonic-gate cuv += aushort; 1011*0Sstevel@tonic-gate } 1012*0Sstevel@tonic-gate } 1013*0Sstevel@tonic-gate else { 1014*0Sstevel@tonic-gate if (len && unpack_only_one) 1015*0Sstevel@tonic-gate len = 1; 1016*0Sstevel@tonic-gate EXTEND(SP, len); 1017*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1018*0Sstevel@tonic-gate while (len-- > 0) { 1019*0Sstevel@tonic-gate COPY16(s, &aushort); 1020*0Sstevel@tonic-gate s += SIZE16; 1021*0Sstevel@tonic-gate sv = NEWSV(39, 0); 1022*0Sstevel@tonic-gate #ifdef HAS_NTOHS 1023*0Sstevel@tonic-gate if (datumtype == 'n') 1024*0Sstevel@tonic-gate aushort = PerlSock_ntohs(aushort); 1025*0Sstevel@tonic-gate #endif 1026*0Sstevel@tonic-gate #ifdef HAS_VTOHS 1027*0Sstevel@tonic-gate if (datumtype == 'v') 1028*0Sstevel@tonic-gate aushort = vtohs(aushort); 1029*0Sstevel@tonic-gate #endif 1030*0Sstevel@tonic-gate sv_setiv(sv, (UV)aushort); 1031*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1032*0Sstevel@tonic-gate } 1033*0Sstevel@tonic-gate } 1034*0Sstevel@tonic-gate break; 1035*0Sstevel@tonic-gate case 'i': 1036*0Sstevel@tonic-gate case 'i' | TYPE_IS_SHRIEKING: 1037*0Sstevel@tonic-gate along = (strend - s) / sizeof(int); 1038*0Sstevel@tonic-gate if (len > along) 1039*0Sstevel@tonic-gate len = along; 1040*0Sstevel@tonic-gate if (checksum) { 1041*0Sstevel@tonic-gate while (len-- > 0) { 1042*0Sstevel@tonic-gate Copy(s, &aint, 1, int); 1043*0Sstevel@tonic-gate s += sizeof(int); 1044*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1045*0Sstevel@tonic-gate cdouble += (NV)aint; 1046*0Sstevel@tonic-gate else 1047*0Sstevel@tonic-gate cuv += aint; 1048*0Sstevel@tonic-gate } 1049*0Sstevel@tonic-gate } 1050*0Sstevel@tonic-gate else { 1051*0Sstevel@tonic-gate if (len && unpack_only_one) 1052*0Sstevel@tonic-gate len = 1; 1053*0Sstevel@tonic-gate EXTEND(SP, len); 1054*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1055*0Sstevel@tonic-gate while (len-- > 0) { 1056*0Sstevel@tonic-gate Copy(s, &aint, 1, int); 1057*0Sstevel@tonic-gate s += sizeof(int); 1058*0Sstevel@tonic-gate sv = NEWSV(40, 0); 1059*0Sstevel@tonic-gate #ifdef __osf__ 1060*0Sstevel@tonic-gate /* Without the dummy below unpack("i", pack("i",-1)) 1061*0Sstevel@tonic-gate * return 0xFFffFFff instead of -1 for Digital Unix V4.0 1062*0Sstevel@tonic-gate * cc with optimization turned on. 1063*0Sstevel@tonic-gate * 1064*0Sstevel@tonic-gate * The bug was detected in 1065*0Sstevel@tonic-gate * DEC C V5.8-009 on Digital UNIX V4.0 (Rev. 1091) (V4.0E) 1066*0Sstevel@tonic-gate * with optimization (-O4) turned on. 1067*0Sstevel@tonic-gate * DEC C V5.2-040 on Digital UNIX V4.0 (Rev. 564) (V4.0B) 1068*0Sstevel@tonic-gate * does not have this problem even with -O4. 1069*0Sstevel@tonic-gate * 1070*0Sstevel@tonic-gate * This bug was reported as DECC_BUGS 1431 1071*0Sstevel@tonic-gate * and tracked internally as GEM_BUGS 7775. 1072*0Sstevel@tonic-gate * 1073*0Sstevel@tonic-gate * The bug is fixed in 1074*0Sstevel@tonic-gate * Tru64 UNIX V5.0: Compaq C V6.1-006 or later 1075*0Sstevel@tonic-gate * UNIX V4.0F support: DEC C V5.9-006 or later 1076*0Sstevel@tonic-gate * UNIX V4.0E support: DEC C V5.8-011 or later 1077*0Sstevel@tonic-gate * and also in DTK. 1078*0Sstevel@tonic-gate * 1079*0Sstevel@tonic-gate * See also few lines later for the same bug. 1080*0Sstevel@tonic-gate */ 1081*0Sstevel@tonic-gate (aint) ? 1082*0Sstevel@tonic-gate sv_setiv(sv, (IV)aint) : 1083*0Sstevel@tonic-gate #endif 1084*0Sstevel@tonic-gate sv_setiv(sv, (IV)aint); 1085*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1086*0Sstevel@tonic-gate } 1087*0Sstevel@tonic-gate } 1088*0Sstevel@tonic-gate break; 1089*0Sstevel@tonic-gate case 'I': 1090*0Sstevel@tonic-gate case 'I' | TYPE_IS_SHRIEKING: 1091*0Sstevel@tonic-gate along = (strend - s) / sizeof(unsigned int); 1092*0Sstevel@tonic-gate if (len > along) 1093*0Sstevel@tonic-gate len = along; 1094*0Sstevel@tonic-gate if (checksum) { 1095*0Sstevel@tonic-gate while (len-- > 0) { 1096*0Sstevel@tonic-gate Copy(s, &auint, 1, unsigned int); 1097*0Sstevel@tonic-gate s += sizeof(unsigned int); 1098*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1099*0Sstevel@tonic-gate cdouble += (NV)auint; 1100*0Sstevel@tonic-gate else 1101*0Sstevel@tonic-gate cuv += auint; 1102*0Sstevel@tonic-gate } 1103*0Sstevel@tonic-gate } 1104*0Sstevel@tonic-gate else { 1105*0Sstevel@tonic-gate if (len && unpack_only_one) 1106*0Sstevel@tonic-gate len = 1; 1107*0Sstevel@tonic-gate EXTEND(SP, len); 1108*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1109*0Sstevel@tonic-gate while (len-- > 0) { 1110*0Sstevel@tonic-gate Copy(s, &auint, 1, unsigned int); 1111*0Sstevel@tonic-gate s += sizeof(unsigned int); 1112*0Sstevel@tonic-gate sv = NEWSV(41, 0); 1113*0Sstevel@tonic-gate #ifdef __osf__ 1114*0Sstevel@tonic-gate /* Without the dummy below unpack("I", pack("I",0xFFFFFFFF)) 1115*0Sstevel@tonic-gate * returns 1.84467440737096e+19 instead of 0xFFFFFFFF. 1116*0Sstevel@tonic-gate * See details few lines earlier. */ 1117*0Sstevel@tonic-gate (auint) ? 1118*0Sstevel@tonic-gate sv_setuv(sv, (UV)auint) : 1119*0Sstevel@tonic-gate #endif 1120*0Sstevel@tonic-gate sv_setuv(sv, (UV)auint); 1121*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1122*0Sstevel@tonic-gate } 1123*0Sstevel@tonic-gate } 1124*0Sstevel@tonic-gate break; 1125*0Sstevel@tonic-gate case 'j': 1126*0Sstevel@tonic-gate along = (strend - s) / IVSIZE; 1127*0Sstevel@tonic-gate if (len > along) 1128*0Sstevel@tonic-gate len = along; 1129*0Sstevel@tonic-gate if (checksum) { 1130*0Sstevel@tonic-gate while (len-- > 0) { 1131*0Sstevel@tonic-gate Copy(s, &aiv, 1, IV); 1132*0Sstevel@tonic-gate s += IVSIZE; 1133*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1134*0Sstevel@tonic-gate cdouble += (NV)aiv; 1135*0Sstevel@tonic-gate else 1136*0Sstevel@tonic-gate cuv += aiv; 1137*0Sstevel@tonic-gate } 1138*0Sstevel@tonic-gate } 1139*0Sstevel@tonic-gate else { 1140*0Sstevel@tonic-gate if (len && unpack_only_one) 1141*0Sstevel@tonic-gate len = 1; 1142*0Sstevel@tonic-gate EXTEND(SP, len); 1143*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1144*0Sstevel@tonic-gate while (len-- > 0) { 1145*0Sstevel@tonic-gate Copy(s, &aiv, 1, IV); 1146*0Sstevel@tonic-gate s += IVSIZE; 1147*0Sstevel@tonic-gate sv = NEWSV(40, 0); 1148*0Sstevel@tonic-gate sv_setiv(sv, aiv); 1149*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1150*0Sstevel@tonic-gate } 1151*0Sstevel@tonic-gate } 1152*0Sstevel@tonic-gate break; 1153*0Sstevel@tonic-gate case 'J': 1154*0Sstevel@tonic-gate along = (strend - s) / UVSIZE; 1155*0Sstevel@tonic-gate if (len > along) 1156*0Sstevel@tonic-gate len = along; 1157*0Sstevel@tonic-gate if (checksum) { 1158*0Sstevel@tonic-gate while (len-- > 0) { 1159*0Sstevel@tonic-gate Copy(s, &auv, 1, UV); 1160*0Sstevel@tonic-gate s += UVSIZE; 1161*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1162*0Sstevel@tonic-gate cdouble += (NV)auv; 1163*0Sstevel@tonic-gate else 1164*0Sstevel@tonic-gate cuv += auv; 1165*0Sstevel@tonic-gate } 1166*0Sstevel@tonic-gate } 1167*0Sstevel@tonic-gate else { 1168*0Sstevel@tonic-gate if (len && unpack_only_one) 1169*0Sstevel@tonic-gate len = 1; 1170*0Sstevel@tonic-gate EXTEND(SP, len); 1171*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1172*0Sstevel@tonic-gate while (len-- > 0) { 1173*0Sstevel@tonic-gate Copy(s, &auv, 1, UV); 1174*0Sstevel@tonic-gate s += UVSIZE; 1175*0Sstevel@tonic-gate sv = NEWSV(41, 0); 1176*0Sstevel@tonic-gate sv_setuv(sv, auv); 1177*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1178*0Sstevel@tonic-gate } 1179*0Sstevel@tonic-gate } 1180*0Sstevel@tonic-gate break; 1181*0Sstevel@tonic-gate case 'l' | TYPE_IS_SHRIEKING: 1182*0Sstevel@tonic-gate #if LONGSIZE != SIZE32 1183*0Sstevel@tonic-gate along = (strend - s) / sizeof(long); 1184*0Sstevel@tonic-gate if (len > along) 1185*0Sstevel@tonic-gate len = along; 1186*0Sstevel@tonic-gate if (checksum) { 1187*0Sstevel@tonic-gate while (len-- > 0) { 1188*0Sstevel@tonic-gate COPYNN(s, &along, sizeof(long)); 1189*0Sstevel@tonic-gate s += sizeof(long); 1190*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1191*0Sstevel@tonic-gate cdouble += (NV)along; 1192*0Sstevel@tonic-gate else 1193*0Sstevel@tonic-gate cuv += along; 1194*0Sstevel@tonic-gate } 1195*0Sstevel@tonic-gate } 1196*0Sstevel@tonic-gate else { 1197*0Sstevel@tonic-gate if (len && unpack_only_one) 1198*0Sstevel@tonic-gate len = 1; 1199*0Sstevel@tonic-gate EXTEND(SP, len); 1200*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1201*0Sstevel@tonic-gate while (len-- > 0) { 1202*0Sstevel@tonic-gate COPYNN(s, &along, sizeof(long)); 1203*0Sstevel@tonic-gate s += sizeof(long); 1204*0Sstevel@tonic-gate sv = NEWSV(42, 0); 1205*0Sstevel@tonic-gate sv_setiv(sv, (IV)along); 1206*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1207*0Sstevel@tonic-gate } 1208*0Sstevel@tonic-gate } 1209*0Sstevel@tonic-gate break; 1210*0Sstevel@tonic-gate #else 1211*0Sstevel@tonic-gate /* Fallthrough! */ 1212*0Sstevel@tonic-gate #endif 1213*0Sstevel@tonic-gate case 'l': 1214*0Sstevel@tonic-gate along = (strend - s) / SIZE32; 1215*0Sstevel@tonic-gate if (len > along) 1216*0Sstevel@tonic-gate len = along; 1217*0Sstevel@tonic-gate if (checksum) { 1218*0Sstevel@tonic-gate while (len-- > 0) { 1219*0Sstevel@tonic-gate #if LONGSIZE > SIZE32 && INTSIZE == SIZE32 1220*0Sstevel@tonic-gate I32 along; 1221*0Sstevel@tonic-gate #endif 1222*0Sstevel@tonic-gate COPY32(s, &along); 1223*0Sstevel@tonic-gate #if LONGSIZE > SIZE32 1224*0Sstevel@tonic-gate if (along > 2147483647) 1225*0Sstevel@tonic-gate along -= 4294967296; 1226*0Sstevel@tonic-gate #endif 1227*0Sstevel@tonic-gate s += SIZE32; 1228*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1229*0Sstevel@tonic-gate cdouble += (NV)along; 1230*0Sstevel@tonic-gate else 1231*0Sstevel@tonic-gate cuv += along; 1232*0Sstevel@tonic-gate } 1233*0Sstevel@tonic-gate } 1234*0Sstevel@tonic-gate else { 1235*0Sstevel@tonic-gate if (len && unpack_only_one) 1236*0Sstevel@tonic-gate len = 1; 1237*0Sstevel@tonic-gate EXTEND(SP, len); 1238*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1239*0Sstevel@tonic-gate while (len-- > 0) { 1240*0Sstevel@tonic-gate #if LONGSIZE > SIZE32 && INTSIZE == SIZE32 1241*0Sstevel@tonic-gate I32 along; 1242*0Sstevel@tonic-gate #endif 1243*0Sstevel@tonic-gate COPY32(s, &along); 1244*0Sstevel@tonic-gate #if LONGSIZE > SIZE32 1245*0Sstevel@tonic-gate if (along > 2147483647) 1246*0Sstevel@tonic-gate along -= 4294967296; 1247*0Sstevel@tonic-gate #endif 1248*0Sstevel@tonic-gate s += SIZE32; 1249*0Sstevel@tonic-gate sv = NEWSV(42, 0); 1250*0Sstevel@tonic-gate sv_setiv(sv, (IV)along); 1251*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1252*0Sstevel@tonic-gate } 1253*0Sstevel@tonic-gate } 1254*0Sstevel@tonic-gate break; 1255*0Sstevel@tonic-gate case 'L' | TYPE_IS_SHRIEKING: 1256*0Sstevel@tonic-gate #if LONGSIZE != SIZE32 1257*0Sstevel@tonic-gate along = (strend - s) / sizeof(unsigned long); 1258*0Sstevel@tonic-gate if (len > along) 1259*0Sstevel@tonic-gate len = along; 1260*0Sstevel@tonic-gate if (checksum) { 1261*0Sstevel@tonic-gate while (len-- > 0) { 1262*0Sstevel@tonic-gate unsigned long aulong; 1263*0Sstevel@tonic-gate COPYNN(s, &aulong, sizeof(unsigned long)); 1264*0Sstevel@tonic-gate s += sizeof(unsigned long); 1265*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1266*0Sstevel@tonic-gate cdouble += (NV)aulong; 1267*0Sstevel@tonic-gate else 1268*0Sstevel@tonic-gate cuv += aulong; 1269*0Sstevel@tonic-gate } 1270*0Sstevel@tonic-gate } 1271*0Sstevel@tonic-gate else { 1272*0Sstevel@tonic-gate if (len && unpack_only_one) 1273*0Sstevel@tonic-gate len = 1; 1274*0Sstevel@tonic-gate EXTEND(SP, len); 1275*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1276*0Sstevel@tonic-gate while (len-- > 0) { 1277*0Sstevel@tonic-gate unsigned long aulong; 1278*0Sstevel@tonic-gate COPYNN(s, &aulong, sizeof(unsigned long)); 1279*0Sstevel@tonic-gate s += sizeof(unsigned long); 1280*0Sstevel@tonic-gate sv = NEWSV(43, 0); 1281*0Sstevel@tonic-gate sv_setuv(sv, (UV)aulong); 1282*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1283*0Sstevel@tonic-gate } 1284*0Sstevel@tonic-gate } 1285*0Sstevel@tonic-gate break; 1286*0Sstevel@tonic-gate #else 1287*0Sstevel@tonic-gate /* Fall through! */ 1288*0Sstevel@tonic-gate #endif 1289*0Sstevel@tonic-gate case 'V': 1290*0Sstevel@tonic-gate case 'N': 1291*0Sstevel@tonic-gate case 'L': 1292*0Sstevel@tonic-gate along = (strend - s) / SIZE32; 1293*0Sstevel@tonic-gate if (len > along) 1294*0Sstevel@tonic-gate len = along; 1295*0Sstevel@tonic-gate if (checksum) { 1296*0Sstevel@tonic-gate while (len-- > 0) { 1297*0Sstevel@tonic-gate COPY32(s, &aulong); 1298*0Sstevel@tonic-gate s += SIZE32; 1299*0Sstevel@tonic-gate #ifdef HAS_NTOHL 1300*0Sstevel@tonic-gate if (datumtype == 'N') 1301*0Sstevel@tonic-gate aulong = PerlSock_ntohl(aulong); 1302*0Sstevel@tonic-gate #endif 1303*0Sstevel@tonic-gate #ifdef HAS_VTOHL 1304*0Sstevel@tonic-gate if (datumtype == 'V') 1305*0Sstevel@tonic-gate aulong = vtohl(aulong); 1306*0Sstevel@tonic-gate #endif 1307*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1308*0Sstevel@tonic-gate cdouble += (NV)aulong; 1309*0Sstevel@tonic-gate else 1310*0Sstevel@tonic-gate cuv += aulong; 1311*0Sstevel@tonic-gate } 1312*0Sstevel@tonic-gate } 1313*0Sstevel@tonic-gate else { 1314*0Sstevel@tonic-gate if (len && unpack_only_one) 1315*0Sstevel@tonic-gate len = 1; 1316*0Sstevel@tonic-gate EXTEND(SP, len); 1317*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1318*0Sstevel@tonic-gate while (len-- > 0) { 1319*0Sstevel@tonic-gate COPY32(s, &aulong); 1320*0Sstevel@tonic-gate s += SIZE32; 1321*0Sstevel@tonic-gate #ifdef HAS_NTOHL 1322*0Sstevel@tonic-gate if (datumtype == 'N') 1323*0Sstevel@tonic-gate aulong = PerlSock_ntohl(aulong); 1324*0Sstevel@tonic-gate #endif 1325*0Sstevel@tonic-gate #ifdef HAS_VTOHL 1326*0Sstevel@tonic-gate if (datumtype == 'V') 1327*0Sstevel@tonic-gate aulong = vtohl(aulong); 1328*0Sstevel@tonic-gate #endif 1329*0Sstevel@tonic-gate sv = NEWSV(43, 0); 1330*0Sstevel@tonic-gate sv_setuv(sv, (UV)aulong); 1331*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1332*0Sstevel@tonic-gate } 1333*0Sstevel@tonic-gate } 1334*0Sstevel@tonic-gate break; 1335*0Sstevel@tonic-gate case 'p': 1336*0Sstevel@tonic-gate along = (strend - s) / sizeof(char*); 1337*0Sstevel@tonic-gate if (len > along) 1338*0Sstevel@tonic-gate len = along; 1339*0Sstevel@tonic-gate EXTEND(SP, len); 1340*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1341*0Sstevel@tonic-gate while (len-- > 0) { 1342*0Sstevel@tonic-gate if (sizeof(char*) > strend - s) 1343*0Sstevel@tonic-gate break; 1344*0Sstevel@tonic-gate else { 1345*0Sstevel@tonic-gate Copy(s, &aptr, 1, char*); 1346*0Sstevel@tonic-gate s += sizeof(char*); 1347*0Sstevel@tonic-gate } 1348*0Sstevel@tonic-gate sv = NEWSV(44, 0); 1349*0Sstevel@tonic-gate if (aptr) 1350*0Sstevel@tonic-gate sv_setpv(sv, aptr); 1351*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1352*0Sstevel@tonic-gate } 1353*0Sstevel@tonic-gate break; 1354*0Sstevel@tonic-gate case 'w': 1355*0Sstevel@tonic-gate if (len && unpack_only_one) 1356*0Sstevel@tonic-gate len = 1; 1357*0Sstevel@tonic-gate EXTEND(SP, len); 1358*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1359*0Sstevel@tonic-gate { 1360*0Sstevel@tonic-gate UV auv = 0; 1361*0Sstevel@tonic-gate U32 bytes = 0; 1362*0Sstevel@tonic-gate 1363*0Sstevel@tonic-gate while ((len > 0) && (s < strend)) { 1364*0Sstevel@tonic-gate auv = (auv << 7) | (*s & 0x7f); 1365*0Sstevel@tonic-gate /* UTF8_IS_XXXXX not right here - using constant 0x80 */ 1366*0Sstevel@tonic-gate if ((U8)(*s++) < 0x80) { 1367*0Sstevel@tonic-gate bytes = 0; 1368*0Sstevel@tonic-gate sv = NEWSV(40, 0); 1369*0Sstevel@tonic-gate sv_setuv(sv, auv); 1370*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1371*0Sstevel@tonic-gate len--; 1372*0Sstevel@tonic-gate auv = 0; 1373*0Sstevel@tonic-gate } 1374*0Sstevel@tonic-gate else if (++bytes >= sizeof(UV)) { /* promote to string */ 1375*0Sstevel@tonic-gate char *t; 1376*0Sstevel@tonic-gate STRLEN n_a; 1377*0Sstevel@tonic-gate 1378*0Sstevel@tonic-gate sv = Perl_newSVpvf(aTHX_ "%.*"UVf, (int)TYPE_DIGITS(UV), auv); 1379*0Sstevel@tonic-gate while (s < strend) { 1380*0Sstevel@tonic-gate sv = mul128(sv, (U8)(*s & 0x7f)); 1381*0Sstevel@tonic-gate if (!(*s++ & 0x80)) { 1382*0Sstevel@tonic-gate bytes = 0; 1383*0Sstevel@tonic-gate break; 1384*0Sstevel@tonic-gate } 1385*0Sstevel@tonic-gate } 1386*0Sstevel@tonic-gate t = SvPV(sv, n_a); 1387*0Sstevel@tonic-gate while (*t == '0') 1388*0Sstevel@tonic-gate t++; 1389*0Sstevel@tonic-gate sv_chop(sv, t); 1390*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1391*0Sstevel@tonic-gate len--; 1392*0Sstevel@tonic-gate auv = 0; 1393*0Sstevel@tonic-gate } 1394*0Sstevel@tonic-gate } 1395*0Sstevel@tonic-gate if ((s >= strend) && bytes) 1396*0Sstevel@tonic-gate Perl_croak(aTHX_ "Unterminated compressed integer in unpack"); 1397*0Sstevel@tonic-gate } 1398*0Sstevel@tonic-gate break; 1399*0Sstevel@tonic-gate case 'P': 1400*0Sstevel@tonic-gate if (symptr->howlen == e_star) 1401*0Sstevel@tonic-gate Perl_croak(aTHX_ "'P' must have an explicit size in unpack"); 1402*0Sstevel@tonic-gate EXTEND(SP, 1); 1403*0Sstevel@tonic-gate if (sizeof(char*) > strend - s) 1404*0Sstevel@tonic-gate break; 1405*0Sstevel@tonic-gate else { 1406*0Sstevel@tonic-gate Copy(s, &aptr, 1, char*); 1407*0Sstevel@tonic-gate s += sizeof(char*); 1408*0Sstevel@tonic-gate } 1409*0Sstevel@tonic-gate sv = NEWSV(44, 0); 1410*0Sstevel@tonic-gate if (aptr) 1411*0Sstevel@tonic-gate sv_setpvn(sv, aptr, len); 1412*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1413*0Sstevel@tonic-gate break; 1414*0Sstevel@tonic-gate #ifdef HAS_QUAD 1415*0Sstevel@tonic-gate case 'q': 1416*0Sstevel@tonic-gate along = (strend - s) / sizeof(Quad_t); 1417*0Sstevel@tonic-gate if (len > along) 1418*0Sstevel@tonic-gate len = along; 1419*0Sstevel@tonic-gate if (checksum) { 1420*0Sstevel@tonic-gate while (len-- > 0) { 1421*0Sstevel@tonic-gate Copy(s, &aquad, 1, Quad_t); 1422*0Sstevel@tonic-gate s += sizeof(Quad_t); 1423*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1424*0Sstevel@tonic-gate cdouble += (NV)aquad; 1425*0Sstevel@tonic-gate else 1426*0Sstevel@tonic-gate cuv += aquad; 1427*0Sstevel@tonic-gate } 1428*0Sstevel@tonic-gate } 1429*0Sstevel@tonic-gate else { 1430*0Sstevel@tonic-gate if (len && unpack_only_one) 1431*0Sstevel@tonic-gate len = 1; 1432*0Sstevel@tonic-gate EXTEND(SP, len); 1433*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1434*0Sstevel@tonic-gate while (len-- > 0) { 1435*0Sstevel@tonic-gate if (s + sizeof(Quad_t) > strend) 1436*0Sstevel@tonic-gate aquad = 0; 1437*0Sstevel@tonic-gate else { 1438*0Sstevel@tonic-gate Copy(s, &aquad, 1, Quad_t); 1439*0Sstevel@tonic-gate s += sizeof(Quad_t); 1440*0Sstevel@tonic-gate } 1441*0Sstevel@tonic-gate sv = NEWSV(42, 0); 1442*0Sstevel@tonic-gate if (aquad >= IV_MIN && aquad <= IV_MAX) 1443*0Sstevel@tonic-gate sv_setiv(sv, (IV)aquad); 1444*0Sstevel@tonic-gate else 1445*0Sstevel@tonic-gate sv_setnv(sv, (NV)aquad); 1446*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1447*0Sstevel@tonic-gate } 1448*0Sstevel@tonic-gate } 1449*0Sstevel@tonic-gate break; 1450*0Sstevel@tonic-gate case 'Q': 1451*0Sstevel@tonic-gate along = (strend - s) / sizeof(Uquad_t); 1452*0Sstevel@tonic-gate if (len > along) 1453*0Sstevel@tonic-gate len = along; 1454*0Sstevel@tonic-gate if (checksum) { 1455*0Sstevel@tonic-gate while (len-- > 0) { 1456*0Sstevel@tonic-gate Copy(s, &auquad, 1, Uquad_t); 1457*0Sstevel@tonic-gate s += sizeof(Uquad_t); 1458*0Sstevel@tonic-gate if (checksum > bits_in_uv) 1459*0Sstevel@tonic-gate cdouble += (NV)auquad; 1460*0Sstevel@tonic-gate else 1461*0Sstevel@tonic-gate cuv += auquad; 1462*0Sstevel@tonic-gate } 1463*0Sstevel@tonic-gate } 1464*0Sstevel@tonic-gate else { 1465*0Sstevel@tonic-gate if (len && unpack_only_one) 1466*0Sstevel@tonic-gate len = 1; 1467*0Sstevel@tonic-gate EXTEND(SP, len); 1468*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1469*0Sstevel@tonic-gate while (len-- > 0) { 1470*0Sstevel@tonic-gate if (s + sizeof(Uquad_t) > strend) 1471*0Sstevel@tonic-gate auquad = 0; 1472*0Sstevel@tonic-gate else { 1473*0Sstevel@tonic-gate Copy(s, &auquad, 1, Uquad_t); 1474*0Sstevel@tonic-gate s += sizeof(Uquad_t); 1475*0Sstevel@tonic-gate } 1476*0Sstevel@tonic-gate sv = NEWSV(43, 0); 1477*0Sstevel@tonic-gate if (auquad <= UV_MAX) 1478*0Sstevel@tonic-gate sv_setuv(sv, (UV)auquad); 1479*0Sstevel@tonic-gate else 1480*0Sstevel@tonic-gate sv_setnv(sv, (NV)auquad); 1481*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1482*0Sstevel@tonic-gate } 1483*0Sstevel@tonic-gate } 1484*0Sstevel@tonic-gate break; 1485*0Sstevel@tonic-gate #endif 1486*0Sstevel@tonic-gate /* float and double added gnb@melba.bby.oz.au 22/11/89 */ 1487*0Sstevel@tonic-gate case 'f': 1488*0Sstevel@tonic-gate along = (strend - s) / sizeof(float); 1489*0Sstevel@tonic-gate if (len > along) 1490*0Sstevel@tonic-gate len = along; 1491*0Sstevel@tonic-gate if (checksum) { 1492*0Sstevel@tonic-gate while (len-- > 0) { 1493*0Sstevel@tonic-gate Copy(s, &afloat, 1, float); 1494*0Sstevel@tonic-gate s += sizeof(float); 1495*0Sstevel@tonic-gate cdouble += afloat; 1496*0Sstevel@tonic-gate } 1497*0Sstevel@tonic-gate } 1498*0Sstevel@tonic-gate else { 1499*0Sstevel@tonic-gate if (len && unpack_only_one) 1500*0Sstevel@tonic-gate len = 1; 1501*0Sstevel@tonic-gate EXTEND(SP, len); 1502*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1503*0Sstevel@tonic-gate while (len-- > 0) { 1504*0Sstevel@tonic-gate Copy(s, &afloat, 1, float); 1505*0Sstevel@tonic-gate s += sizeof(float); 1506*0Sstevel@tonic-gate sv = NEWSV(47, 0); 1507*0Sstevel@tonic-gate sv_setnv(sv, (NV)afloat); 1508*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1509*0Sstevel@tonic-gate } 1510*0Sstevel@tonic-gate } 1511*0Sstevel@tonic-gate break; 1512*0Sstevel@tonic-gate case 'd': 1513*0Sstevel@tonic-gate along = (strend - s) / sizeof(double); 1514*0Sstevel@tonic-gate if (len > along) 1515*0Sstevel@tonic-gate len = along; 1516*0Sstevel@tonic-gate if (checksum) { 1517*0Sstevel@tonic-gate while (len-- > 0) { 1518*0Sstevel@tonic-gate Copy(s, &adouble, 1, double); 1519*0Sstevel@tonic-gate s += sizeof(double); 1520*0Sstevel@tonic-gate cdouble += adouble; 1521*0Sstevel@tonic-gate } 1522*0Sstevel@tonic-gate } 1523*0Sstevel@tonic-gate else { 1524*0Sstevel@tonic-gate if (len && unpack_only_one) 1525*0Sstevel@tonic-gate len = 1; 1526*0Sstevel@tonic-gate EXTEND(SP, len); 1527*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1528*0Sstevel@tonic-gate while (len-- > 0) { 1529*0Sstevel@tonic-gate Copy(s, &adouble, 1, double); 1530*0Sstevel@tonic-gate s += sizeof(double); 1531*0Sstevel@tonic-gate sv = NEWSV(48, 0); 1532*0Sstevel@tonic-gate sv_setnv(sv, (NV)adouble); 1533*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1534*0Sstevel@tonic-gate } 1535*0Sstevel@tonic-gate } 1536*0Sstevel@tonic-gate break; 1537*0Sstevel@tonic-gate case 'F': 1538*0Sstevel@tonic-gate along = (strend - s) / NVSIZE; 1539*0Sstevel@tonic-gate if (len > along) 1540*0Sstevel@tonic-gate len = along; 1541*0Sstevel@tonic-gate if (checksum) { 1542*0Sstevel@tonic-gate while (len-- > 0) { 1543*0Sstevel@tonic-gate Copy(s, &anv, 1, NV); 1544*0Sstevel@tonic-gate s += NVSIZE; 1545*0Sstevel@tonic-gate cdouble += anv; 1546*0Sstevel@tonic-gate } 1547*0Sstevel@tonic-gate } 1548*0Sstevel@tonic-gate else { 1549*0Sstevel@tonic-gate if (len && unpack_only_one) 1550*0Sstevel@tonic-gate len = 1; 1551*0Sstevel@tonic-gate EXTEND(SP, len); 1552*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1553*0Sstevel@tonic-gate while (len-- > 0) { 1554*0Sstevel@tonic-gate Copy(s, &anv, 1, NV); 1555*0Sstevel@tonic-gate s += NVSIZE; 1556*0Sstevel@tonic-gate sv = NEWSV(48, 0); 1557*0Sstevel@tonic-gate sv_setnv(sv, anv); 1558*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1559*0Sstevel@tonic-gate } 1560*0Sstevel@tonic-gate } 1561*0Sstevel@tonic-gate break; 1562*0Sstevel@tonic-gate #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 1563*0Sstevel@tonic-gate case 'D': 1564*0Sstevel@tonic-gate along = (strend - s) / LONG_DOUBLESIZE; 1565*0Sstevel@tonic-gate if (len > along) 1566*0Sstevel@tonic-gate len = along; 1567*0Sstevel@tonic-gate if (checksum) { 1568*0Sstevel@tonic-gate while (len-- > 0) { 1569*0Sstevel@tonic-gate Copy(s, &aldouble, 1, long double); 1570*0Sstevel@tonic-gate s += LONG_DOUBLESIZE; 1571*0Sstevel@tonic-gate cdouble += aldouble; 1572*0Sstevel@tonic-gate } 1573*0Sstevel@tonic-gate } 1574*0Sstevel@tonic-gate else { 1575*0Sstevel@tonic-gate if (len && unpack_only_one) 1576*0Sstevel@tonic-gate len = 1; 1577*0Sstevel@tonic-gate EXTEND(SP, len); 1578*0Sstevel@tonic-gate EXTEND_MORTAL(len); 1579*0Sstevel@tonic-gate while (len-- > 0) { 1580*0Sstevel@tonic-gate Copy(s, &aldouble, 1, long double); 1581*0Sstevel@tonic-gate s += LONG_DOUBLESIZE; 1582*0Sstevel@tonic-gate sv = NEWSV(48, 0); 1583*0Sstevel@tonic-gate sv_setnv(sv, (NV)aldouble); 1584*0Sstevel@tonic-gate PUSHs(sv_2mortal(sv)); 1585*0Sstevel@tonic-gate } 1586*0Sstevel@tonic-gate } 1587*0Sstevel@tonic-gate break; 1588*0Sstevel@tonic-gate #endif 1589*0Sstevel@tonic-gate case 'u': 1590*0Sstevel@tonic-gate /* MKS: 1591*0Sstevel@tonic-gate * Initialise the decode mapping. By using a table driven 1592*0Sstevel@tonic-gate * algorithm, the code will be character-set independent 1593*0Sstevel@tonic-gate * (and just as fast as doing character arithmetic) 1594*0Sstevel@tonic-gate */ 1595*0Sstevel@tonic-gate if (PL_uudmap['M'] == 0) { 1596*0Sstevel@tonic-gate int i; 1597*0Sstevel@tonic-gate 1598*0Sstevel@tonic-gate for (i = 0; i < sizeof(PL_uuemap); i += 1) 1599*0Sstevel@tonic-gate PL_uudmap[(U8)PL_uuemap[i]] = i; 1600*0Sstevel@tonic-gate /* 1601*0Sstevel@tonic-gate * Because ' ' and '`' map to the same value, 1602*0Sstevel@tonic-gate * we need to decode them both the same. 1603*0Sstevel@tonic-gate */ 1604*0Sstevel@tonic-gate PL_uudmap[' '] = 0; 1605*0Sstevel@tonic-gate } 1606*0Sstevel@tonic-gate 1607*0Sstevel@tonic-gate along = (strend - s) * 3 / 4; 1608*0Sstevel@tonic-gate sv = NEWSV(42, along); 1609*0Sstevel@tonic-gate if (along) 1610*0Sstevel@tonic-gate SvPOK_on(sv); 1611*0Sstevel@tonic-gate while (s < strend && *s > ' ' && ISUUCHAR(*s)) { 1612*0Sstevel@tonic-gate I32 a, b, c, d; 1613*0Sstevel@tonic-gate char hunk[4]; 1614*0Sstevel@tonic-gate 1615*0Sstevel@tonic-gate hunk[3] = '\0'; 1616*0Sstevel@tonic-gate len = PL_uudmap[*(U8*)s++] & 077; 1617*0Sstevel@tonic-gate while (len > 0) { 1618*0Sstevel@tonic-gate if (s < strend && ISUUCHAR(*s)) 1619*0Sstevel@tonic-gate a = PL_uudmap[*(U8*)s++] & 077; 1620*0Sstevel@tonic-gate else 1621*0Sstevel@tonic-gate a = 0; 1622*0Sstevel@tonic-gate if (s < strend && ISUUCHAR(*s)) 1623*0Sstevel@tonic-gate b = PL_uudmap[*(U8*)s++] & 077; 1624*0Sstevel@tonic-gate else 1625*0Sstevel@tonic-gate b = 0; 1626*0Sstevel@tonic-gate if (s < strend && ISUUCHAR(*s)) 1627*0Sstevel@tonic-gate c = PL_uudmap[*(U8*)s++] & 077; 1628*0Sstevel@tonic-gate else 1629*0Sstevel@tonic-gate c = 0; 1630*0Sstevel@tonic-gate if (s < strend && ISUUCHAR(*s)) 1631*0Sstevel@tonic-gate d = PL_uudmap[*(U8*)s++] & 077; 1632*0Sstevel@tonic-gate else 1633*0Sstevel@tonic-gate d = 0; 1634*0Sstevel@tonic-gate hunk[0] = (char)((a << 2) | (b >> 4)); 1635*0Sstevel@tonic-gate hunk[1] = (char)((b << 4) | (c >> 2)); 1636*0Sstevel@tonic-gate hunk[2] = (char)((c << 6) | d); 1637*0Sstevel@tonic-gate sv_catpvn(sv, hunk, (len > 3) ? 3 : len); 1638*0Sstevel@tonic-gate len -= 3; 1639*0Sstevel@tonic-gate } 1640*0Sstevel@tonic-gate if (*s == '\n') 1641*0Sstevel@tonic-gate s++; 1642*0Sstevel@tonic-gate else /* possible checksum byte */ 1643*0Sstevel@tonic-gate if (s + 1 < strend && s[1] == '\n') 1644*0Sstevel@tonic-gate s += 2; 1645*0Sstevel@tonic-gate } 1646*0Sstevel@tonic-gate XPUSHs(sv_2mortal(sv)); 1647*0Sstevel@tonic-gate break; 1648*0Sstevel@tonic-gate } 1649*0Sstevel@tonic-gate 1650*0Sstevel@tonic-gate if (checksum) { 1651*0Sstevel@tonic-gate sv = NEWSV(42, 0); 1652*0Sstevel@tonic-gate if (strchr("fFdD", datumtype) || 1653*0Sstevel@tonic-gate (checksum > bits_in_uv && 1654*0Sstevel@tonic-gate strchr("csSiIlLnNUvVqQjJ", datumtype&0xFF)) ) { 1655*0Sstevel@tonic-gate NV trouble; 1656*0Sstevel@tonic-gate 1657*0Sstevel@tonic-gate adouble = (NV) (1 << (checksum & 15)); 1658*0Sstevel@tonic-gate while (checksum >= 16) { 1659*0Sstevel@tonic-gate checksum -= 16; 1660*0Sstevel@tonic-gate adouble *= 65536.0; 1661*0Sstevel@tonic-gate } 1662*0Sstevel@tonic-gate while (cdouble < 0.0) 1663*0Sstevel@tonic-gate cdouble += adouble; 1664*0Sstevel@tonic-gate cdouble = Perl_modf(cdouble / adouble, &trouble) * adouble; 1665*0Sstevel@tonic-gate sv_setnv(sv, cdouble); 1666*0Sstevel@tonic-gate } 1667*0Sstevel@tonic-gate else { 1668*0Sstevel@tonic-gate if (checksum < bits_in_uv) { 1669*0Sstevel@tonic-gate UV mask = ((UV)1 << checksum) - 1; 1670*0Sstevel@tonic-gate cuv &= mask; 1671*0Sstevel@tonic-gate } 1672*0Sstevel@tonic-gate sv_setuv(sv, cuv); 1673*0Sstevel@tonic-gate } 1674*0Sstevel@tonic-gate XPUSHs(sv_2mortal(sv)); 1675*0Sstevel@tonic-gate checksum = 0; 1676*0Sstevel@tonic-gate } 1677*0Sstevel@tonic-gate 1678*0Sstevel@tonic-gate if (symptr->flags & FLAG_SLASH){ 1679*0Sstevel@tonic-gate if (SP - PL_stack_base - start_sp_offset <= 0) 1680*0Sstevel@tonic-gate Perl_croak(aTHX_ "'/' must follow a numeric type in unpack"); 1681*0Sstevel@tonic-gate if( next_symbol(symptr) ){ 1682*0Sstevel@tonic-gate if( symptr->howlen == e_number ) 1683*0Sstevel@tonic-gate Perl_croak(aTHX_ "Count after length/code in unpack" ); 1684*0Sstevel@tonic-gate if( beyond ){ 1685*0Sstevel@tonic-gate /* ...end of char buffer then no decent length available */ 1686*0Sstevel@tonic-gate Perl_croak(aTHX_ "length/code after end of string in unpack" ); 1687*0Sstevel@tonic-gate } else { 1688*0Sstevel@tonic-gate /* take top of stack (hope it's numeric) */ 1689*0Sstevel@tonic-gate len = POPi; 1690*0Sstevel@tonic-gate if( len < 0 ) 1691*0Sstevel@tonic-gate Perl_croak(aTHX_ "Negative '/' count in unpack" ); 1692*0Sstevel@tonic-gate } 1693*0Sstevel@tonic-gate } else { 1694*0Sstevel@tonic-gate Perl_croak(aTHX_ "Code missing after '/' in unpack" ); 1695*0Sstevel@tonic-gate } 1696*0Sstevel@tonic-gate datumtype = symptr->code; 1697*0Sstevel@tonic-gate goto redo_switch; 1698*0Sstevel@tonic-gate } 1699*0Sstevel@tonic-gate } 1700*0Sstevel@tonic-gate 1701*0Sstevel@tonic-gate if (new_s) 1702*0Sstevel@tonic-gate *new_s = s; 1703*0Sstevel@tonic-gate PUTBACK; 1704*0Sstevel@tonic-gate return SP - PL_stack_base - start_sp_offset; 1705*0Sstevel@tonic-gate } 1706*0Sstevel@tonic-gate 1707*0Sstevel@tonic-gate PP(pp_unpack) 1708*0Sstevel@tonic-gate { 1709*0Sstevel@tonic-gate dSP; 1710*0Sstevel@tonic-gate dPOPPOPssrl; 1711*0Sstevel@tonic-gate I32 gimme = GIMME_V; 1712*0Sstevel@tonic-gate STRLEN llen; 1713*0Sstevel@tonic-gate STRLEN rlen; 1714*0Sstevel@tonic-gate register char *pat = SvPV(left, llen); 1715*0Sstevel@tonic-gate #ifdef PACKED_IS_OCTETS 1716*0Sstevel@tonic-gate /* Packed side is assumed to be octets - so force downgrade if it 1717*0Sstevel@tonic-gate has been UTF-8 encoded by accident 1718*0Sstevel@tonic-gate */ 1719*0Sstevel@tonic-gate register char *s = SvPVbyte(right, rlen); 1720*0Sstevel@tonic-gate #else 1721*0Sstevel@tonic-gate register char *s = SvPV(right, rlen); 1722*0Sstevel@tonic-gate #endif 1723*0Sstevel@tonic-gate char *strend = s + rlen; 1724*0Sstevel@tonic-gate register char *patend = pat + llen; 1725*0Sstevel@tonic-gate register I32 cnt; 1726*0Sstevel@tonic-gate 1727*0Sstevel@tonic-gate PUTBACK; 1728*0Sstevel@tonic-gate cnt = unpackstring(pat, patend, s, strend, 1729*0Sstevel@tonic-gate ((gimme == G_SCALAR) ? FLAG_UNPACK_ONLY_ONE : 0) 1730*0Sstevel@tonic-gate | (DO_UTF8(right) ? FLAG_UNPACK_DO_UTF8 : 0)); 1731*0Sstevel@tonic-gate 1732*0Sstevel@tonic-gate SPAGAIN; 1733*0Sstevel@tonic-gate if ( !cnt && gimme == G_SCALAR ) 1734*0Sstevel@tonic-gate PUSHs(&PL_sv_undef); 1735*0Sstevel@tonic-gate RETURN; 1736*0Sstevel@tonic-gate } 1737*0Sstevel@tonic-gate 1738*0Sstevel@tonic-gate STATIC void 1739*0Sstevel@tonic-gate S_doencodes(pTHX_ register SV *sv, register char *s, register I32 len) 1740*0Sstevel@tonic-gate { 1741*0Sstevel@tonic-gate char hunk[5]; 1742*0Sstevel@tonic-gate 1743*0Sstevel@tonic-gate *hunk = PL_uuemap[len]; 1744*0Sstevel@tonic-gate sv_catpvn(sv, hunk, 1); 1745*0Sstevel@tonic-gate hunk[4] = '\0'; 1746*0Sstevel@tonic-gate while (len > 2) { 1747*0Sstevel@tonic-gate hunk[0] = PL_uuemap[(077 & (*s >> 2))]; 1748*0Sstevel@tonic-gate hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((s[1] >> 4) & 017)))]; 1749*0Sstevel@tonic-gate hunk[2] = PL_uuemap[(077 & (((s[1] << 2) & 074) | ((s[2] >> 6) & 03)))]; 1750*0Sstevel@tonic-gate hunk[3] = PL_uuemap[(077 & (s[2] & 077))]; 1751*0Sstevel@tonic-gate sv_catpvn(sv, hunk, 4); 1752*0Sstevel@tonic-gate s += 3; 1753*0Sstevel@tonic-gate len -= 3; 1754*0Sstevel@tonic-gate } 1755*0Sstevel@tonic-gate if (len > 0) { 1756*0Sstevel@tonic-gate char r = (len > 1 ? s[1] : '\0'); 1757*0Sstevel@tonic-gate hunk[0] = PL_uuemap[(077 & (*s >> 2))]; 1758*0Sstevel@tonic-gate hunk[1] = PL_uuemap[(077 & (((*s << 4) & 060) | ((r >> 4) & 017)))]; 1759*0Sstevel@tonic-gate hunk[2] = PL_uuemap[(077 & ((r << 2) & 074))]; 1760*0Sstevel@tonic-gate hunk[3] = PL_uuemap[0]; 1761*0Sstevel@tonic-gate sv_catpvn(sv, hunk, 4); 1762*0Sstevel@tonic-gate } 1763*0Sstevel@tonic-gate sv_catpvn(sv, "\n", 1); 1764*0Sstevel@tonic-gate } 1765*0Sstevel@tonic-gate 1766*0Sstevel@tonic-gate STATIC SV * 1767*0Sstevel@tonic-gate S_is_an_int(pTHX_ char *s, STRLEN l) 1768*0Sstevel@tonic-gate { 1769*0Sstevel@tonic-gate STRLEN n_a; 1770*0Sstevel@tonic-gate SV *result = newSVpvn(s, l); 1771*0Sstevel@tonic-gate char *result_c = SvPV(result, n_a); /* convenience */ 1772*0Sstevel@tonic-gate char *out = result_c; 1773*0Sstevel@tonic-gate bool skip = 1; 1774*0Sstevel@tonic-gate bool ignore = 0; 1775*0Sstevel@tonic-gate 1776*0Sstevel@tonic-gate while (*s) { 1777*0Sstevel@tonic-gate switch (*s) { 1778*0Sstevel@tonic-gate case ' ': 1779*0Sstevel@tonic-gate break; 1780*0Sstevel@tonic-gate case '+': 1781*0Sstevel@tonic-gate if (!skip) { 1782*0Sstevel@tonic-gate SvREFCNT_dec(result); 1783*0Sstevel@tonic-gate return (NULL); 1784*0Sstevel@tonic-gate } 1785*0Sstevel@tonic-gate break; 1786*0Sstevel@tonic-gate case '0': 1787*0Sstevel@tonic-gate case '1': 1788*0Sstevel@tonic-gate case '2': 1789*0Sstevel@tonic-gate case '3': 1790*0Sstevel@tonic-gate case '4': 1791*0Sstevel@tonic-gate case '5': 1792*0Sstevel@tonic-gate case '6': 1793*0Sstevel@tonic-gate case '7': 1794*0Sstevel@tonic-gate case '8': 1795*0Sstevel@tonic-gate case '9': 1796*0Sstevel@tonic-gate skip = 0; 1797*0Sstevel@tonic-gate if (!ignore) { 1798*0Sstevel@tonic-gate *(out++) = *s; 1799*0Sstevel@tonic-gate } 1800*0Sstevel@tonic-gate break; 1801*0Sstevel@tonic-gate case '.': 1802*0Sstevel@tonic-gate ignore = 1; 1803*0Sstevel@tonic-gate break; 1804*0Sstevel@tonic-gate default: 1805*0Sstevel@tonic-gate SvREFCNT_dec(result); 1806*0Sstevel@tonic-gate return (NULL); 1807*0Sstevel@tonic-gate } 1808*0Sstevel@tonic-gate s++; 1809*0Sstevel@tonic-gate } 1810*0Sstevel@tonic-gate *(out++) = '\0'; 1811*0Sstevel@tonic-gate SvCUR_set(result, out - result_c); 1812*0Sstevel@tonic-gate return (result); 1813*0Sstevel@tonic-gate } 1814*0Sstevel@tonic-gate 1815*0Sstevel@tonic-gate /* pnum must be '\0' terminated */ 1816*0Sstevel@tonic-gate STATIC int 1817*0Sstevel@tonic-gate S_div128(pTHX_ SV *pnum, bool *done) 1818*0Sstevel@tonic-gate { 1819*0Sstevel@tonic-gate STRLEN len; 1820*0Sstevel@tonic-gate char *s = SvPV(pnum, len); 1821*0Sstevel@tonic-gate int m = 0; 1822*0Sstevel@tonic-gate int r = 0; 1823*0Sstevel@tonic-gate char *t = s; 1824*0Sstevel@tonic-gate 1825*0Sstevel@tonic-gate *done = 1; 1826*0Sstevel@tonic-gate while (*t) { 1827*0Sstevel@tonic-gate int i; 1828*0Sstevel@tonic-gate 1829*0Sstevel@tonic-gate i = m * 10 + (*t - '0'); 1830*0Sstevel@tonic-gate m = i & 0x7F; 1831*0Sstevel@tonic-gate r = (i >> 7); /* r < 10 */ 1832*0Sstevel@tonic-gate if (r) { 1833*0Sstevel@tonic-gate *done = 0; 1834*0Sstevel@tonic-gate } 1835*0Sstevel@tonic-gate *(t++) = '0' + r; 1836*0Sstevel@tonic-gate } 1837*0Sstevel@tonic-gate *(t++) = '\0'; 1838*0Sstevel@tonic-gate SvCUR_set(pnum, (STRLEN) (t - s)); 1839*0Sstevel@tonic-gate return (m); 1840*0Sstevel@tonic-gate } 1841*0Sstevel@tonic-gate 1842*0Sstevel@tonic-gate 1843*0Sstevel@tonic-gate 1844*0Sstevel@tonic-gate /* 1845*0Sstevel@tonic-gate =for apidoc pack_cat 1846*0Sstevel@tonic-gate 1847*0Sstevel@tonic-gate The engine implementing pack() Perl function. Note: parameters next_in_list and 1848*0Sstevel@tonic-gate flags are not used. This call should not be used; use packlist instead. 1849*0Sstevel@tonic-gate 1850*0Sstevel@tonic-gate =cut */ 1851*0Sstevel@tonic-gate 1852*0Sstevel@tonic-gate 1853*0Sstevel@tonic-gate void 1854*0Sstevel@tonic-gate Perl_pack_cat(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist, SV ***next_in_list, U32 flags) 1855*0Sstevel@tonic-gate { 1856*0Sstevel@tonic-gate tempsym_t sym = { 0 }; 1857*0Sstevel@tonic-gate sym.patptr = pat; 1858*0Sstevel@tonic-gate sym.patend = patend; 1859*0Sstevel@tonic-gate sym.flags = FLAG_PACK; 1860*0Sstevel@tonic-gate 1861*0Sstevel@tonic-gate (void)pack_rec( cat, &sym, beglist, endlist ); 1862*0Sstevel@tonic-gate } 1863*0Sstevel@tonic-gate 1864*0Sstevel@tonic-gate 1865*0Sstevel@tonic-gate /* 1866*0Sstevel@tonic-gate =for apidoc packlist 1867*0Sstevel@tonic-gate 1868*0Sstevel@tonic-gate The engine implementing pack() Perl function. 1869*0Sstevel@tonic-gate 1870*0Sstevel@tonic-gate =cut */ 1871*0Sstevel@tonic-gate 1872*0Sstevel@tonic-gate 1873*0Sstevel@tonic-gate void 1874*0Sstevel@tonic-gate Perl_packlist(pTHX_ SV *cat, char *pat, register char *patend, register SV **beglist, SV **endlist ) 1875*0Sstevel@tonic-gate { 1876*0Sstevel@tonic-gate tempsym_t sym = { 0 }; 1877*0Sstevel@tonic-gate sym.patptr = pat; 1878*0Sstevel@tonic-gate sym.patend = patend; 1879*0Sstevel@tonic-gate sym.flags = FLAG_PACK; 1880*0Sstevel@tonic-gate 1881*0Sstevel@tonic-gate (void)pack_rec( cat, &sym, beglist, endlist ); 1882*0Sstevel@tonic-gate } 1883*0Sstevel@tonic-gate 1884*0Sstevel@tonic-gate 1885*0Sstevel@tonic-gate STATIC 1886*0Sstevel@tonic-gate SV ** 1887*0Sstevel@tonic-gate S_pack_rec(pTHX_ SV *cat, register tempsym_t* symptr, register SV **beglist, SV **endlist ) 1888*0Sstevel@tonic-gate { 1889*0Sstevel@tonic-gate register I32 items; 1890*0Sstevel@tonic-gate STRLEN fromlen; 1891*0Sstevel@tonic-gate register I32 len = 0; 1892*0Sstevel@tonic-gate SV *fromstr; 1893*0Sstevel@tonic-gate /*SUPPRESS 442*/ 1894*0Sstevel@tonic-gate static char null10[] = {0,0,0,0,0,0,0,0,0,0}; 1895*0Sstevel@tonic-gate static char *space10 = " "; 1896*0Sstevel@tonic-gate bool found; 1897*0Sstevel@tonic-gate 1898*0Sstevel@tonic-gate /* These must not be in registers: */ 1899*0Sstevel@tonic-gate char achar; 1900*0Sstevel@tonic-gate I16 ashort; 1901*0Sstevel@tonic-gate int aint; 1902*0Sstevel@tonic-gate unsigned int auint; 1903*0Sstevel@tonic-gate I32 along; 1904*0Sstevel@tonic-gate U32 aulong; 1905*0Sstevel@tonic-gate IV aiv; 1906*0Sstevel@tonic-gate UV auv; 1907*0Sstevel@tonic-gate NV anv; 1908*0Sstevel@tonic-gate #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 1909*0Sstevel@tonic-gate long double aldouble; 1910*0Sstevel@tonic-gate #endif 1911*0Sstevel@tonic-gate #ifdef HAS_QUAD 1912*0Sstevel@tonic-gate Quad_t aquad; 1913*0Sstevel@tonic-gate Uquad_t auquad; 1914*0Sstevel@tonic-gate #endif 1915*0Sstevel@tonic-gate char *aptr; 1916*0Sstevel@tonic-gate float afloat; 1917*0Sstevel@tonic-gate double adouble; 1918*0Sstevel@tonic-gate int strrelbeg = SvCUR(cat); 1919*0Sstevel@tonic-gate tempsym_t lookahead; 1920*0Sstevel@tonic-gate 1921*0Sstevel@tonic-gate items = endlist - beglist; 1922*0Sstevel@tonic-gate found = next_symbol( symptr ); 1923*0Sstevel@tonic-gate 1924*0Sstevel@tonic-gate #ifndef PACKED_IS_OCTETS 1925*0Sstevel@tonic-gate if (symptr->level == 0 && found && symptr->code == 'U' ){ 1926*0Sstevel@tonic-gate SvUTF8_on(cat); 1927*0Sstevel@tonic-gate } 1928*0Sstevel@tonic-gate #endif 1929*0Sstevel@tonic-gate 1930*0Sstevel@tonic-gate while (found) { 1931*0Sstevel@tonic-gate SV *lengthcode = Nullsv; 1932*0Sstevel@tonic-gate #define NEXTFROM ( lengthcode ? lengthcode : items-- > 0 ? *beglist++ : &PL_sv_no) 1933*0Sstevel@tonic-gate 1934*0Sstevel@tonic-gate I32 datumtype = symptr->code; 1935*0Sstevel@tonic-gate howlen_t howlen; 1936*0Sstevel@tonic-gate 1937*0Sstevel@tonic-gate switch( howlen = symptr->howlen ){ 1938*0Sstevel@tonic-gate case e_no_len: 1939*0Sstevel@tonic-gate case e_number: 1940*0Sstevel@tonic-gate len = symptr->length; 1941*0Sstevel@tonic-gate break; 1942*0Sstevel@tonic-gate case e_star: 1943*0Sstevel@tonic-gate len = strchr("@Xxu", datumtype) ? 0 : items; 1944*0Sstevel@tonic-gate break; 1945*0Sstevel@tonic-gate } 1946*0Sstevel@tonic-gate 1947*0Sstevel@tonic-gate /* Look ahead for next symbol. Do we have code/code? */ 1948*0Sstevel@tonic-gate lookahead = *symptr; 1949*0Sstevel@tonic-gate found = next_symbol(&lookahead); 1950*0Sstevel@tonic-gate if ( symptr->flags & FLAG_SLASH ) { 1951*0Sstevel@tonic-gate if (found){ 1952*0Sstevel@tonic-gate if ( 0 == strchr( "aAZ", lookahead.code ) || 1953*0Sstevel@tonic-gate e_star != lookahead.howlen ) 1954*0Sstevel@tonic-gate Perl_croak(aTHX_ "'/' must be followed by 'a*', 'A*' or 'Z*' in pack"); 1955*0Sstevel@tonic-gate lengthcode = sv_2mortal(newSViv(sv_len(items > 0 1956*0Sstevel@tonic-gate ? *beglist : &PL_sv_no) 1957*0Sstevel@tonic-gate + (lookahead.code == 'Z' ? 1 : 0))); 1958*0Sstevel@tonic-gate } else { 1959*0Sstevel@tonic-gate Perl_croak(aTHX_ "Code missing after '/' in pack"); 1960*0Sstevel@tonic-gate } 1961*0Sstevel@tonic-gate } 1962*0Sstevel@tonic-gate 1963*0Sstevel@tonic-gate switch(datumtype) { 1964*0Sstevel@tonic-gate default: 1965*0Sstevel@tonic-gate Perl_croak(aTHX_ "Invalid type '%c' in pack", (int)datumtype); 1966*0Sstevel@tonic-gate case '%': 1967*0Sstevel@tonic-gate Perl_croak(aTHX_ "'%%' may not be used in pack"); 1968*0Sstevel@tonic-gate case '@': 1969*0Sstevel@tonic-gate len += strrelbeg - SvCUR(cat); 1970*0Sstevel@tonic-gate if (len > 0) 1971*0Sstevel@tonic-gate goto grow; 1972*0Sstevel@tonic-gate len = -len; 1973*0Sstevel@tonic-gate if (len > 0) 1974*0Sstevel@tonic-gate goto shrink; 1975*0Sstevel@tonic-gate break; 1976*0Sstevel@tonic-gate case '(': 1977*0Sstevel@tonic-gate { 1978*0Sstevel@tonic-gate tempsym_t savsym = *symptr; 1979*0Sstevel@tonic-gate symptr->patend = savsym.grpend; 1980*0Sstevel@tonic-gate symptr->level++; 1981*0Sstevel@tonic-gate while (len--) { 1982*0Sstevel@tonic-gate symptr->patptr = savsym.grpbeg; 1983*0Sstevel@tonic-gate beglist = pack_rec(cat, symptr, beglist, endlist ); 1984*0Sstevel@tonic-gate if (savsym.howlen == e_star && beglist == endlist) 1985*0Sstevel@tonic-gate break; /* No way to continue */ 1986*0Sstevel@tonic-gate } 1987*0Sstevel@tonic-gate lookahead.flags = symptr->flags; 1988*0Sstevel@tonic-gate *symptr = savsym; 1989*0Sstevel@tonic-gate break; 1990*0Sstevel@tonic-gate } 1991*0Sstevel@tonic-gate case 'X' | TYPE_IS_SHRIEKING: 1992*0Sstevel@tonic-gate if (!len) /* Avoid division by 0 */ 1993*0Sstevel@tonic-gate len = 1; 1994*0Sstevel@tonic-gate len = (SvCUR(cat)) % len; 1995*0Sstevel@tonic-gate /* FALL THROUGH */ 1996*0Sstevel@tonic-gate case 'X': 1997*0Sstevel@tonic-gate shrink: 1998*0Sstevel@tonic-gate if ((I32)SvCUR(cat) < len) 1999*0Sstevel@tonic-gate Perl_croak(aTHX_ "'X' outside of string in pack"); 2000*0Sstevel@tonic-gate SvCUR(cat) -= len; 2001*0Sstevel@tonic-gate *SvEND(cat) = '\0'; 2002*0Sstevel@tonic-gate break; 2003*0Sstevel@tonic-gate case 'x' | TYPE_IS_SHRIEKING: 2004*0Sstevel@tonic-gate if (!len) /* Avoid division by 0 */ 2005*0Sstevel@tonic-gate len = 1; 2006*0Sstevel@tonic-gate aint = (SvCUR(cat)) % len; 2007*0Sstevel@tonic-gate if (aint) /* Other portable ways? */ 2008*0Sstevel@tonic-gate len = len - aint; 2009*0Sstevel@tonic-gate else 2010*0Sstevel@tonic-gate len = 0; 2011*0Sstevel@tonic-gate /* FALL THROUGH */ 2012*0Sstevel@tonic-gate 2013*0Sstevel@tonic-gate case 'x': 2014*0Sstevel@tonic-gate grow: 2015*0Sstevel@tonic-gate while (len >= 10) { 2016*0Sstevel@tonic-gate sv_catpvn(cat, null10, 10); 2017*0Sstevel@tonic-gate len -= 10; 2018*0Sstevel@tonic-gate } 2019*0Sstevel@tonic-gate sv_catpvn(cat, null10, len); 2020*0Sstevel@tonic-gate break; 2021*0Sstevel@tonic-gate case 'A': 2022*0Sstevel@tonic-gate case 'Z': 2023*0Sstevel@tonic-gate case 'a': 2024*0Sstevel@tonic-gate fromstr = NEXTFROM; 2025*0Sstevel@tonic-gate aptr = SvPV(fromstr, fromlen); 2026*0Sstevel@tonic-gate if (howlen == e_star) { 2027*0Sstevel@tonic-gate len = fromlen; 2028*0Sstevel@tonic-gate if (datumtype == 'Z') 2029*0Sstevel@tonic-gate ++len; 2030*0Sstevel@tonic-gate } 2031*0Sstevel@tonic-gate if ((I32)fromlen >= len) { 2032*0Sstevel@tonic-gate sv_catpvn(cat, aptr, len); 2033*0Sstevel@tonic-gate if (datumtype == 'Z') 2034*0Sstevel@tonic-gate *(SvEND(cat)-1) = '\0'; 2035*0Sstevel@tonic-gate } 2036*0Sstevel@tonic-gate else { 2037*0Sstevel@tonic-gate sv_catpvn(cat, aptr, fromlen); 2038*0Sstevel@tonic-gate len -= fromlen; 2039*0Sstevel@tonic-gate if (datumtype == 'A') { 2040*0Sstevel@tonic-gate while (len >= 10) { 2041*0Sstevel@tonic-gate sv_catpvn(cat, space10, 10); 2042*0Sstevel@tonic-gate len -= 10; 2043*0Sstevel@tonic-gate } 2044*0Sstevel@tonic-gate sv_catpvn(cat, space10, len); 2045*0Sstevel@tonic-gate } 2046*0Sstevel@tonic-gate else { 2047*0Sstevel@tonic-gate while (len >= 10) { 2048*0Sstevel@tonic-gate sv_catpvn(cat, null10, 10); 2049*0Sstevel@tonic-gate len -= 10; 2050*0Sstevel@tonic-gate } 2051*0Sstevel@tonic-gate sv_catpvn(cat, null10, len); 2052*0Sstevel@tonic-gate } 2053*0Sstevel@tonic-gate } 2054*0Sstevel@tonic-gate break; 2055*0Sstevel@tonic-gate case 'B': 2056*0Sstevel@tonic-gate case 'b': 2057*0Sstevel@tonic-gate { 2058*0Sstevel@tonic-gate register char *str; 2059*0Sstevel@tonic-gate I32 saveitems; 2060*0Sstevel@tonic-gate 2061*0Sstevel@tonic-gate fromstr = NEXTFROM; 2062*0Sstevel@tonic-gate saveitems = items; 2063*0Sstevel@tonic-gate str = SvPV(fromstr, fromlen); 2064*0Sstevel@tonic-gate if (howlen == e_star) 2065*0Sstevel@tonic-gate len = fromlen; 2066*0Sstevel@tonic-gate aint = SvCUR(cat); 2067*0Sstevel@tonic-gate SvCUR(cat) += (len+7)/8; 2068*0Sstevel@tonic-gate SvGROW(cat, SvCUR(cat) + 1); 2069*0Sstevel@tonic-gate aptr = SvPVX(cat) + aint; 2070*0Sstevel@tonic-gate if (len > (I32)fromlen) 2071*0Sstevel@tonic-gate len = fromlen; 2072*0Sstevel@tonic-gate aint = len; 2073*0Sstevel@tonic-gate items = 0; 2074*0Sstevel@tonic-gate if (datumtype == 'B') { 2075*0Sstevel@tonic-gate for (len = 0; len++ < aint;) { 2076*0Sstevel@tonic-gate items |= *str++ & 1; 2077*0Sstevel@tonic-gate if (len & 7) 2078*0Sstevel@tonic-gate items <<= 1; 2079*0Sstevel@tonic-gate else { 2080*0Sstevel@tonic-gate *aptr++ = items & 0xff; 2081*0Sstevel@tonic-gate items = 0; 2082*0Sstevel@tonic-gate } 2083*0Sstevel@tonic-gate } 2084*0Sstevel@tonic-gate } 2085*0Sstevel@tonic-gate else { 2086*0Sstevel@tonic-gate for (len = 0; len++ < aint;) { 2087*0Sstevel@tonic-gate if (*str++ & 1) 2088*0Sstevel@tonic-gate items |= 128; 2089*0Sstevel@tonic-gate if (len & 7) 2090*0Sstevel@tonic-gate items >>= 1; 2091*0Sstevel@tonic-gate else { 2092*0Sstevel@tonic-gate *aptr++ = items & 0xff; 2093*0Sstevel@tonic-gate items = 0; 2094*0Sstevel@tonic-gate } 2095*0Sstevel@tonic-gate } 2096*0Sstevel@tonic-gate } 2097*0Sstevel@tonic-gate if (aint & 7) { 2098*0Sstevel@tonic-gate if (datumtype == 'B') 2099*0Sstevel@tonic-gate items <<= 7 - (aint & 7); 2100*0Sstevel@tonic-gate else 2101*0Sstevel@tonic-gate items >>= 7 - (aint & 7); 2102*0Sstevel@tonic-gate *aptr++ = items & 0xff; 2103*0Sstevel@tonic-gate } 2104*0Sstevel@tonic-gate str = SvPVX(cat) + SvCUR(cat); 2105*0Sstevel@tonic-gate while (aptr <= str) 2106*0Sstevel@tonic-gate *aptr++ = '\0'; 2107*0Sstevel@tonic-gate 2108*0Sstevel@tonic-gate items = saveitems; 2109*0Sstevel@tonic-gate } 2110*0Sstevel@tonic-gate break; 2111*0Sstevel@tonic-gate case 'H': 2112*0Sstevel@tonic-gate case 'h': 2113*0Sstevel@tonic-gate { 2114*0Sstevel@tonic-gate register char *str; 2115*0Sstevel@tonic-gate I32 saveitems; 2116*0Sstevel@tonic-gate 2117*0Sstevel@tonic-gate fromstr = NEXTFROM; 2118*0Sstevel@tonic-gate saveitems = items; 2119*0Sstevel@tonic-gate str = SvPV(fromstr, fromlen); 2120*0Sstevel@tonic-gate if (howlen == e_star) 2121*0Sstevel@tonic-gate len = fromlen; 2122*0Sstevel@tonic-gate aint = SvCUR(cat); 2123*0Sstevel@tonic-gate SvCUR(cat) += (len+1)/2; 2124*0Sstevel@tonic-gate SvGROW(cat, SvCUR(cat) + 1); 2125*0Sstevel@tonic-gate aptr = SvPVX(cat) + aint; 2126*0Sstevel@tonic-gate if (len > (I32)fromlen) 2127*0Sstevel@tonic-gate len = fromlen; 2128*0Sstevel@tonic-gate aint = len; 2129*0Sstevel@tonic-gate items = 0; 2130*0Sstevel@tonic-gate if (datumtype == 'H') { 2131*0Sstevel@tonic-gate for (len = 0; len++ < aint;) { 2132*0Sstevel@tonic-gate if (isALPHA(*str)) 2133*0Sstevel@tonic-gate items |= ((*str++ & 15) + 9) & 15; 2134*0Sstevel@tonic-gate else 2135*0Sstevel@tonic-gate items |= *str++ & 15; 2136*0Sstevel@tonic-gate if (len & 1) 2137*0Sstevel@tonic-gate items <<= 4; 2138*0Sstevel@tonic-gate else { 2139*0Sstevel@tonic-gate *aptr++ = items & 0xff; 2140*0Sstevel@tonic-gate items = 0; 2141*0Sstevel@tonic-gate } 2142*0Sstevel@tonic-gate } 2143*0Sstevel@tonic-gate } 2144*0Sstevel@tonic-gate else { 2145*0Sstevel@tonic-gate for (len = 0; len++ < aint;) { 2146*0Sstevel@tonic-gate if (isALPHA(*str)) 2147*0Sstevel@tonic-gate items |= (((*str++ & 15) + 9) & 15) << 4; 2148*0Sstevel@tonic-gate else 2149*0Sstevel@tonic-gate items |= (*str++ & 15) << 4; 2150*0Sstevel@tonic-gate if (len & 1) 2151*0Sstevel@tonic-gate items >>= 4; 2152*0Sstevel@tonic-gate else { 2153*0Sstevel@tonic-gate *aptr++ = items & 0xff; 2154*0Sstevel@tonic-gate items = 0; 2155*0Sstevel@tonic-gate } 2156*0Sstevel@tonic-gate } 2157*0Sstevel@tonic-gate } 2158*0Sstevel@tonic-gate if (aint & 1) 2159*0Sstevel@tonic-gate *aptr++ = items & 0xff; 2160*0Sstevel@tonic-gate str = SvPVX(cat) + SvCUR(cat); 2161*0Sstevel@tonic-gate while (aptr <= str) 2162*0Sstevel@tonic-gate *aptr++ = '\0'; 2163*0Sstevel@tonic-gate 2164*0Sstevel@tonic-gate items = saveitems; 2165*0Sstevel@tonic-gate } 2166*0Sstevel@tonic-gate break; 2167*0Sstevel@tonic-gate case 'C': 2168*0Sstevel@tonic-gate case 'c': 2169*0Sstevel@tonic-gate while (len-- > 0) { 2170*0Sstevel@tonic-gate fromstr = NEXTFROM; 2171*0Sstevel@tonic-gate switch (datumtype) { 2172*0Sstevel@tonic-gate case 'C': 2173*0Sstevel@tonic-gate aint = SvIV(fromstr); 2174*0Sstevel@tonic-gate if ((aint < 0 || aint > 255) && 2175*0Sstevel@tonic-gate ckWARN(WARN_PACK)) 2176*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PACK), 2177*0Sstevel@tonic-gate "Character in 'C' format wrapped in pack"); 2178*0Sstevel@tonic-gate achar = aint & 255; 2179*0Sstevel@tonic-gate sv_catpvn(cat, &achar, sizeof(char)); 2180*0Sstevel@tonic-gate break; 2181*0Sstevel@tonic-gate case 'c': 2182*0Sstevel@tonic-gate aint = SvIV(fromstr); 2183*0Sstevel@tonic-gate if ((aint < -128 || aint > 127) && 2184*0Sstevel@tonic-gate ckWARN(WARN_PACK)) 2185*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PACK), 2186*0Sstevel@tonic-gate "Character in 'c' format wrapped in pack" ); 2187*0Sstevel@tonic-gate achar = aint & 255; 2188*0Sstevel@tonic-gate sv_catpvn(cat, &achar, sizeof(char)); 2189*0Sstevel@tonic-gate break; 2190*0Sstevel@tonic-gate } 2191*0Sstevel@tonic-gate } 2192*0Sstevel@tonic-gate break; 2193*0Sstevel@tonic-gate case 'U': 2194*0Sstevel@tonic-gate while (len-- > 0) { 2195*0Sstevel@tonic-gate fromstr = NEXTFROM; 2196*0Sstevel@tonic-gate auint = UNI_TO_NATIVE(SvUV(fromstr)); 2197*0Sstevel@tonic-gate SvGROW(cat, SvCUR(cat) + UTF8_MAXLEN + 1); 2198*0Sstevel@tonic-gate SvCUR_set(cat, 2199*0Sstevel@tonic-gate (char*)uvchr_to_utf8_flags((U8*)SvEND(cat), 2200*0Sstevel@tonic-gate auint, 2201*0Sstevel@tonic-gate ckWARN(WARN_UTF8) ? 2202*0Sstevel@tonic-gate 0 : UNICODE_ALLOW_ANY) 2203*0Sstevel@tonic-gate - SvPVX(cat)); 2204*0Sstevel@tonic-gate } 2205*0Sstevel@tonic-gate *SvEND(cat) = '\0'; 2206*0Sstevel@tonic-gate break; 2207*0Sstevel@tonic-gate /* Float and double added by gnb@melba.bby.oz.au 22/11/89 */ 2208*0Sstevel@tonic-gate case 'f': 2209*0Sstevel@tonic-gate while (len-- > 0) { 2210*0Sstevel@tonic-gate fromstr = NEXTFROM; 2211*0Sstevel@tonic-gate #ifdef __VOS__ 2212*0Sstevel@tonic-gate /* VOS does not automatically map a floating-point overflow 2213*0Sstevel@tonic-gate during conversion from double to float into infinity, so we 2214*0Sstevel@tonic-gate do it by hand. This code should either be generalized for 2215*0Sstevel@tonic-gate any OS that needs it, or removed if and when VOS implements 2216*0Sstevel@tonic-gate posix-976 (suggestion to support mapping to infinity). 2217*0Sstevel@tonic-gate Paul.Green@stratus.com 02-04-02. */ 2218*0Sstevel@tonic-gate if (SvNV(fromstr) > FLT_MAX) 2219*0Sstevel@tonic-gate afloat = _float_constants[0]; /* single prec. inf. */ 2220*0Sstevel@tonic-gate else if (SvNV(fromstr) < -FLT_MAX) 2221*0Sstevel@tonic-gate afloat = _float_constants[0]; /* single prec. inf. */ 2222*0Sstevel@tonic-gate else afloat = (float)SvNV(fromstr); 2223*0Sstevel@tonic-gate #else 2224*0Sstevel@tonic-gate # if defined(VMS) && !defined(__IEEE_FP) 2225*0Sstevel@tonic-gate /* IEEE fp overflow shenanigans are unavailable on VAX and optional 2226*0Sstevel@tonic-gate * on Alpha; fake it if we don't have them. 2227*0Sstevel@tonic-gate */ 2228*0Sstevel@tonic-gate if (SvNV(fromstr) > FLT_MAX) 2229*0Sstevel@tonic-gate afloat = FLT_MAX; 2230*0Sstevel@tonic-gate else if (SvNV(fromstr) < -FLT_MAX) 2231*0Sstevel@tonic-gate afloat = -FLT_MAX; 2232*0Sstevel@tonic-gate else afloat = (float)SvNV(fromstr); 2233*0Sstevel@tonic-gate # else 2234*0Sstevel@tonic-gate afloat = (float)SvNV(fromstr); 2235*0Sstevel@tonic-gate # endif 2236*0Sstevel@tonic-gate #endif 2237*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&afloat, sizeof (float)); 2238*0Sstevel@tonic-gate } 2239*0Sstevel@tonic-gate break; 2240*0Sstevel@tonic-gate case 'd': 2241*0Sstevel@tonic-gate while (len-- > 0) { 2242*0Sstevel@tonic-gate fromstr = NEXTFROM; 2243*0Sstevel@tonic-gate #ifdef __VOS__ 2244*0Sstevel@tonic-gate /* VOS does not automatically map a floating-point overflow 2245*0Sstevel@tonic-gate during conversion from long double to double into infinity, 2246*0Sstevel@tonic-gate so we do it by hand. This code should either be generalized 2247*0Sstevel@tonic-gate for any OS that needs it, or removed if and when VOS 2248*0Sstevel@tonic-gate implements posix-976 (suggestion to support mapping to 2249*0Sstevel@tonic-gate infinity). Paul.Green@stratus.com 02-04-02. */ 2250*0Sstevel@tonic-gate if (SvNV(fromstr) > DBL_MAX) 2251*0Sstevel@tonic-gate adouble = _double_constants[0]; /* double prec. inf. */ 2252*0Sstevel@tonic-gate else if (SvNV(fromstr) < -DBL_MAX) 2253*0Sstevel@tonic-gate adouble = _double_constants[0]; /* double prec. inf. */ 2254*0Sstevel@tonic-gate else adouble = (double)SvNV(fromstr); 2255*0Sstevel@tonic-gate #else 2256*0Sstevel@tonic-gate # if defined(VMS) && !defined(__IEEE_FP) 2257*0Sstevel@tonic-gate /* IEEE fp overflow shenanigans are unavailable on VAX and optional 2258*0Sstevel@tonic-gate * on Alpha; fake it if we don't have them. 2259*0Sstevel@tonic-gate */ 2260*0Sstevel@tonic-gate if (SvNV(fromstr) > DBL_MAX) 2261*0Sstevel@tonic-gate adouble = DBL_MAX; 2262*0Sstevel@tonic-gate else if (SvNV(fromstr) < -DBL_MAX) 2263*0Sstevel@tonic-gate adouble = -DBL_MAX; 2264*0Sstevel@tonic-gate else adouble = (double)SvNV(fromstr); 2265*0Sstevel@tonic-gate # else 2266*0Sstevel@tonic-gate adouble = (double)SvNV(fromstr); 2267*0Sstevel@tonic-gate # endif 2268*0Sstevel@tonic-gate #endif 2269*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&adouble, sizeof (double)); 2270*0Sstevel@tonic-gate } 2271*0Sstevel@tonic-gate break; 2272*0Sstevel@tonic-gate case 'F': 2273*0Sstevel@tonic-gate while (len-- > 0) { 2274*0Sstevel@tonic-gate fromstr = NEXTFROM; 2275*0Sstevel@tonic-gate anv = SvNV(fromstr); 2276*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&anv, NVSIZE); 2277*0Sstevel@tonic-gate } 2278*0Sstevel@tonic-gate break; 2279*0Sstevel@tonic-gate #if defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE) 2280*0Sstevel@tonic-gate case 'D': 2281*0Sstevel@tonic-gate while (len-- > 0) { 2282*0Sstevel@tonic-gate fromstr = NEXTFROM; 2283*0Sstevel@tonic-gate aldouble = (long double)SvNV(fromstr); 2284*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&aldouble, LONG_DOUBLESIZE); 2285*0Sstevel@tonic-gate } 2286*0Sstevel@tonic-gate break; 2287*0Sstevel@tonic-gate #endif 2288*0Sstevel@tonic-gate case 'n': 2289*0Sstevel@tonic-gate while (len-- > 0) { 2290*0Sstevel@tonic-gate fromstr = NEXTFROM; 2291*0Sstevel@tonic-gate ashort = (I16)SvIV(fromstr); 2292*0Sstevel@tonic-gate #ifdef HAS_HTONS 2293*0Sstevel@tonic-gate ashort = PerlSock_htons(ashort); 2294*0Sstevel@tonic-gate #endif 2295*0Sstevel@tonic-gate CAT16(cat, &ashort); 2296*0Sstevel@tonic-gate } 2297*0Sstevel@tonic-gate break; 2298*0Sstevel@tonic-gate case 'v': 2299*0Sstevel@tonic-gate while (len-- > 0) { 2300*0Sstevel@tonic-gate fromstr = NEXTFROM; 2301*0Sstevel@tonic-gate ashort = (I16)SvIV(fromstr); 2302*0Sstevel@tonic-gate #ifdef HAS_HTOVS 2303*0Sstevel@tonic-gate ashort = htovs(ashort); 2304*0Sstevel@tonic-gate #endif 2305*0Sstevel@tonic-gate CAT16(cat, &ashort); 2306*0Sstevel@tonic-gate } 2307*0Sstevel@tonic-gate break; 2308*0Sstevel@tonic-gate case 'S' | TYPE_IS_SHRIEKING: 2309*0Sstevel@tonic-gate #if SHORTSIZE != SIZE16 2310*0Sstevel@tonic-gate { 2311*0Sstevel@tonic-gate unsigned short aushort; 2312*0Sstevel@tonic-gate 2313*0Sstevel@tonic-gate while (len-- > 0) { 2314*0Sstevel@tonic-gate fromstr = NEXTFROM; 2315*0Sstevel@tonic-gate aushort = SvUV(fromstr); 2316*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&aushort, sizeof(unsigned short)); 2317*0Sstevel@tonic-gate } 2318*0Sstevel@tonic-gate } 2319*0Sstevel@tonic-gate break; 2320*0Sstevel@tonic-gate #else 2321*0Sstevel@tonic-gate /* Fall through! */ 2322*0Sstevel@tonic-gate #endif 2323*0Sstevel@tonic-gate case 'S': 2324*0Sstevel@tonic-gate { 2325*0Sstevel@tonic-gate U16 aushort; 2326*0Sstevel@tonic-gate 2327*0Sstevel@tonic-gate while (len-- > 0) { 2328*0Sstevel@tonic-gate fromstr = NEXTFROM; 2329*0Sstevel@tonic-gate aushort = (U16)SvUV(fromstr); 2330*0Sstevel@tonic-gate CAT16(cat, &aushort); 2331*0Sstevel@tonic-gate } 2332*0Sstevel@tonic-gate 2333*0Sstevel@tonic-gate } 2334*0Sstevel@tonic-gate break; 2335*0Sstevel@tonic-gate case 's' | TYPE_IS_SHRIEKING: 2336*0Sstevel@tonic-gate #if SHORTSIZE != SIZE16 2337*0Sstevel@tonic-gate { 2338*0Sstevel@tonic-gate short ashort; 2339*0Sstevel@tonic-gate 2340*0Sstevel@tonic-gate while (len-- > 0) { 2341*0Sstevel@tonic-gate fromstr = NEXTFROM; 2342*0Sstevel@tonic-gate ashort = SvIV(fromstr); 2343*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&ashort, sizeof(short)); 2344*0Sstevel@tonic-gate } 2345*0Sstevel@tonic-gate } 2346*0Sstevel@tonic-gate break; 2347*0Sstevel@tonic-gate #else 2348*0Sstevel@tonic-gate /* Fall through! */ 2349*0Sstevel@tonic-gate #endif 2350*0Sstevel@tonic-gate case 's': 2351*0Sstevel@tonic-gate while (len-- > 0) { 2352*0Sstevel@tonic-gate fromstr = NEXTFROM; 2353*0Sstevel@tonic-gate ashort = (I16)SvIV(fromstr); 2354*0Sstevel@tonic-gate CAT16(cat, &ashort); 2355*0Sstevel@tonic-gate } 2356*0Sstevel@tonic-gate break; 2357*0Sstevel@tonic-gate case 'I': 2358*0Sstevel@tonic-gate case 'I' | TYPE_IS_SHRIEKING: 2359*0Sstevel@tonic-gate while (len-- > 0) { 2360*0Sstevel@tonic-gate fromstr = NEXTFROM; 2361*0Sstevel@tonic-gate auint = SvUV(fromstr); 2362*0Sstevel@tonic-gate sv_catpvn(cat, (char*)&auint, sizeof(unsigned int)); 2363*0Sstevel@tonic-gate } 2364*0Sstevel@tonic-gate break; 2365*0Sstevel@tonic-gate case 'j': 2366*0Sstevel@tonic-gate while (len-- > 0) { 2367*0Sstevel@tonic-gate fromstr = NEXTFROM; 2368*0Sstevel@tonic-gate aiv = SvIV(fromstr); 2369*0Sstevel@tonic-gate sv_catpvn(cat, (char*)&aiv, IVSIZE); 2370*0Sstevel@tonic-gate } 2371*0Sstevel@tonic-gate break; 2372*0Sstevel@tonic-gate case 'J': 2373*0Sstevel@tonic-gate while (len-- > 0) { 2374*0Sstevel@tonic-gate fromstr = NEXTFROM; 2375*0Sstevel@tonic-gate auv = SvUV(fromstr); 2376*0Sstevel@tonic-gate sv_catpvn(cat, (char*)&auv, UVSIZE); 2377*0Sstevel@tonic-gate } 2378*0Sstevel@tonic-gate break; 2379*0Sstevel@tonic-gate case 'w': 2380*0Sstevel@tonic-gate while (len-- > 0) { 2381*0Sstevel@tonic-gate fromstr = NEXTFROM; 2382*0Sstevel@tonic-gate anv = SvNV(fromstr); 2383*0Sstevel@tonic-gate 2384*0Sstevel@tonic-gate if (anv < 0) 2385*0Sstevel@tonic-gate Perl_croak(aTHX_ "Cannot compress negative numbers in pack"); 2386*0Sstevel@tonic-gate 2387*0Sstevel@tonic-gate /* 0xFFFFFFFFFFFFFFFF may cast to 18446744073709551616.0, 2388*0Sstevel@tonic-gate which is == UV_MAX_P1. IOK is fine (instead of UV_only), as 2389*0Sstevel@tonic-gate any negative IVs will have already been got by the croak() 2390*0Sstevel@tonic-gate above. IOK is untrue for fractions, so we test them 2391*0Sstevel@tonic-gate against UV_MAX_P1. */ 2392*0Sstevel@tonic-gate if (SvIOK(fromstr) || anv < UV_MAX_P1) 2393*0Sstevel@tonic-gate { 2394*0Sstevel@tonic-gate char buf[(sizeof(UV)*8)/7+1]; 2395*0Sstevel@tonic-gate char *in = buf + sizeof(buf); 2396*0Sstevel@tonic-gate UV auv = SvUV(fromstr); 2397*0Sstevel@tonic-gate 2398*0Sstevel@tonic-gate do { 2399*0Sstevel@tonic-gate *--in = (char)((auv & 0x7f) | 0x80); 2400*0Sstevel@tonic-gate auv >>= 7; 2401*0Sstevel@tonic-gate } while (auv); 2402*0Sstevel@tonic-gate buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ 2403*0Sstevel@tonic-gate sv_catpvn(cat, in, (buf + sizeof(buf)) - in); 2404*0Sstevel@tonic-gate } 2405*0Sstevel@tonic-gate else if (SvPOKp(fromstr)) { /* decimal string arithmetics */ 2406*0Sstevel@tonic-gate char *from, *result, *in; 2407*0Sstevel@tonic-gate SV *norm; 2408*0Sstevel@tonic-gate STRLEN len; 2409*0Sstevel@tonic-gate bool done; 2410*0Sstevel@tonic-gate 2411*0Sstevel@tonic-gate /* Copy string and check for compliance */ 2412*0Sstevel@tonic-gate from = SvPV(fromstr, len); 2413*0Sstevel@tonic-gate if ((norm = is_an_int(from, len)) == NULL) 2414*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); 2415*0Sstevel@tonic-gate 2416*0Sstevel@tonic-gate New('w', result, len, char); 2417*0Sstevel@tonic-gate in = result + len; 2418*0Sstevel@tonic-gate done = FALSE; 2419*0Sstevel@tonic-gate while (!done) 2420*0Sstevel@tonic-gate *--in = div128(norm, &done) | 0x80; 2421*0Sstevel@tonic-gate result[len - 1] &= 0x7F; /* clear continue bit */ 2422*0Sstevel@tonic-gate sv_catpvn(cat, in, (result + len) - in); 2423*0Sstevel@tonic-gate Safefree(result); 2424*0Sstevel@tonic-gate SvREFCNT_dec(norm); /* free norm */ 2425*0Sstevel@tonic-gate } 2426*0Sstevel@tonic-gate else if (SvNOKp(fromstr)) { 2427*0Sstevel@tonic-gate /* 10**NV_MAX_10_EXP is the largest power of 10 2428*0Sstevel@tonic-gate so 10**(NV_MAX_10_EXP+1) is definately unrepresentable 2429*0Sstevel@tonic-gate given 10**(NV_MAX_10_EXP+1) == 128 ** x solve for x: 2430*0Sstevel@tonic-gate x = (NV_MAX_10_EXP+1) * log (10) / log (128) 2431*0Sstevel@tonic-gate And with that many bytes only Inf can overflow. 2432*0Sstevel@tonic-gate Some C compilers are strict about integral constant 2433*0Sstevel@tonic-gate expressions so we conservatively divide by a slightly 2434*0Sstevel@tonic-gate smaller integer instead of multiplying by the exact 2435*0Sstevel@tonic-gate floating-point value. 2436*0Sstevel@tonic-gate */ 2437*0Sstevel@tonic-gate #ifdef NV_MAX_10_EXP 2438*0Sstevel@tonic-gate /* char buf[1 + (int)((NV_MAX_10_EXP + 1) * 0.47456)]; -- invalid C */ 2439*0Sstevel@tonic-gate char buf[1 + (int)((NV_MAX_10_EXP + 1) / 2)]; /* valid C */ 2440*0Sstevel@tonic-gate #else 2441*0Sstevel@tonic-gate /* char buf[1 + (int)((308 + 1) * 0.47456)]; -- invalid C */ 2442*0Sstevel@tonic-gate char buf[1 + (int)((308 + 1) / 2)]; /* valid C */ 2443*0Sstevel@tonic-gate #endif 2444*0Sstevel@tonic-gate char *in = buf + sizeof(buf); 2445*0Sstevel@tonic-gate 2446*0Sstevel@tonic-gate anv = Perl_floor(anv); 2447*0Sstevel@tonic-gate do { 2448*0Sstevel@tonic-gate NV next = Perl_floor(anv / 128); 2449*0Sstevel@tonic-gate if (in <= buf) /* this cannot happen ;-) */ 2450*0Sstevel@tonic-gate Perl_croak(aTHX_ "Cannot compress integer in pack"); 2451*0Sstevel@tonic-gate *--in = (unsigned char)(anv - (next * 128)) | 0x80; 2452*0Sstevel@tonic-gate anv = next; 2453*0Sstevel@tonic-gate } while (anv > 0); 2454*0Sstevel@tonic-gate buf[sizeof(buf) - 1] &= 0x7f; /* clear continue bit */ 2455*0Sstevel@tonic-gate sv_catpvn(cat, in, (buf + sizeof(buf)) - in); 2456*0Sstevel@tonic-gate } 2457*0Sstevel@tonic-gate else { 2458*0Sstevel@tonic-gate char *from, *result, *in; 2459*0Sstevel@tonic-gate SV *norm; 2460*0Sstevel@tonic-gate STRLEN len; 2461*0Sstevel@tonic-gate bool done; 2462*0Sstevel@tonic-gate 2463*0Sstevel@tonic-gate /* Copy string and check for compliance */ 2464*0Sstevel@tonic-gate from = SvPV(fromstr, len); 2465*0Sstevel@tonic-gate if ((norm = is_an_int(from, len)) == NULL) 2466*0Sstevel@tonic-gate Perl_croak(aTHX_ "Can only compress unsigned integers in pack"); 2467*0Sstevel@tonic-gate 2468*0Sstevel@tonic-gate New('w', result, len, char); 2469*0Sstevel@tonic-gate in = result + len; 2470*0Sstevel@tonic-gate done = FALSE; 2471*0Sstevel@tonic-gate while (!done) 2472*0Sstevel@tonic-gate *--in = div128(norm, &done) | 0x80; 2473*0Sstevel@tonic-gate result[len - 1] &= 0x7F; /* clear continue bit */ 2474*0Sstevel@tonic-gate sv_catpvn(cat, in, (result + len) - in); 2475*0Sstevel@tonic-gate Safefree(result); 2476*0Sstevel@tonic-gate SvREFCNT_dec(norm); /* free norm */ 2477*0Sstevel@tonic-gate } 2478*0Sstevel@tonic-gate } 2479*0Sstevel@tonic-gate break; 2480*0Sstevel@tonic-gate case 'i': 2481*0Sstevel@tonic-gate case 'i' | TYPE_IS_SHRIEKING: 2482*0Sstevel@tonic-gate while (len-- > 0) { 2483*0Sstevel@tonic-gate fromstr = NEXTFROM; 2484*0Sstevel@tonic-gate aint = SvIV(fromstr); 2485*0Sstevel@tonic-gate sv_catpvn(cat, (char*)&aint, sizeof(int)); 2486*0Sstevel@tonic-gate } 2487*0Sstevel@tonic-gate break; 2488*0Sstevel@tonic-gate case 'N': 2489*0Sstevel@tonic-gate while (len-- > 0) { 2490*0Sstevel@tonic-gate fromstr = NEXTFROM; 2491*0Sstevel@tonic-gate aulong = SvUV(fromstr); 2492*0Sstevel@tonic-gate #ifdef HAS_HTONL 2493*0Sstevel@tonic-gate aulong = PerlSock_htonl(aulong); 2494*0Sstevel@tonic-gate #endif 2495*0Sstevel@tonic-gate CAT32(cat, &aulong); 2496*0Sstevel@tonic-gate } 2497*0Sstevel@tonic-gate break; 2498*0Sstevel@tonic-gate case 'V': 2499*0Sstevel@tonic-gate while (len-- > 0) { 2500*0Sstevel@tonic-gate fromstr = NEXTFROM; 2501*0Sstevel@tonic-gate aulong = SvUV(fromstr); 2502*0Sstevel@tonic-gate #ifdef HAS_HTOVL 2503*0Sstevel@tonic-gate aulong = htovl(aulong); 2504*0Sstevel@tonic-gate #endif 2505*0Sstevel@tonic-gate CAT32(cat, &aulong); 2506*0Sstevel@tonic-gate } 2507*0Sstevel@tonic-gate break; 2508*0Sstevel@tonic-gate case 'L' | TYPE_IS_SHRIEKING: 2509*0Sstevel@tonic-gate #if LONGSIZE != SIZE32 2510*0Sstevel@tonic-gate { 2511*0Sstevel@tonic-gate unsigned long aulong; 2512*0Sstevel@tonic-gate 2513*0Sstevel@tonic-gate while (len-- > 0) { 2514*0Sstevel@tonic-gate fromstr = NEXTFROM; 2515*0Sstevel@tonic-gate aulong = SvUV(fromstr); 2516*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&aulong, sizeof(unsigned long)); 2517*0Sstevel@tonic-gate } 2518*0Sstevel@tonic-gate } 2519*0Sstevel@tonic-gate break; 2520*0Sstevel@tonic-gate #else 2521*0Sstevel@tonic-gate /* Fall though! */ 2522*0Sstevel@tonic-gate #endif 2523*0Sstevel@tonic-gate case 'L': 2524*0Sstevel@tonic-gate { 2525*0Sstevel@tonic-gate while (len-- > 0) { 2526*0Sstevel@tonic-gate fromstr = NEXTFROM; 2527*0Sstevel@tonic-gate aulong = SvUV(fromstr); 2528*0Sstevel@tonic-gate CAT32(cat, &aulong); 2529*0Sstevel@tonic-gate } 2530*0Sstevel@tonic-gate } 2531*0Sstevel@tonic-gate break; 2532*0Sstevel@tonic-gate case 'l' | TYPE_IS_SHRIEKING: 2533*0Sstevel@tonic-gate #if LONGSIZE != SIZE32 2534*0Sstevel@tonic-gate { 2535*0Sstevel@tonic-gate long along; 2536*0Sstevel@tonic-gate 2537*0Sstevel@tonic-gate while (len-- > 0) { 2538*0Sstevel@tonic-gate fromstr = NEXTFROM; 2539*0Sstevel@tonic-gate along = SvIV(fromstr); 2540*0Sstevel@tonic-gate sv_catpvn(cat, (char *)&along, sizeof(long)); 2541*0Sstevel@tonic-gate } 2542*0Sstevel@tonic-gate } 2543*0Sstevel@tonic-gate break; 2544*0Sstevel@tonic-gate #else 2545*0Sstevel@tonic-gate /* Fall though! */ 2546*0Sstevel@tonic-gate #endif 2547*0Sstevel@tonic-gate case 'l': 2548*0Sstevel@tonic-gate while (len-- > 0) { 2549*0Sstevel@tonic-gate fromstr = NEXTFROM; 2550*0Sstevel@tonic-gate along = SvIV(fromstr); 2551*0Sstevel@tonic-gate CAT32(cat, &along); 2552*0Sstevel@tonic-gate } 2553*0Sstevel@tonic-gate break; 2554*0Sstevel@tonic-gate #ifdef HAS_QUAD 2555*0Sstevel@tonic-gate case 'Q': 2556*0Sstevel@tonic-gate while (len-- > 0) { 2557*0Sstevel@tonic-gate fromstr = NEXTFROM; 2558*0Sstevel@tonic-gate auquad = (Uquad_t)SvUV(fromstr); 2559*0Sstevel@tonic-gate sv_catpvn(cat, (char*)&auquad, sizeof(Uquad_t)); 2560*0Sstevel@tonic-gate } 2561*0Sstevel@tonic-gate break; 2562*0Sstevel@tonic-gate case 'q': 2563*0Sstevel@tonic-gate while (len-- > 0) { 2564*0Sstevel@tonic-gate fromstr = NEXTFROM; 2565*0Sstevel@tonic-gate aquad = (Quad_t)SvIV(fromstr); 2566*0Sstevel@tonic-gate sv_catpvn(cat, (char*)&aquad, sizeof(Quad_t)); 2567*0Sstevel@tonic-gate } 2568*0Sstevel@tonic-gate break; 2569*0Sstevel@tonic-gate #endif 2570*0Sstevel@tonic-gate case 'P': 2571*0Sstevel@tonic-gate len = 1; /* assume SV is correct length */ 2572*0Sstevel@tonic-gate /* Fall through! */ 2573*0Sstevel@tonic-gate case 'p': 2574*0Sstevel@tonic-gate while (len-- > 0) { 2575*0Sstevel@tonic-gate fromstr = NEXTFROM; 2576*0Sstevel@tonic-gate if (fromstr == &PL_sv_undef) 2577*0Sstevel@tonic-gate aptr = NULL; 2578*0Sstevel@tonic-gate else { 2579*0Sstevel@tonic-gate STRLEN n_a; 2580*0Sstevel@tonic-gate /* XXX better yet, could spirit away the string to 2581*0Sstevel@tonic-gate * a safe spot and hang on to it until the result 2582*0Sstevel@tonic-gate * of pack() (and all copies of the result) are 2583*0Sstevel@tonic-gate * gone. 2584*0Sstevel@tonic-gate */ 2585*0Sstevel@tonic-gate if (ckWARN(WARN_PACK) && (SvTEMP(fromstr) 2586*0Sstevel@tonic-gate || (SvPADTMP(fromstr) 2587*0Sstevel@tonic-gate && !SvREADONLY(fromstr)))) 2588*0Sstevel@tonic-gate { 2589*0Sstevel@tonic-gate Perl_warner(aTHX_ packWARN(WARN_PACK), 2590*0Sstevel@tonic-gate "Attempt to pack pointer to temporary value"); 2591*0Sstevel@tonic-gate } 2592*0Sstevel@tonic-gate if (SvPOK(fromstr) || SvNIOK(fromstr)) 2593*0Sstevel@tonic-gate aptr = SvPV(fromstr,n_a); 2594*0Sstevel@tonic-gate else 2595*0Sstevel@tonic-gate aptr = SvPV_force(fromstr,n_a); 2596*0Sstevel@tonic-gate } 2597*0Sstevel@tonic-gate sv_catpvn(cat, (char*)&aptr, sizeof(char*)); 2598*0Sstevel@tonic-gate } 2599*0Sstevel@tonic-gate break; 2600*0Sstevel@tonic-gate case 'u': 2601*0Sstevel@tonic-gate fromstr = NEXTFROM; 2602*0Sstevel@tonic-gate aptr = SvPV(fromstr, fromlen); 2603*0Sstevel@tonic-gate SvGROW(cat, fromlen * 4 / 3); 2604*0Sstevel@tonic-gate if (len <= 2) 2605*0Sstevel@tonic-gate len = 45; 2606*0Sstevel@tonic-gate else 2607*0Sstevel@tonic-gate len = len / 3 * 3; 2608*0Sstevel@tonic-gate while (fromlen > 0) { 2609*0Sstevel@tonic-gate I32 todo; 2610*0Sstevel@tonic-gate 2611*0Sstevel@tonic-gate if ((I32)fromlen > len) 2612*0Sstevel@tonic-gate todo = len; 2613*0Sstevel@tonic-gate else 2614*0Sstevel@tonic-gate todo = fromlen; 2615*0Sstevel@tonic-gate doencodes(cat, aptr, todo); 2616*0Sstevel@tonic-gate fromlen -= todo; 2617*0Sstevel@tonic-gate aptr += todo; 2618*0Sstevel@tonic-gate } 2619*0Sstevel@tonic-gate break; 2620*0Sstevel@tonic-gate } 2621*0Sstevel@tonic-gate *symptr = lookahead; 2622*0Sstevel@tonic-gate } 2623*0Sstevel@tonic-gate return beglist; 2624*0Sstevel@tonic-gate } 2625*0Sstevel@tonic-gate #undef NEXTFROM 2626*0Sstevel@tonic-gate 2627*0Sstevel@tonic-gate 2628*0Sstevel@tonic-gate PP(pp_pack) 2629*0Sstevel@tonic-gate { 2630*0Sstevel@tonic-gate dSP; dMARK; dORIGMARK; dTARGET; 2631*0Sstevel@tonic-gate register SV *cat = TARG; 2632*0Sstevel@tonic-gate STRLEN fromlen; 2633*0Sstevel@tonic-gate register char *pat = SvPVx(*++MARK, fromlen); 2634*0Sstevel@tonic-gate register char *patend = pat + fromlen; 2635*0Sstevel@tonic-gate 2636*0Sstevel@tonic-gate MARK++; 2637*0Sstevel@tonic-gate sv_setpvn(cat, "", 0); 2638*0Sstevel@tonic-gate 2639*0Sstevel@tonic-gate packlist(cat, pat, patend, MARK, SP + 1); 2640*0Sstevel@tonic-gate 2641*0Sstevel@tonic-gate SvSETMAGIC(cat); 2642*0Sstevel@tonic-gate SP = ORIGMARK; 2643*0Sstevel@tonic-gate PUSHs(cat); 2644*0Sstevel@tonic-gate RETURN; 2645*0Sstevel@tonic-gate } 2646*0Sstevel@tonic-gate 2647