#!/usr/bin/perl -w

use strict;
use vars qw($PLACEHOLDER);
use Benchmark qw(cmpthese);
use CGI::Ex::Conf;
use POSIX qw(tmpnam);

$PLACEHOLDER = chr(186).'~'.chr(186);

my $n = -2;

my $cob   = CGI::Ex::Conf->new;
my %files = ();

###----------------------------------------------------------------###

#           Rate  yaml2   yaml    xml    ini g_conf     pl    sto   sto2  yaml3
#yaml2     159/s     --    -1%   -72%   -80%   -91%   -95%   -98%   -98%  -100%
#yaml      160/s     1%     --   -72%   -80%   -91%   -95%   -98%   -98%  -100%
#xml       565/s   255%   253%     --   -28%   -68%   -84%   -93%   -94%  -100%
#ini       785/s   393%   391%    39%     --   -55%   -78%   -90%   -91%   -99%
#g_conf   1756/s  1004%   998%   211%   124%     --   -50%   -78%   -80%   -98%
#pl       3524/s  2115%  2103%   524%   349%   101%     --   -55%   -61%   -97%
#sto      7838/s  4826%  4799%  1288%   898%   346%   122%     --   -12%   -93%
#sto2     8924/s  5508%  5477%  1480%  1037%   408%   153%    14%     --   -92%
#yaml3  113328/s 71115% 70730% 19961% 14336%  6353%  3116%  1346%  1170%     -- #memory

my $str = '{
  foo     => {key1 => "bar",   key2 => "ralph"},
  pass    => {key1 => "word",  key2 => "ralph"},
  garbage => {key1 => "can",   key2 => "ralph"},
  mighty  => {key1 => "ducks", key2 => "ralph"},
  quack   => {key1 => "moo",   key2 => "ralph"},
  one1    => {key1 => "val1",  key2 => "ralph"},
  one2    => {key1 => "val2",  key2 => "ralph"},
  one3    => {key1 => "val3",  key2 => "ralph"},
  one4    => {key1 => "val4",  key2 => "ralph"},
  one5    => {key1 => "val5",  key2 => "ralph"},
  one6    => {key1 => "val6",  key2 => "ralph"},
  one7    => {key1 => "val7",  key2 => "ralph"},
  one8    => {key1 => "val8",  key2 => "ralph"},
}';

###----------------------------------------------------------------###

#           Rate   yaml  yaml2    xml g_conf     pl    sto   sto2  yaml3
#yaml      431/s     --    -2%   -61%   -91%   -94%   -97%   -98%  -100%
#yaml2     438/s     2%     --   -60%   -91%   -94%   -97%   -98%  -100%
#xml      1099/s   155%   151%     --   -78%   -85%   -92%   -94%   -99%
#g_conf   4990/s  1057%  1038%   354%     --   -33%   -64%   -72%   -96%
#pl       7492/s  1637%  1609%   582%    50%     --   -46%   -58%   -93%
#sto     13937/s  3130%  3078%  1169%   179%    86%     --   -22%   -88%
#sto2    17925/s  4055%  3988%  1532%   259%   139%    29%     --   -84%
#yaml3  114429/s 26423% 25996% 10316%  2193%  1427%   721%   538%     -- # memory

#$str = '{
#  foo     => "bar",
#  pass    => "word",
#  garbage => "can",
#  mighty  => "ducks",
#  quack   => "moo",
#  one1    => "val1",
#  one2    => "val2",
#  one3    => "val3",
#  one4    => "val4",
#  one5    => "val5",
#  one6    => "val6",
#  one7    => "val7",
#  one8    => "val8",
#}';

###----------------------------------------------------------------###

my $conf = eval $str;

my %TESTS = ();

### do perl
my $file = tmpnam(). '.pl';
open OUT, ">$file";
print OUT $str;
close OUT;
$TESTS{pl} = sub {
  my $hash = $cob->read_ref($file);
};
$files{pl} = $file;

### do a generic conf_write
my $file2 = tmpnam(). '.g_conf';
&generic_conf_write($file2, $conf);
local $CGI::Ex::Conf::EXT_READERS{g_conf} = \&generic_conf_read;
$TESTS{g_conf} = sub {
  my $hash = $cob->read_ref($file2);
};
$files{g_conf} = $file2;


if (eval {require JSON}) {
  my $_file = tmpnam(). '.json';
  my $str = JSON::objToJson($conf, {pretty => 1, indent => 2});
  open(my $fh, ">$_file");
  print $fh $str;
  $TESTS{json} = sub {
    my $hash = $cob->read_ref($_file);
  };
  $TESTS{json2} = sub {
    open(my $fh, "<$_file") || die "Couldn't open file: $!";
    read($fh, my $str, -s $_file);
    my $hash = JSON::jsonToObj($str);
  };
  $files{json} = $_file;
}


