Permalink
Browse files

Merge pull request #66 from kboga/ng-pack-unpack

Adds a slightly adjusted but mostly copy pasted version of ng's pack & unpack.
  • Loading branch information...
2 parents 570f2bb + 7d33ee1 commit f2e5c38f872ecd0de89ee1af5316c0cec2998ee4 @jnthn jnthn committed May 14, 2012
Showing with 125 additions and 2 deletions.
  1. +123 −0 src/core/Buf.pm
  2. +2 −2 t/spectest.data
View
@@ -76,6 +76,76 @@ my class Buf does Positional {
);
$ret;
}
+
+ method unpack(Buf:D: $template) {
+ my @bytes = self.list;
+ my @fields;
+ for $template.comb(/<[a..zA..Z]>[\d+|'*']?/) -> $unit {
+ my $directive = $unit.substr(0, 1);
+ my $amount = $unit.substr(1);
+
+ given $directive {
+ when 'A' {
+ my $asciistring;
+ if $amount eq '*' {
+ $amount = @bytes.elems;
+ }
+ for ^$amount {
+ $asciistring ~= chr(shift @bytes);
+ }
+ @fields.push($asciistring);
+ }
+ when 'H' {
+ my $hexstring;
+ while @bytes {
+ my $byte = shift @bytes;
+ $hexstring ~= ($byte +> 4).fmt('%x')
+ ~ ($byte % 16).fmt('%x');
+ }
+ @fields.push($hexstring);
+ }
+ when 'x' {
+ if $amount eq '*' {
+ $amount = 0;
+ }
+ elsif $amount eq '' {
+ $amount = 1;
+ }
+ splice @bytes, 0, $amount;
+ }
+ when 'C' {
+ @fields.push: shift @bytes;
+ }
+ when 'S' | 'v' {
+ @fields.push: shift(@bytes)
+ + (shift(@bytes) +< 0x08);
+ }
+ when 'L' | 'V' {
+ @fields.push: shift(@bytes)
+ + (shift(@bytes) +< 0x08)
+ + (shift(@bytes) +< 0x10)
+ + (shift(@bytes) +< 0x18);
+ }
+ when 'n' {
+ @fields.push: (shift(@bytes) +< 0x08)
+ + shift(@bytes);
+ }
+ when 'N' {
+ @fields.push: (shift(@bytes) +< 0x18)
+ + (shift(@bytes) +< 0x10)
+ + (shift(@bytes) +< 0x08)
+ + shift(@bytes);
+ }
+ die "Unrecognized directive $directive";
+ }
+ }
+
+ return |@fields;
+ }
+
+ # XXX: the pack.t spectest file seems to require this method
+ # not sure if it should be changed to list there...
+ method contents(Buf:D:) { self.list }
}
multi infix:<eqv>(Buf:D $a, Buf:D $b) {
@@ -140,3 +210,56 @@ multi sub infix:<le>(Buf:D $a, Buf:D $b) {
multi sub infix:<ge>(Buf:D $a, Buf:D $b) {
($a cmp $b) != -1
}
+
+multi sub pack(Str $template, *@items) {
+ my @bytes;
+ for $template.comb(/<[a..zA..Z]>[\d+|'*']?/) -> $unit {
+ my $directive = $unit.substr(0, 1);
+ my $amount = $unit.substr(1);
+
+ given $directive {
+ when 'A' {
+ my $ascii = shift @items // '';
+ for $ascii.comb -> $char {
+ die "Non-ASCII character $char" if ord($char) > 0x7f;
+ @bytes.push: ord($char);
+ }
+ if $amount ne '*' {
+ @bytes.push: 0x20 xx ($amount - $ascii.chars);
+ }
+ }
+ when 'H' {
+ my $hexstring = shift @items // '';
+ if $hexstring % 2 {
+ $hexstring ~= '0';
+ }
+ @bytes.push: map { :16($_) }, $hexstring.comb(/../);
+ }
+ when 'C' {
+ my $number = shift(@items);
+ @bytes.push: $number % 0x100;
+ }
+ when 'S' | 'v' {
+ my $number = shift(@items);
+ @bytes.push: ($number, $number +> 0x08) >>%>> 0x100;
+ }
+ when 'L' | 'V' {
+ my $number = shift(@items);
+ @bytes.push: ($number, $number +> 0x08,
+ $number +> 0x10, $number +> 0x18) >>%>> 0x100;
+ }
+ when 'n' {
+ my $number = shift(@items);
+ @bytes.push: ($number +> 0x08, $number) >>%>> 0x100;
+ }
+ when 'N' {
+ my $number = shift(@items);
+ @bytes.push: ($number +> 0x18, $number +> 0x10,
+ $number +> 0x08, $number) >>%>> 0x100;
+ }
+ die "Unrecognized directive $directive";
+ }
+ }
+
+ return Buf.new(@bytes);
+}
View
@@ -627,7 +627,7 @@ S32-str/lc.t # icu
S32-str/lines.t
S32-str/numeric.t
S32-str/ords.t
-# S32-str/pack.t # err: Undefined routine '&pack' called
+S32-str/pack.t
S32-str/pos.t
S32-str/rindex.t
S32-str/samecase.t # icu
@@ -638,7 +638,7 @@ S32-str/substr.t
S32-str/trim.t
S32-str/ucfirst.t # icu
S32-str/uc.t # icu
-# S32-str/unpack.t # err: Method 'unpack' not found for invocant of class 'Buf'
+S32-str/unpack.t
S32-str/words.t # icu
S32-temporal/calendar.t
S32-temporal/Date.t

0 comments on commit f2e5c38

Please sign in to comment.