Try this. It fixes a potential bug and adds the ability to get greater compression for numeric fields. It needs more testing, diagnostics and documentation, but suck it and see if it satisfies.
#! perl -slw
package Class::Struct::Compact2;
use strict;
use warnings;
my $TEMPL_RE = qr[(?:[AaZ]\d*|[cCsSiIlLqQjJfFd][><]?)];
our @export = qw[ new ];
sub new {
my( $class, $newClassName, $templ ) = ( shift, shift, shift );
$templ =~ m[^(?:\s*$TEMPL_RE)+\s*$] or die "Invalid template";
my @templs = split ' ', $templ;
my @names = @_;
die 'The number of templates and names does not match.' unless @te
+mpls == @names;
my( $n, @sizes, @offsets ) = 0;
$sizes[ @sizes ] = $_, $offsets[ @offsets ] = $n, $n += $_ for map
+ length( pack $_, 0 ), @templs;
my $package = <<EON;
# line 1 \"sub_New\"
package $newClassName;
sub new {
my \$class = shift;
my \$self;
if( \@_ == 1 ) {
\$self = shift() // '';
}
elsif( \@_ == @{[ scalar @templs ]} ) {
\$self = pack '$templ', \@_;
}
return bless \\\$self, \$class
}
EON
for my $field ( 0 .. $#names ) {
$package .= <<EOA;
# line 1 \"sub_$names[ $field ]\"
sub ${newClassName}::${names[ $field ]} {
my( \$self, \$newVal ) = \@_;
substr( \$\$self, $offsets[ $field ], $sizes[ $field ] ) = pack '$
+templs[ $field ]', \$newVal
if defined \$newVal;
return unpack '$templs[ $field ]', substr( \$\$self, $offsets[ $fi
+eld ], $sizes[ $field ] );
}
EOA
}
# print $package;
eval $package;
return;
}
return 1 if caller;
package main;
use Time::HiRes qw[ time ];
use Devel::Size qw[ total_size ];
use Data::Dump qw[ pp ];
my @chars = ( 'a'..'z' );
sub dummy {
my $n = shift;
join '', @chars[ map int( rand @chars ), 1 .. $n ];
}
my @fieldNames = ( qw[
SPString BString NPString SChar UChar SShort UShort
SInt UInt ANInt UNInt SLong ULong
SQuad UQuad SPFloat DPFloat NDouble
] );
our $N //= 15_000;
our $FIELD //= 'BString';
our $SHOW //= 0;
our $CHECK //= 0;
Class::Struct::Compact2->new(
'Test',
'A15 a15 Z15 c C s S i I l L j J q Q f F d',
@fieldNames
);
printf "Class constructed: check mem: "; $CHECK and <>;
my @db;
push @db, Test->new(
map( dummy( 15 ), 1 .. 3 ),
map( int( rand 2**$_ ), (7)x2, (15)x2, (31)x6, (63)x2 ),
rand() * 1e38, rand() * 1e308, rand() * 1e308
) for 1 .. $N;
printf "Instances created: check mem: "; $CHECK and <>;
@db = sort{
$a->$FIELD cmp $b->$FIELD
} @db;
$SHOW and pp \@db;
printf "Instances sorted: check mem: "; $CHECK and <>;
print "total size: ", total_size \@db;
print "object size:", total_size \$db[0];
my $start = time;
for my $o ( 0, $#db ) {
my @rec = map $db[ $o ]->$_, @fieldNames;
print "@rec";
}
printf "Took %15.12f s\n", time() - $start;
__END__
With the rise and rise of 'Social' network sites: 'Computers are making people easier to use everyday'
Examine what is said, not who speaks -- Silence betokens consent -- Love the truth but pardon error.
"Science is about questioning the status quo. Questioning authority".
In the absence of evidence, opinion is indistinguishable from prejudice.
|