use strict;
use warnings;
use Benchmark qw(cmpthese);


no warnings 'uninitialized';
#use Everything;

#===
local *escape=sub
{
    my ($esc) = @_;

    $esc =~ s/(\W)/sprintf("%%%02x",ord($1))/ge;

    return $esc;
};

local *unescape=sub
{
    foreach my $arg (@_)
    {
        tr/+/ /;
        $arg =~ s/\%(..)/chr(hex($1))/ge;
    }

    1;
};

######################################################################
+#######
local *gVars= sub
{
    my $varstr=shift;
    my %vars = map { split /=/ } split (/&/, $varstr);
    foreach (keys %vars) {
        unescape($vars{$_});
        if ($vars{$_} eq ' ') { $vars{$_} = ""; }
    }
    return \%vars;
};

local *sVars=sub
{
    my ($varsref) = @_;

    # Clean out the keys that have do not have a value.
    foreach (keys %$varsref) {
        $$varsref{$_} = " " unless $$varsref{$_};
    }

    return join("&", map( $_."=".escape($$varsref{$_}), keys %$varsref
+) );

};


my $PackVer = '==01';
local *packVars=sub
{
    my $varsref = $_[0];
    my $seenref = $_[1];

    return unless $varsref;
    my $PV=!$seenref ? "$PackVer:" : "";
    return if $seenref->{0+$varsref}++;

    if (ref $varsref eq "HASH") {
        return join "*", $PV."H",
            map {
                my $v = $varsref->{$_};
                $v = ref $v
                    ? packVars( $v, $seenref )
                    : defined($v) ? "V$v" : "U";
                join '!',
                    map { s/([*!#])/ sprintf '#%02x', ord($1) /ge; $_}
                        "V$_", $v;
            } sort keys %$varsref;
    } elsif (ref $varsref eq "ARRAY") {
        return join "^", $PV."A",
            map {
                my $v = ref $_
                    ? packVars( $_, $seenref )
                    : defined($_) ? "V$_" : "U";
                $v =~ s/([~^])/sprintf '~%02x', ord($1)/ge;
                $v;
            } @$varsref;
    } else {
      die "Can't handle vars of type ".ref($varsref)."\n";
    }
};

local *unpackVars= sub
{
    my $vars_str = $_[0];

    return {} unless $vars_str;

    my $depth    = $_[1]||0;
    #printf "% 3d:%s\n",$depth,$vars_str;

    unless ($depth) {
      # version 00: original format
      # version 01: keys are escaped, not just values, handles nested 
+refs.
      $vars_str =~ s/^(==\d\d)://;
      unless (defined $1) {
        # No format/format version "00"
        my %vars = map split(/=/, $_, 2), split /&/, $vars_str;
        unescape( values %vars );
        $vars{$_} eq ' ' and $vars{$_} = '' for keys %vars;
        return \%vars;
      } elsif ($1 gt $PackVer) {
        return "Version Error! $1 / $PackVer";
      }
    }

    my $vars;
    $vars_str =~ s/^([AHUV])(.)?//;
    my ($type,$split)=($1,$2);

    #print "$type : $split : $vars_str\n";

    #print "$format_version : $type : $split\n";
    unless (defined $type) {
        return "Error: $vars_str";
    } elsif ($type eq 'H') {
        for (split /\Q$split\E/, $vars_str) {
          my ($k,$v)= split /!/, $_, 2;
          for ( $k,$v ) {
            s/#(\w\w)/ chr(hex($1)) /ge;
            if ($_ eq 'U') {
              $_ = undef;
            } elsif (substr($_,0,1) eq 'V') {
              $_ = substr($_,1);
            } else {
              $_= unpackVars($_,$depth+1);
            }
          }
          $vars->{$k} = $v;
        }
    } elsif ($type eq 'A') {
        for (split /\Q$split\E/, $vars_str) {
            s/~(\w\w)/ chr(hex($1)) /ge;
            push @$vars, $_ eq 'U'
                         ? undef
                         : substr($_,0,1) eq 'V'
                           ? substr($_,1)
                           : unpackVars($_,$depth+1);
        }
    } elsif ($type eq 'U') {
      return undef;
    } elsif ($type eq 'V') {
      return $split.$vars_str;
    }
    return $vars;
};

*cmpVarStrs=*cmpVarStrs;
local *cmpVarStrs=sub
{
    my ($var1str, $var2str) = @_;

    return 0 if $var1str eq $var2str;

    # upgrade to new version
    /^$PackVer:/ or $_ = packVars( unpackVars( $_ ) )
        for ($var1str, $var2str);

    return $var1str cmp $var2str;
};

local *new_getVars=sub
{
    my ($NODE) = @_;
    getRef $NODE;

    return if ($NODE == -1);

    return unpackVars($NODE->{vars});
};

local *new_setVars=sub
{
    my ($NODE, $varsref) = @_;
    my $str;

    getRef($NODE);

    unless (exists $$NODE{vars}) {
        warn ("setVars:\t'vars' field does not exist for node ".getId(
+$NODE)."
        perhaps it doesn't join on the settings table?\n");
    }

    $str = packVars($varsref);

    return unless ($str ne $$NODE{vars}); #we don't need to update...

    # The new vars are different from what this user node contains, fo
+rce
    # an update on the user info.
    $$NODE{vars} = $str;
    my $superuser = -1;
    $DB->updateNode($NODE, $superuser);
};

my $foo=do{open my $fh,"<","./dem_vars.txt"; local $/; <$fh>};

my $Subject={u=>undef,a=>[{'==01:H&'=>'A','H'=>'A'},'==01:H&',1..3,und
+ef,undef,1..4],b=>'test b'};

my $packed=packVars($Subject);
my $unpacked=unpackVars($packed);
my $NODE1=getNodeById(399747);
my $NODE2=getNodeById(396815);

1 and cmpthese -2,
{
 old_u => sub { my $h=getVars($NODE1); $h->{_test1}++; setVars($NODE1,
+$h); },
 new_u => sub { my $h=new_getVars($NODE2); $h->{_test1}++; new_setVars
+($NODE2,$h); },
 old   => sub { my $h=gVars($NODE1->{vars}); my $s=sVars($h); },
 new   => sub { my $h=unpackVars($NODE2->{vars}); my $s=packVars($h); 
+},
};
($Subject,$packed,$unpacked)
__END__

 new, new_u, old, old_u, each for at least 2 CPU seconds...
       new:  2 wallclock secs ( 2.04 usr +  0.00 sys =  2.04 CPU) @ 50
+5.62/s (n=1031)
     new_u:  8 wallclock secs ( 2.09 usr +  0.05 sys =  2.15 CPU) @ 23
+6.45/s (n=508)
       old:  3 wallclock secs ( 2.12 usr +  0.00 sys =  2.12 CPU) @ 13
+0.82/s (n=278)
     old_u:  7 wallclock secs ( 2.05 usr +  0.06 sys =  2.12 CPU) @ 10
+2.49/s (n=217)
       Rate old_u   old new_u   new
old_u 102/s    --  -22%  -57%  -80%
old   131/s   28%    --  -45%  -74%
new_u 236/s  131%   81%    --  -53%
new   506/s  393%  286%  114%    --

new, new_u, old, old_u, each for at least 2 CPU seconds...
       new:  3 wallclock secs ( 2.19 usr +  0.00 sys =  2.19 CPU) @ 50
+0.11/s (n=1094)
     new_u:  5 wallclock secs ( 1.94 usr +  0.12 sys =  2.06 CPU) @ 24
+6.30/s (n=508)
       old:  2 wallclock secs ( 2.13 usr +  0.00 sys =  2.13 CPU) @ 13
+5.50/s (n=289)
     old_u:  4 wallclock secs ( 2.10 usr +  0.03 sys =  2.13 CPU) @ 10
+6.43/s (n=227)
       Rate old_u   old new_u   new
old_u 106/s    --  -21%  -57%  -79%
old   136/s   27%    --  -45%  -73%
new_u 246/s  131%   82%    --  -51%
new   500/s  370%  269%  103%    --

 new, new_u, old, old_u, each for at least 2 CPU seconds...
       new:  2 wallclock secs ( 2.09 usr +  0.00 sys =  2.09 CPU) @ 51
+0.56/s (n=1065)
     new_u:  5 wallclock secs ( 1.89 usr +  0.13 sys =  2.02 CPU) @ 26
+0.94/s (n=528)
       old:  2 wallclock secs ( 2.14 usr +  0.00 sys =  2.14 CPU) @ 13
+9.21/s (n=298)
     old_u:  3 wallclock secs ( 2.01 usr +  0.03 sys =  2.04 CPU) @ 11
+1.33/s (n=227)
       Rate old_u   old new_u   new
old_u 111/s    --  -20%  -57%  -78%
old   139/s   25%    --  -47%  -73%
new_u 261/s  134%   87%    --  -49%
new   511/s  359%  267%   96%    --
[download]