File Coverage

xsubs/pack.xs
Criterion Covered Total %
statement 94 95 98.9
branch 113 128 88.2
condition n/a
subroutine n/a
pod n/a
total 207 223 92.8


line stmt bran cond sub pod time code
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 344406           CBC_METHOD(pack);
27             char *buffer;
28             MemberInfo mi;
29             PackHandle pack;
30             SV *rv;
31 344406           dXCPT;
32              
33             CODE:
34             CT_DEBUG_METHOD1("'%s'", type);
35              
36 344406 100         if (string == NULL && GIMME_V == G_VOID)
    100          
    100          
37             {
38 12 100         WARN_VOID_CONTEXT;
39 12           XSRETURN_EMPTY;
40             }
41              
42 344394 100         if (string != NULL)
43             {
44 68 100         SvGETMAGIC(string);
    50          
45            
46 68 100         if ((SvFLAGS(string) & (SVf_POK|SVp_POK)) == 0)
47 7           Perl_croak(aTHX_ "Type of arg 3 to pack must be string");
48              
49 61 100         if (GIMME_V == G_VOID && SvREADONLY(string))
    100          
    100          
50 6           Perl_croak(aTHX_ "Modification of a read-only value attempted");
51             }
52              
53 344381 100         NEED_PARSE_DATA;
    100          
54              
55 344381 100         if (!get_member_info(aTHX_ THIS, type, &mi, 0))
56 18           Perl_croak(aTHX_ "Cannot find '%s'", type);
57              
58 344345 100         if (mi.flags)
59 305983 100         WARN_FLAGS(type, mi.flags);
    100          
60              
61 344345 100         if (string == NULL)
62             {
63 344296           rv = newSV(mi.size);
64              
65             /* force rv into a PV when mi.size is zero (bug #3753) */
66 344296 100         if (mi.size == 0)
67 71           sv_grow(rv, 1);
68              
69 344296           SvPOK_only(rv);
70 344296           SvCUR_set(rv, mi.size);
71 344296           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 344296           Zero(buffer, mi.size+1, char);
76             }
77             else
78             {
79 49           STRLEN len = SvCUR(string);
80 49           STRLEN max = mi.size > len ? mi.size : len;
81              
82 49 50         if (GIMME_V == G_VOID)
    100          
83             {
84 33           rv = NULL;
85 33 100         buffer = SvGROW(string, max+1);
    50          
86 33           SvCUR_set(string, max);
87             }
88             else
89             {
90 16           rv = newSV(max);
91 16           SvPOK_only(rv);
92 16           buffer = SvPVX(rv);
93 16           SvCUR_set(rv, max);
94 16           Copy(SvPVX(string), buffer, len, char);
95             }
96              
97 49 100         if(max > len)
98 9           Zero(buffer+len, max+1-len, char);
99             }
100              
101 344345           pack = pk_create(THIS, ST(0));
102 344345           pk_set_type(pack, type);
103 344345 100         pk_set_buffer(pack, rv ? rv : string, buffer, mi.size);
104              
105 344345 100         SvGETMAGIC(data);
    50          
106              
107 344441 100         XCPT_TRY_START
108             {
109 344345           pk_pack(aTHX_ pack, &mi.type, mi.pDecl, mi.level, data);
110             }
111 344345           XCPT_TRY_END
112              
113 344345           pk_delete(pack);
114              
115 344345 100         XCPT_CATCH
116             {
117 96 50         if (rv)
118 96           SvREFCNT_dec(rv);
119              
120 96 50         XCPT_RETHROW;
    0          
121             }
122              
123             /* this makes substr() as third argument work */
124 344249 100         if (string)
125 49 100         SvSETMAGIC(string);
126              
127 344248 100         if (rv == NULL)
128 32           XSRETURN_EMPTY;
129              
130 344216           ST(0) = sv_2mortal(rv);
131 344260           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 381868           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 381868 100         CHECK_VOID_CONTEXT;
    100          
    100          
159              
160 381856 100         SvGETMAGIC(string);
    50          
161              
162 381856 100         if ((SvFLAGS(string) & (SVf_POK|SVp_POK)) == 0)
163 1           Perl_croak(aTHX_ "Type of arg 2 to unpack must be string");
164              
165 381855 100         NEED_PARSE_DATA;
    100          
166              
167 381855 100         if (!get_member_info(aTHX_ THIS, type, &mi, 0))
168 12           Perl_croak(aTHX_ "Cannot find '%s'", type);
169              
170 381825 100         if (mi.flags)
171 306017 100         WARN_FLAGS(type, mi.flags);
    100          
172              
173 381825 100         buf = SvPV(string, len);
174              
175 381825 100         if (GIMME_V == G_SCALAR)
    100          
176             {
177 381805 100         if (mi.size > len)
178 30 100         WARN((aTHX_ "Data too short"));
179              
180 381805           count = 1;
181             }
182             else
183 20 100         count = mi.size == 0 ? 1 : len / mi.size;
184              
185 381825 100         if (count > 0)
186             {
187 381819           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 381819 50         Newz(0, sva, count, SV *);
197              
198 381819           pack = pk_create(THIS, ST(0));
199 381819           pk_set_buffer(pack, NULL, buf, len);
200              
201 381919 100         XCPT_TRY_START
202             {
203 763567 100         for (i = 0; i < count; i++)
204             {
205 381848           pk_set_buffer_pos(pack, i*mi.size);
206 381848           sva[i] = pk_unpack(aTHX_ pack, &mi.type, mi.pDecl, mi.level);
207             }
208              
209             }
210 381819           XCPT_TRY_END
211              
212 381819           pk_delete(pack);
213            
214 381819 100         XCPT_CATCH
215             {
216 200 100         for (i = 0; i < count; i++)
217 100 50         if (sva[i])
218 0           SvREFCNT_dec(sva[i]);
219              
220 100           Safefree(sva);
221              
222 100 50         XCPT_RETHROW;
    0          
223             }
224              
225             /* A hook may have moved our stack */
226 381719           SPAGAIN;
227 381719           SP -= items;
228              
229 381719 50         EXTEND(SP, count);
230              
231 763467 100         for (i = 0; i < count; i++)
232 381748           PUSHs(sv_2mortal(sva[i]));
233              
234 381719           Safefree(sva);
235             }
236              
237 381737           XSRETURN(count);
238