1 ################################################################################ 2 # 3 # Copyright (c) 2002-2020 Marcus Holland-Moritz. All rights reserved. 4 # This program is free software; you can redistribute it and/or modify 5 # it under the same terms as Perl itself. 6 # 7 ################################################################################ 8 9 10 ################################################################################ 11 # 12 # METHOD: pack 13 # 14 # WRITTEN BY: Marcus Holland-Moritz ON: Jan 2002 15 # CHANGED BY: ON: 16 # 17 ################################################################################ 18 19 void 20 CBC::pack(type, data = &PL_sv_undef, string = NULL) 21 const char *type 22 SV *data 23 SV *string 24 25 PREINIT: 26 CBC_METHOD(pack); 27 char *buffer; 28 MemberInfo mi; 29 PackHandle pack; 30 SV *rv; 31 dXCPT; 32 33 CODE: 34 CT_DEBUG_METHOD1("'%s'", type); 35 36 if (string == NULL && GIMME_V == G_VOID) 37 { 38 WARN_VOID_CONTEXT; 39 XSRETURN_EMPTY; 40 } 41 42 if (string != NULL) 43 { 44 SvGETMAGIC(string); 45 46 if ((SvFLAGS(string) & (SVf_POK|SVp_POK)) == 0) 47 Perl_croak(aTHX_ "Type of arg 3 to pack must be string"); 48 49 if (GIMME_V == G_VOID && SvREADONLY(string)) 50 Perl_croak(aTHX_ "Modification of a read-only value attempted"); 51 } 52 53 NEED_PARSE_DATA; 54 55 if (!get_member_info(aTHX_ THIS, type, &mi, 0)) 56 Perl_croak(aTHX_ "Cannot find '%s'", type); 57 58 if (mi.flags) 59 WARN_FLAGS(type, mi.flags); 60 61 if (string == NULL) 62 { 63 rv = newSV(mi.size); 64 65 /* force rv into a PV when mi.size is zero (bug #3753) */ 66 if (mi.size == 0) 67 sv_grow(rv, 1); 68 69 SvPOK_only(rv); 70 SvCUR_set(rv, mi.size); 71 buffer = SvPVX(rv); 72 73 /* We get an mi.size+1 buffer from newSV. So the following */ 74 /* call will properly \0-terminate our return value. */ 75 Zero(buffer, mi.size+1, char); 76 } 77 else 78 { 79 STRLEN len = SvCUR(string); 80 STRLEN max = mi.size > len ? mi.size : len; 81 82 if (GIMME_V == G_VOID) 83 { 84 rv = NULL; 85 buffer = SvGROW(string, max+1); 86 SvCUR_set(string, max); 87 } 88 else 89 { 90 rv = newSV(max); 91 SvPOK_only(rv); 92 buffer = SvPVX(rv); 93 SvCUR_set(rv, max); 94 Copy(SvPVX(string), buffer, len, char); 95 } 96 97 if(max > len) 98 Zero(buffer+len, max+1-len, char); 99 } 100 101 pack = pk_create(THIS, ST(0)); 102 pk_set_type(pack, type); 103 pk_set_buffer(pack, rv ? rv : string, buffer, mi.size); 104 105 SvGETMAGIC(data); 106 107 XCPT_TRY_START 108 { 109 pk_pack(aTHX_ pack, &mi.type, mi.pDecl, mi.level, data); 110 } 111 XCPT_TRY_END 112 113 pk_delete(pack); 114 115 XCPT_CATCH 116 { 117 if (rv) 118 SvREFCNT_dec(rv); 119 120 XCPT_RETHROW; 121 } 122 123 /* this makes substr() as third argument work */ 124 if (string) 125 SvSETMAGIC(string); 126 127 if (rv == NULL) 128 XSRETURN_EMPTY; 129 130 ST(0) = sv_2mortal(rv); 131 XSRETURN(1); 132 133 134 ################################################################################ 135 # 136 # METHOD: unpack 137 # 138 # WRITTEN BY: Marcus Holland-Moritz ON: Jan 2002 139 # CHANGED BY: ON: 140 # 141 ################################################################################ 142 143 void 144 CBC::unpack(type, string) 145 const char *type 146 SV *string 147 148 PREINIT: 149 CBC_METHOD(unpack); 150 char *buf; 151 STRLEN len; 152 MemberInfo mi; 153 unsigned long count; 154 155 PPCODE: 156 CT_DEBUG_METHOD1("'%s'", type); 157 158 CHECK_VOID_CONTEXT; 159 160 SvGETMAGIC(string); 161 162 if ((SvFLAGS(string) & (SVf_POK|SVp_POK)) == 0) 163 Perl_croak(aTHX_ "Type of arg 2 to unpack must be string"); 164 165 NEED_PARSE_DATA; 166 167 if (!get_member_info(aTHX_ THIS, type, &mi, 0)) 168 Perl_croak(aTHX_ "Cannot find '%s'", type); 169 170 if (mi.flags) 171 WARN_FLAGS(type, mi.flags); 172 173 buf = SvPV(string, len); 174 175 if (GIMME_V == G_SCALAR) 176 { 177 if (mi.size > len) 178 WARN((aTHX_ "Data too short")); 179 180 count = 1; 181 } 182 else 183 count = mi.size == 0 ? 1 : len / mi.size; 184 185 if (count > 0) 186 { 187 dXCPT; 188 unsigned long i; 189 PackHandle pack; 190 SV **sva; 191 192 /* newHV_indexed() messes with the stack, so we cannot 193 * store the return values on the stack immediately... 194 */ 195 196 Newz(0, sva, count, SV *); 197 198 pack = pk_create(THIS, ST(0)); 199 pk_set_buffer(pack, NULL, buf, len); 200 201 XCPT_TRY_START 202 { 203 for (i = 0; i < count; i++) 204 { 205 pk_set_buffer_pos(pack, i*mi.size); 206 sva[i] = pk_unpack(aTHX_ pack, &mi.type, mi.pDecl, mi.level); 207 } 208 209 } 210 XCPT_TRY_END 211 212 pk_delete(pack); 213 214 XCPT_CATCH 215 { 216 for (i = 0; i < count; i++) 217 if (sva[i]) 218 SvREFCNT_dec(sva[i]); 219 220 Safefree(sva); 221 222 XCPT_RETHROW; 223 } 224 225 /* A hook may have moved our stack */ 226 SPAGAIN; 227 SP -= items; 228 229 EXTEND(SP, count); 230 231 for (i = 0; i < count; i++) 232 PUSHs(sv_2mortal(sva[i])); 233 234 Safefree(sva); 235 } 236 237 XSRETURN(count); 238 239