### load in the rest of the tests that we support
if (eval {require Storable}) {
  my $_file = tmpnam(). '.sto';
  &Storable::store($conf, $_file);
  $TESTS{sto} = sub {
    my $hash = $cob->read_ref($_file);
  };
  $files{sto} = $_file;
}

if (eval {require Storable}) {
  my $_file = tmpnam(). '.sto2';
  &Storable::store($conf, $_file);
  $TESTS{sto2} = sub {
    my $hash = &Storable::retrieve($_file);
  };
  $files{sto2} = $_file;
}

if (eval {require YAML}) {
  my $_file = tmpnam(). '.yaml';
  &YAML::DumpFile($_file, $conf);
  $TESTS{yaml} = sub {
    my $hash = $cob->read_ref($_file);
  };
  $files{yaml} = $_file;
}

if (eval {require YAML}) {
  my $_file = tmpnam(). '.yaml2';
  &YAML::DumpFile($_file, $conf);
  $TESTS{yaml2} = sub {
    my $hash = &YAML::LoadFile($_file);
  };
  $files{yaml2} = $_file;
}

if (eval {require YAML}) {
  my $_file = tmpnam(). '.yaml';
  &YAML::DumpFile($_file, $conf);
  $cob->preload_files($_file);
  $TESTS{yaml3} = sub {
    my $hash = $cob->read_ref($_file);
  };
  $files{yaml3} = $_file;
}

if (eval {require Config::IniHash}) {
  my $_file = tmpnam(). '.ini';
  &Config::IniHash::WriteINI($_file, $conf);
  $TESTS{ini} = sub {
    local $^W = 0;
    my $hash = $cob->read_ref($_file);
  };
  $files{ini} = $_file;
}

if (eval {require XML::Simple}) {
  my $_file = tmpnam(). '.xml';
  my $xml = XML::Simple->new->XMLout($conf);
  open  OUT, ">$_file" || die $!;
  print OUT $xml;
  close OUT;
  $TESTS{xml} = sub {
    my $hash = $cob->read_ref($_file);
  };
  $files{xml} = $_file;
}

### tell file locations
foreach my $key (sort keys %files) {
  print "$key => $files{$key}\n";
}

cmpthese($n, \%TESTS);

### comment out this line to inspect files
unlink $_ foreach values %files;

###----------------------------------------------------------------###

sub generic_conf_read {
  my $_file = shift || die "No filename supplied";
  my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;

  ### fh will now lose scope and close itself if necessary
  my $FH = do { local *FH; *FH };
  open ($FH, $_file) || return {};

  my $x = 0;
  my $conf = {};
  my $key  = '';
  my $val;
  my $line;
  my ($is_array,$is_hash,$is_multiline);
  my $order;
  $order = [] if wantarray;

  while( defined($line = <$FH>) ){
    last if ! defined $line;
    last if $x++ > 10000;

    next if index($line,'#') == 0;

    if ($line =~ /^\s/ && ($is_multiline || $line ne "\n")){
      next if ! length($key);
      $conf->{$key} .= $line;
      $is_multiline = 1;

    }else{
      ### duplicate trim section
      if( length($key) ){
        $conf->{$key} =~ s/\s+$//;
        if( $is_array || $is_hash ){
          $conf->{$key} =~ s/^\s+//;
          my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
          my @pieces;
          if ($sep_by_newlines) {
            @pieces = split(/\s*\n\s*/,$conf->{$key});
            @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
          } else {
            @pieces = split(/\s+/,$conf->{$key});
          }
          if( $urldec ){
            foreach my $_val (@pieces){
              $_val =~ y/+/ / if ! $sep_by_newlines;
              $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
            }
          }
          if( $is_array ){
            foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
            $conf->{$key} = \@pieces;
          }elsif( $is_hash ){
            foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
            shift(@pieces) if scalar(@pieces) % 2;
            $conf->{$key} = {@pieces};
          }
        }elsif( ! $is_multiline ){
          $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
          $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
        }
      }

      ($key,$val) = split(/\s+/,$line,2);
      $is_array = 0;
      $is_hash = 0;
      $is_multiline = 0;
      if (! length($key)) {
        next;
      } elsif (index($key,'array:') == 0) {
        $is_array = $key =~ s/^array://i;
      } elsif (index($key,'hash:') == 0) {
        $is_hash = $key =~ s/^hash://i;
      }
      $key =~ y/+/ / if ! $sep_by_newlines;
      $key =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
      $conf->{$key} = $val;
      push @$order, $key if $order;
    }
  }

  ### duplicate trim section
  if( length($key) && defined($conf->{$key}) ){
    $conf->{$key} =~ s/\s+$//;
    if( $is_array || $is_hash ){
      $conf->{$key} =~ s/^\s+//;
      my $urldec = (index($conf->{$key},'%')>-1 || index($conf->{$key},'+')>-1);
      my @pieces;
      if ($sep_by_newlines) {
        @pieces = split(/\s*\n\s*/,$conf->{$key});
        @pieces = map {split(/\s+/,$_,2)} @pieces if $is_hash;
      } else {
        @pieces = split(/\s+/,$conf->{$key});
      }
      if( $urldec ){
        foreach my $_val (@pieces){
          $_val =~ y/+/ / if ! $sep_by_newlines;
          $_val =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
        }
      }
      if( $is_array ){
        foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
        $conf->{$key} = \@pieces;
      }elsif( $is_hash ){
        foreach (@pieces){ $_="" if index($_,$PLACEHOLDER)>-1 }
        shift(@pieces) if scalar(@pieces) % 2;
        $conf->{$key} = {@pieces};
      }
    }elsif( ! $is_multiline ){
      $conf->{$key} =~ y/+/ / if ! $sep_by_newlines;
      $conf->{$key} =~ s/%([a-f0-9]{2})/chr(hex($1))/egi;
    }
  }


  close($FH);
  return $order ? ($conf,$order) : $conf;
}


