Front page | perl.perl5.porters |
Postings from April 2000
Re: [ID 20000425.002] Minor bug fix and enhancement to to pp.c:pp_pack()
Thread Previous
|
Thread Next
From:
John Holdsworth
Date:
April 26, 2000 12:56
Subject:
Re: [ID 20000425.002] Minor bug fix and enhancement to to pp.c:pp_pack()
Message ID:
390749BD.16922685@msdw.com
Ilya Zakharevich wrote:
> On Wed, Apr 26, 2000 at 12:25:08PM +0100, John Holdsworth wrote:
> > > > 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.
>
> > > Not clear. unpack 'N/Z*' with N unpacking to 14 should be the same as
> > > Z14. Is it?
> >
> > It seems not. There is some rather strange code in pp_pack()
>
> Hmm, I was asking about unpack(), not about pack().
Apologies, I'd better break this up into three separate changes which is
what it really is. The "N/Z*" bug results in an asymetry in the
operation pack() and unpack(). You only notice it when
N/Z* is followed by another pattern in a template.
If you try the following code on perl-5.6.0 you'll see what I mean
#! ./perl
use lib::strict;
my $packed = pack "N/Z* a4", "hi there ", "1234";
my ( $s, $i ) = unpack "N/Z* a4", $packed;
print "$s $i\n";
The output is "hi there \000123\n" rather than "hi there 1234\n".
unpack() has not skipped the extra null which pack() has inserted.
If you apply the following patch to pp_unpack() this is fixed...
=============================================
*** pp.c Wed Apr 26 20:49:41 2000
--- pp.c.1 Wed Apr 26 19:52:34 2000
***************
*** 3436,3442 ****
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 */
--- 3436,3441 ----
***************
*** 3443,3448 ****
--- 3442,3448 ----
s = SvPVX(sv);
while (*s)
s++;
+ len++;
}
else { /* 'A' strips both nulls and spaces */
s = SvPVX(sv) + len - 1;
***************
*** 3454,3459 ****
--- 3454,3460 ----
s = aptr; /* unborrow register */
}
XPUSHs(sv_2mortal(sv));
+ s += len;
break;
case 'B':
case 'b':
============================================================
> What is the problem you want to address?
I'm trying to support XDR strings (and arrays eventually)
in [un]pack() so I can write an efficient NFS server in perl.
XDR/PRC quite a simple but very established protocol.
I fell it would be useful if the new '/' modifier supported it.
The second part of the patch was to make the smallest tweak
to get XDR strings which have to be encoded in a number of
bytes which is a multiple of 4 working in a backward compatable
manner.
"x!4" would be a nicer syntax but I'm a little reluctant
to try to change pp_pack and pp_unpack quite as much
as this would require. Its early days for me under the hood.
The patch below can be applied after the one above
to have the following code work:
#! ./perl
my $pack2 = pack "N/a*4 N/a*4", "hi", "there";
my ( $s1, $s2 ) = unpack "N/a*4 N/a*4", $pack2;
printf "$s1 $s2 %d\n", length( $pack2 );
# prints "hi there 20\n" (4 bytes + 12 bytes for the strings and two network order ints).
==================================
*** pp.c Wed Apr 26 20:18:32 2000
--- pp.c.2 Wed Apr 26 20:16:44 2000
***************
*** 3420,3429 ****
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;
--- 3420,3429 ----
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" );
+ if (*pat == '*')
+ pat++; /* ignore '*' for compatibility with pack */
len = POPi;
star = 0;
goto redo_switch;
***************
*** 3454,3459 ****
--- 3454,3461 ----
s = aptr; /* unborrow register */
}
XPUSHs(sv_2mortal(sv));
+ if ( *pat == '4' && pat++ )
+ len = (len + 3 & ~3);
s += len;
break;
case 'B':
***************
*** 4491,4496 ****
--- 4493,4500 ----
if (datumtype == 'Z')
++len;
}
+ if ( *pat == '4' && pat++ )
+ len = (len + 3 & ~3);
if (fromlen >= len) {
sv_catpvn(cat, aptr, len);
if (datumtype == 'Z')
=================================================
>
> Currently this can be done with interpolation into the pattern:
>
> my $len = @arr;
> my $packed = pack "N$len N$len", @arr, @arr;
This is true but again I'm thinking of XDR. If "N/N*" worked
for unpack as you might expect it to the following code would
be possible:
# code for processing an incoming RPC call..
my ( $xid, $dir, $rpcvers, $prog, $vers, $proc, $credentials ) = unpack( "NNNNNN N/a*4" );
my ( $time, $hostname, $uid, $gid, @gids ) = unpack( "N N/a*4 NNN N/N*", $credentials );
> I can easily believe that the feature you wanted to add is desirable,
> but until we can invent a more intuitive and more general "API". I do
> not think that what you did should go in.
No problem, how it is represented in the template is going to
require more discussion. I am mainly putting forward the idea.
Regards,
john.
>
Original suggested patch follows:
===========================
To: perlbug@perl.com
Cc: gsar@activestate.com
Subject: Minor bug fix and enhancement to to pp.c:pp_pack()
Reply-To: coldwave@bigfoot.com
This is a bug report for perl from root@pland.cwp,
generated with the help of perlbug 1.28 running under perl v5.6.0.
-----------------------------------------------------------------
[Please enter your report here]
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<u> 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<a>, C<A>, and C<Z> types gobble just one value, but pack it as a
***************
*** 3090,3104 ****
and describes how the length value is packed.
The ones likely to be of most use are integer-packing ones like
C<n> (for Java strings), C<w> (for ASN.1 or SNMP)
! and C<N> (for Sun XDR).
- The I<string-item> must, at present, be C<"A*">, C<"a*"> or C<"Z*">.
For C<unpack> the length of the string is obtained from the I<length-item>,
but if you put in the '*' it will be ignored.
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<unpack>.
--- 3097,3112 ----
and describes how the length value is packed.
The ones likely to be of most use are integer-packing ones like
C<n> (for Java strings), C<w> (for ASN.1 or SNMP)
! and C<N/N*4> (for Sun XDR).
For C<unpack> the length of the string is obtained from the I<length-item>,
but if you put in the '*' it will be ignored.
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<unpack>.
*** 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')
[Please do not change anything below this line]
-----------------------------------------------------------------
---
Flags:
category=core
severity=medium
---
Site configuration information for perl v5.6.0:
Configured by root at Wed Apr 19 23:36:44 BST 2000.
Summary of my perl5 (revision 5.0 version 6 subversion 0) configuration:
Platform:
osname=linux, osvers=2.2.5-15, archname=i686-linux
uname='linux pland.cwp 2.2.5-15 #1 mon apr 19 23:00:46 edt 1999 i686 unknown '
config_args='-d'
hint=recommended, useposix=true, d_sigaction=define
usethreads=undef use5005threads=undef useithreads=undef usemultiplicity=undef
useperlio=undef d_sfio=undef uselargefiles=define
use64bitint=undef use64bitall=undef uselongdouble=undef usesocks=undef
Compiler:
cc='cc', optimize='-O2', gccversion=egcs-2.91.66 19990314/Linux (egcs-1.1.2 release)
cppflags='-fno-strict-aliasing'
ccflags ='-fno-strict-aliasing -D_LARGEFILE_SOURCE -D_FILE_OFFSET_BITS=64'
stdchar='char', d_stdstdio=define, usevfork=false
intsize=4, longsize=4, ptrsize=4, doublesize=8
d_longlong=define, longlongsize=8, d_longdbl=define, longdblsize=12
ivtype='long', ivsize=4, nvtype='double', nvsize=8, Off_t='off_t', lseeksize=8
alignbytes=4, usemymalloc=n, prototype=define
Linker and Libraries:
ld='cc', ldflags =' -L/usr/local/lib'
libpth=/usr/local/lib /lib /usr/lib
libs=-lnsl -lndbm -lgdbm -ldb -ldl -lm -lc -lposix -lcrypt
libc=/lib/libc-2.1.1.so, so=so, useshrplib=false, libperl=libperl.a
Dynamic Linking:
dlsrc=dl_dlopen.xs, dlext=so, d_dlsymun=undef, ccdlflags='-rdynamic'
cccdlflags='-fpic', lddlflags='-shared -L/usr/local/lib'
Locally applied patches:
---
@INC for perl v5.6.0:
/usr/local/lib/perl5/5.6.0/i686-linux
/usr/local/lib/perl5/5.6.0
/usr/local/lib/perl5/site_perl/5.6.0/i686-linux
/usr/local/lib/perl5/site_perl/5.6.0
/usr/local/lib/perl5/site_perl
.
---
Environment for perl v5.6.0:
HOME=/root
LANG (unset)
LANGUAGE (unset)
LD_LIBRARY_PATH (unset)
LOGDIR (unset)
PATH=/bin:/usr/bin:/usr/local/bin:/usr/bin/X11:/usr/X11R6/bin:.
PERL_BADLANG (unset)
SHELL=/bin/bash
Thread Previous
|
Thread Next