I took the liberty of taking your code and running with it. Unsurprisingly I added handling arrays, (Which required a modification to your packing scheme, type is tagged at the root level, right after the version string and not at the key/value level as you had it.) As well as code to prevent possible accidental infinite recursion. Additionally I used my personal settings as a test set and benchmarked the two approaches to see what the comparative perfomance was. The results were very interesting. First off, if we rip out DB related code and benchmark the two variants we find that the results are as follows: 

       Rate   old  new
old   115/s    -- -47%
new   215/s   87%   --

[download]

When i then did the benchmark on the server _with_ update code the perfomance changes to as follows: 

     Rate  old  new
old 107/s   -- -61%
new 271/s 153%   --

[download]

These results were somewhat gratifying to me as they appear to validate my point that by using a more compact encoding we reduce the size of the stored data and thus the time required to marshal that data back and forth to the db server. (The update was forced each time by incrementing a counter in the stored hash.) These are the lengths and first chars of the two packed vars: 

L: 11549>external_user=demerphq&scratchpublic=%20
L: 6902 >==01:H&DomainNodeletExtras=&allow_dupe_p

[download]

So overall I think this code is worthy. We probably pack and unpack four or five vars per page fetch. Reducing the load this takes has got to be a good thing for all concerned.

Home test code (needs DDS to be installed) 


use Data::Dump::Streamer;
use strict;
use warnings;

{
no warnings 'uninitialized';

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

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

    return $esc;
}

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

    1;
}

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

sub sVars
{
    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";

sub packVars
{
    my $varsref = $_[0];
    my $seenref = $_[1];

    return unless $varsref;
    return if $seenref->{0+$varsref}++;

    if (eval { ($varsref->[0]||1) }) {
      return join "^","$PackVer:A",
             map {
              my $typ;
              my $v=ref $_ ? packVars( $_, $seenref )  : defined($_) ?
+ $_ : '';
              $v=~s/([~^=])/sprintf '~%02x', ord($1)/ge;
              $v;
             } @$varsref;
    } elsif (eval { ($varsref->{''}||1) }) {
      return join "&", "$PackVer:H",
        map {
            my $v = $varsref->{$_};
            $v=ref $v ? packVars( $v, $seenref )  : defined($v) ? $v :
+ '';
            join '=',
                map {s/([%&=])/ sprintf '%%%02x', ord($1) /ge; $_}
                    $_, $v;
        } sort keys %$varsref;
    } else {
      die "Can't handle vars of type ".ref($varsref)."\n";
    }
}

sub unpackVars
{
    my $vars_str = $_[0];
    return {} unless $vars_str;

    # version 00: original format
    # version 01: keys are escaped, not just values, handles nested re
+fs.

    my $vars;

    #print "$vars_str\n";

    $vars_str =~ s/^(==\d\d):([AH])(.)//;
    my ($format_version,$type,$split)=($1,$2,$3);

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

    unless (defined $format_version) {
        # 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 ($format_version le $PackVer) {
      if ($type eq 'H') {
          for (split /\Q$split\E/, $vars_str) {
              my ($k,$v) = map { s/%(\w\w)/ chr(hex($1)) /ge; $_ }
                           split /=/, $_, -1;

              # special data to unpack?
              if ($v=~/^==\d\d:[AH]/) {
                  # nested value
                  $v = unpackVars($v);
              }
              $vars->{$k} = $v;

          }
      } elsif ($type eq 'A') {
          for (split /\Q$split\E/, $vars_str) {
            s/~(\w\w)/ chr(hex($1)) /ge;
            # special data to unpack?
            if (/^==\d\d:[AH]/) {
                # nested value
                $_ = unpackVars($_);
            }
            push @{$vars},$_;
          }
      } else {
        return "Unknown type! $type";
      }
    } else {
      return "Version number too high! ($format_version gt $PackVer)";
    }
    return $vars;
}

sub cmpVars
{
    my ($var1str, $var2str) = @_;

    my $v1new=$var1str =~ /^==\d\d:[AH]/;
    my $v2new=$var2str =~ /^==\d\d:[AH]/;

    if ($v1new eq $v2new) {
      return $var1str cmp $var2str;
    } else {
      return ( $v1new ? $var1str : packVars( unpackVars ( $var1str ) )
+ )
             cmp
             ( $v2new ? $var2str : packVars( unpackVars ( $var2str ) )
+ )
    }

}

sub _p_str {
  foreach my $str (@_) {
    print "L: ".length($str)." >".substr($str,0,40)."\n";
  }
}

$|++;
my $txt=do{open my $fh,"<","./dem_vars.txt"; local $/; <$fh>};
my $hash=unpackVars($txt);
my $newtxt=packVars($hash);
my $newhash=unpackVars($newtxt);
my $newpack=packVars($newhash);
my $newnewhash=unpackVars($newpack);
my $newnewpack=packVars($newnewhash);
_p_str($txt,$newtxt,$newpack,$newnewpack);
my $n_dump=Dump($newhash)->Out();
my $h_dump=Dump($hash)->Out();
my $nn_dump=Dump($newnewhash)->Out();

if ($n_dump ne $h_dump) {
  print "N - H: Different!\n";
} else {
  print "N - H: Same!\n";
}
if ($nn_dump ne $h_dump) {
  print "NN - H: Different!\n";
} else {
  print "NN - H: Same!\n";
}
if ($nn_dump ne $n_dump) {
  print "NN - N: Different!\n";
} else {
  print "NN - N: Same!\n";
}
use Benchmark qw(cmpthese);
cmpthese -5,{
              old => sub { my $h=gVars($txt); my $str=sVars($h); },
              new_c => sub { my $h=unpackVars($txt); my $str=packVars(
+$h); },
              new => sub { my $h=unpackVars($txt); my $str=packVars($h
+); },
            };

[download]

And the Dumper Prompt Benhcmark Code (in IE this means you have to save the response as a file as the cmpthese output comes before the html, havent figured out a better way to do this yet.) 

my $PackVer="==01";

local *unescape=*Everything::unescape;
local *packVars=sub
{
    my $varsref = $_[0];
    my $seenref = $_[1];

    return unless $varsref;
    return if $seenref->{0+$varsref}++;

    if (eval { ($varsref->[0]||1) }) {
      return join "^","$PackVer:A",
             map {
              my $typ;
              my $v=ref $_ ? packVars( $_, $seenref )  : defined($_) ?
+ $_ : '';
              $v=~s/([~^=])/sprintf '~%02x', ord($1)/ge;
              $v;
             } @$varsref;
    } elsif (eval { ($varsref->{''}||1) }) {
      return join "&", "$PackVer:H",
        map {
            my $v = $varsref->{$_};
            $v=ref $v ? packVars( $v, $seenref )  : defined($v) ? $v :
+ '';
            join '=',
                map {s/([%&=])/ sprintf '%%%02x', ord($1) /ge; $_}
                    $_, $v;
        } sort keys %$varsref;
    } else {
      die "Can't handle vars of type ".ref($varsref)."\n";
    }
};

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

    # version 00: original format
    # version 01: keys are escaped, not just values, handles nested re
+fs.

    my $vars;

    #print "$vars_str\n";

    $vars_str =~ s/^(==\d\d):([AH])(.)//;
    my ($format_version,$type,$split)=($1,$2,$3);

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

    unless (defined $format_version) {
        # 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 ($format_version le $PackVer) {
      if ($type eq 'H') {
          for (split /\Q$split\E/, $vars_str) {
              my ($k,$v) = map { s/%(\w\w)/ chr(hex($1)) /ge; $_ }
                           split /=/, $_, -1;

              # special data to unpack?
              if ($v=~/^==\d\d:[AH]/) {
                  # nested value
                  $v = unpackVars($v);
              }
              $vars->{$k} = $v;

          }
      } elsif ($type eq 'A') {
          for (split /\Q$split\E/, $vars_str) {
            s/~(\w\w)/ chr(hex($1)) /ge;
            # special data to unpack?
            if (/^==\d\d:[AH]/) {
                # nested value
                $_ = unpackVars($_);
            }
            push @{$vars},$_;
          }
      } else {
        return "Unknown type! $type";
      }
    } else {
      return "Version number too high! ($format_version gt $PackVer)";
    }
    return $vars;
};

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

    my $v1new=$var1str =~ /^==\d\d:[AH]/;
    my $v2new=$var2str =~ /^==\d\d:[AH]/;

    if ($v1new eq $v2new) {
      return $var1str cmp $var2str;
    } else {
      return ( $v1new ? $var1str : packVars( unpackVars ( $var1str ) )
+ )
             cmp
             ( $v2new ? $var2str : packVars( unpackVars ( $var2str ) )
+ )
    }

};