sub generic_conf_write{
  my $_file = shift || die "No filename supplied";

  if (! @_) {
    return;
  }

  my $new_conf = shift || die "Missing update hashref";
  return if ! keys %$new_conf;


  ### do we allow writing out hashes in a nice way
  my $sep_by_newlines = ($_[0] && lc($_[0]) eq 'sep_by_newlines') ? 1 : 0;

  ### touch the file if necessary
  if( ! -e $_file ){
    open(TOUCH,">$_file") || die "Conf file \"$_file\" could not be opened for writing: $!";
    close(TOUCH);
  }

  ### read old values
  my $conf = &generic_conf_read($_file) || {};
  my $key;
  my $val;

  ### remove duplicates and undefs
  while (($key,$val) = each %$new_conf){
    $conf->{$key} = $new_conf->{$key};
  }

  ### prepare output
  my $output = '';
  my $qr = qr/([^\ \!\"\$\&-\*\,-\~])/;
  foreach $key (sort keys %$conf){
    next if ! defined $conf->{$key};
    $val = delete $conf->{$key};
    $key =~ s/([^\ \!\"\$\&-\*\,-9\;-\~\/])/sprintf("%%%02X",ord($1))/eg;
    $key =~ tr/\ /+/;
    my $ref = ref($val);
    if( $ref ){
      if( $ref eq 'HASH' ){
        $output .= "hash:$key\n";
        foreach my $_key (sort keys %$val){
          my $_val = $val->{$_key};
          next if ! defined $_val;
          $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
          $_key =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
          if ($sep_by_newlines) {
            $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
            $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
            $_key =~ s/\ /%20/g;
          } else {
            $_val =~ tr/\ /+/;
            $_key =~ tr/\ /+/;
          }
          $_val = $PLACEHOLDER if ! length($_val);
          $output .= "\t$_key\t$_val\n";
        }
      }elsif( $ref eq 'ARRAY' ){
        $output .= "array:$key\n";
        foreach (@$val){
          my $_val = $_;
          $_val =~ s/$qr/sprintf("%%%02X",ord($1))/ego;
          if ($sep_by_newlines) {
            $_val =~ s/^(\s)/sprintf("%%%02X",ord($1))/ego;
            $_val =~ s/(\s)$/sprintf("%%%02X",ord($1))/ego;
          } else {
            $_val =~ tr/\ /+/;
          }
          $_val = $PLACEHOLDER if ! length($_val);
          $output .= "\t$_val\n";
        }
      }else{
        $output .= "$key\tbless('$val','$ref')\n"; # stringify the ref
      }
    }else{
      if( $val =~ /\n/ ){ # multiline values that are indented properly don't need encoding
        if( $val =~ /^\s/ || $val =~ /\s$/ || $val =~ /\n\n/ || $val =~ /\n([^\ \t])/ ){
          if ($sep_by_newlines) {
            $val =~ s/([^\!\"\$\&-\~])/sprintf("%%%02X",ord($1))/eg;
          } else {
            $val =~ s/([^\ \!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
            $val =~ y/ /+/;
          }
        }
      }else{
        $val =~ s/([^\ \t\!\"\$\&-\*\,-\~])/sprintf("%%%02X",ord($1))/eg;
        $val =~ s/^(\s)/sprintf("%%%02X",ord($1))/eg;
        $val =~ s/(\s)$/sprintf("%%%02X",ord($1))/eg;
      }
      $output .= "$key\t$val\n";
    }
  }

  open (CONF,"+<$_file") || die "Could not open the file for writing ($_file) -- [$!]";
  print CONF $output;
  truncate CONF, length($output);
  close CONF;

  return 1;
}

1;