p5pRT
commented
24 years ago From johnno@ms.com
Created by root@pland.cwp
This message contains a small set of patches to pp.c:pp_pack/unpack(). This slightly rounds out the new /' modifier to support XDR format more fully.
Included is a bug fix to the decode of unpack 'N/Z*' which was not adding a byte to the encoded length as pack does.
There is also option to use 'N/a*4' to round the length of encoded strings to four bytes as required by SUN XDR RFC 1832.
More contentiously perhaps the code also supports a new length character '?' which steals the length from the next argument. This allows multiple arrays to be encoded and decoded viz.:
my @arr = (1\,2\,3\,4); my $packed = pack "N/N?N/N?"\, scalar @arr\, @arr\, scalar @arr\, @arr;
Using these basic changes it is possible to decode/encode SUN RPC calls\, indeed I have tested this code fairly extensively with an NFS server implemented entirely in perl (less strange a thing to do than it sounds).
Included are patches to t/op/pack.t and pod/perlfunc.pod regression testing the changes and documenting them.
I hope you find this interesting. I've tried to keep the changes to the absolute minimum to try to perhaps slip under the 5.6.1 wire.
Regards\,
John Holdsworth Coldwave Programs Ltd.
Patch file to perl-5.6.0 follows...
*** t/op/pack.t Mon Mar 13 21:25:37 2000
--- t/op/pack.new Wed Apr 19 23:35:31 2000
***************
*** 6\,12 ****
require Config; import Config;
}
! print "1..156\n";
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
--- 6\,12 ----
require Config; import Config;
}
! print "1..160\n";
$format = "c2 x5 C C x s d i l a6";
# Need the expression in here to force ary[5] to be numeric. This avoids
***************
*** 405\,407 ****
--- 405\,427 ----
w/A* # Count a BER integer
EOP
print 'not ' unless $z eq "\000\006string\003etc"; print "ok $test\n"; $test++;
+
+ # 157..160 test XDR N/? and unpack == pack
+
+ sub punp {
+ my $template = shift;
+ my $packed = pack $template\, @_;
+ my @unpacked = unpack $template\, $packed;
+
+ print "not " if join( '~'\, @unpacked ) ne join( '~'\, @_ );
+ print "ok $test\n";
+ $test++;
+ }
+
+ my @arr = (11\,22\,33\,44\,55);
+
+ punp "N/a*4N/N?N/a?4@?"\, ("hello"\, scalar @arr\, @arr\, 5\, "there"\, 48);
+ punp "i/A*N/I?I/A*"\, ("hello"\, scalar @arr\, @arr\, "there");
+ punp "N/Z*w/a*N/f?N/i*"\, ("hello"\, "there"\, scalar @arr\, @arr\, @arr);
+ punp "N/Z*4i/s?w/A?N/a*"\, ("hell"\, scalar @arr\, @arr\, 2\, "hi"\, "john");
+
*** pod/perlfunc.pod Mon Mar 20 22:13:52 2000
--- pod/perlfunc.pod.new Wed Apr 19 23:31:29 2000
***************
*** 3006\,3011 ****
--- 3006\,3018 ----
The repeat count for C\ is interpreted as the maximal number of bytes
to encode per line of output\, with 0 and 1 replaced by 45.
+ The characterC\<?> for the repeat count means the next argument will
+ be taken as the number of items to be encoded. This allows multiple
+ variable length arrays to be packed and unpacked in the same string
+ when using the C\</> modifier. As packed results can now be variable
+ length the special case C\<@?> on unpack returns the number of bytes
+ into the string that have been processed up to that point.
+
=item *
The C\\, C\\, and C\
- The I\<string-item> must\, at present\, be C\<"A*">\, C\<"a*"> or C\<"Z*">.
For C\
unpack 'C/a'\, "\04Gurusamy"; gives 'Guru'
unpack 'a3/A* A*'\, '007 Bond J '; gives (' Bond'\,'J')
pack 'n/a* w/a*'\,'hello\,'\,'world'; gives "\000\006hello\,\005world"
The I\<length-item> is not returned explicitly from C\
--- 3097\,3112 ----
and describes how the length value is packed.
The ones likely to be of most use are integer-packing ones like
C\
For C\
unpack 'C/a'\, "\04Gurusamy"; gives 'Guru'
unpack 'a3/A* A*'\, '007 Bond J '; gives (' Bond'\,'J')
pack 'n/a* w/a*'\,'hello\,'\,'world'; gives "\000\006hello\,\005world"
+ pack 'N/a*4N/a*4'\,'hello\,'\,'world'; gives (SUN XDR string format)
+ "\000\000\000\006hello\,\000\000\000\000\000\005world\000\000\000"
The I\<length-item> is not returned explicitly from C\
*** pp.c Mon Mar 20 15:35:44 2000
--- pp.c.new Wed Apr 19 11:15:26 2000
***************
*** 3284\,3289 ****
--- 3284\,3293 ----
#define ISUUCHAR(ch) (memchr(PL_uuemap\, (ch)\, sizeof(PL_uuemap)-1) || (ch) == ' ')
#endif
+ #define NEXTPAT( _chr ) (pat \< patend && *pat == (_chr) && pat++)
+
+
+
PP(pp_unpack)
{
djSP;
***************
*** 3402\,3410 ****
goto reparse;
break;
case '@':
if (len > strend - strbeg)
DIE(aTHX_ "@ outside of string");
- s = strbeg + len;
break;
case 'X':
if (len > s - strbeg)
--- 3406\,3422 ----
goto reparse;
break;
case '@':
+ if (NEXTPAT('?')) {
+ EXTEND(SP\, 1);
+ EXTEND_MORTAL(1);
+ sv = NEWSV(43\, 0);
+ sv_setuv(sv\, (UV)(s-strbeg));
+ PUSHs(sv_2mortal(sv));
+ }
+ else
+ s = strbeg + len;
if (len > strend - strbeg)
DIE(aTHX_ "@ outside of string");
break;
case 'X':
if (len > s - strbeg)
***************
*** 3420\,3430 ****
if (start_sp_offset >= SP - PL_stack_base)
DIE(aTHX_ "/ must follow a numeric type");
datumtype = *pat++;
- if (*pat == '*')
- pat++; /* ignore '*' for compatibility with pack */
if (isDIGIT(*pat))
DIE(aTHX_ "/ cannot take a count" );
! len = POPi;
star = 0;
goto redo_switch;
case 'A':
--- 3432\,3441 ----
if (start_sp_offset >= SP - PL_stack_base)
DIE(aTHX_ "/ must follow a numeric type");
datumtype = *pat++;
if (isDIGIT(*pat))
DIE(aTHX_ "/ cannot take a count" );
! NEXTPAT('*'); /* ignore '*' for compatibility with pack */
! len = NEXTPAT('?') ? TOPi : POPi;
star = 0;
goto redo_switch;
case 'A':
***************
*** 3436\,3448 ****
goto uchar_checksum;
sv = NEWSV(35\, len);
sv_setpvn(sv\, s\, len);
- s += len;
if (datumtype == 'A' || datumtype == 'Z') {
aptr = s; /* borrow register */
if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
s = SvPVX(sv);
while (*s)
s++;
}
else { /* 'A' strips both nulls and spaces */
s = SvPVX(sv) + len - 1;
--- 3447\,3460 ----
goto uchar_checksum;
sv = NEWSV(35\, len);
sv_setpvn(sv\, s\, len);
if (datumtype == 'A' || datumtype == 'Z') {
aptr = s; /* borrow register */
if (datumtype == 'Z') { /* 'Z' strips stuff after first null */
s = SvPVX(sv);
while (*s)
s++;
+ if (pat[-1] == '*')
+ len++;
}
else { /* 'A' strips both nulls and spaces */
s = SvPVX(sv) + len - 1;
***************
*** 3454\,3459 ****
--- 3466\,3474 ----
s = aptr; /* unborrow register */
}
XPUSHs(sv_2mortal(sv));
+ if (NEXTPAT('4'))
+ len = (len + 3 & ~3);
+ s += len;
break;
case 'B':
case 'b':
***************
*** 4438\,4451 ****
DIE(aTHX_ "Repeat count in pack overflows");
}
}
else
len = 1;
! if (*pat == '/') {
! ++pat;
! if ((*pat != 'a' && *pat != 'A' && *pat != 'Z') || pat[1] != '*')
! DIE(aTHX_ "/ must be followed by a*\, A* or Z*");
! lengthcode = sv_2mortal(newSViv(sv_len(items > 0
! ? *MARK : &PL_sv_no)));
}
switch(datumtype) {
default:
--- 4453\,4472 ----
DIE(aTHX_ "Repeat count in pack overflows");
}
}
+ else if (NEXTPAT('?')) {
+ fromstr = NEXTFROM;
+ len = SvIV(fromstr);
+ }
else
len = 1;
! if (NEXTPAT('/')) {
! lengthcode = items > 0 ? *MARK : &PL_sv_no;
! if (pat[1] != '?') {
! if (strchr("aAZ"\,*pat))
! lengthcode = sv_2mortal(newSViv(sv_len(lengthcode)));
! else
! lengthcode = sv_2mortal(newSViv(items));
! }
}
switch(datumtype) {
default:
***************
*** 4490\,4495 ****
--- 4511\,4518 ----
if (datumtype == 'Z')
++len;
}
+ if (NEXTPAT('4'))
+ len = (len + 3 & ~3);
if (fromlen >= len) {
sv_catpvn(cat\, aptr\, len);
if (datumtype == 'Z')
Migrated from rt.perl.org#3154 (status was 'resolved')
Searchable as RT3154$