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