local *_p_str=sub  {
  foreach my $str (@_) {
    print "L: ".length($str)." >".substr($str,0,40)."\n";
  }
};

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);
};

#[id://399747]
#[id://396815]

my $NODE1=getNodeById(399747);
my $NODE2=getNodeById(396815);
use Benchmark qw(cmpthese);
cmpthese -1,
{
 old => sub { my $h=getVars($NODE1); $h->{_test}++; setVars($NODE1,$h)
+; },
 new => sub { my $h=new_getVars($NODE2); $h->{_test}++; new_setVars($N
+ODE2,$h); },
};

[download]

---
demerphq

    First they ignore you, then they laugh at you, then they fight you, then you win.
    -- Gandhi

    Flux8


In reply to Re^2: patchable settings (big readmores) by demerphq
in thread patchable settings by ysth

Title:
Use:  <p> text here (a paragraph) </p>
and:  <code> code here </code>
to format your post, it's "PerlMonks-approved HTML":


  • Posts are HTML formatted. Put <p> </p> tags around your paragraphs. Put <code> </code> tags around your code and data!
  • Titles consisting of a single word are discouraged, and in most cases are disallowed outright.
  • Read Where should I post X? if you're not absolutely sure you're posting in the right place.
  • Please read these before you post! —
  • Posts may use any of the Perl Monks Approved HTML tags:
    a, abbr, b, big, blockquote, br, caption, center, col, colgroup, dd, del, details, div, dl, dt, em, font, h1, h2, h3, h4, h5, h6, hr, i, ins, li, ol, p, pre, readmore, small, span, spoiler, strike, strong, sub, summary, sup, table, tbody, td, tfoot, th, thead, tr, tt, u, ul, wbr
  • You may need to use entities for some characters, as follows. (Exception: Within code tags, you can put the characters literally.)
            For:     Use:
    & &amp;
    < &lt;
    > &gt;
    [ &#91;
    ] &#93;
  • Link using PerlMonks shortcuts! What shortcuts can I use for linking?
  • See Writeup Formatting Tips and other pages linked from there for more info.