#!/usr/bin/perl -w

use strict;
use vars qw($PLACEHOLDER);
use Benchmark qw(cmpthese timethese);
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   yaml  yaml2    sto     pl    xml g_conf    ini   sto2
#yaml    250/s     --    -1%   -14%   -14%   -61%   -77%   -95%   -95%
#yaml2   254/s     1%     --   -13%   -13%   -60%   -77%   -95%   -95%
#sto     292/s    17%    15%     --    -0%   -54%   -73%   -94%   -95%
#pl      292/s    17%    15%     0%     --   -54%   -73%   -94%   -95%
#xml     636/s   155%   151%   118%   118%     --   -42%   -88%   -88%
#g_conf 1088/s   335%   329%   273%   272%    71%     --   -79%   -80%
#ini    5144/s  1958%  1929%  1662%  1660%   708%   373%     --    -3%
#sto2   5321/s  2029%  1999%  1723%  1721%   736%   389%     3%     --

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     pl    sto    xml g_conf   sto2
#yaml    736/s     --    -3%   -20%   -21%   -62%   -72%   -89%
#yaml2   755/s     3%     --   -18%   -19%   -61%   -71%   -89%
#pl      923/s    25%    22%     --    -1%   -53%   -65%   -86%
#sto     928/s    26%    23%     1%     --   -53%   -65%   -86%
#xml    1961/s   166%   160%   113%   111%     --   -26%   -71%
#g_conf 2635/s   258%   249%   185%   184%    34%     --   -61%
#sto2   6824/s   827%   803%   639%   635%   248%   159%     --

#$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 $dir = tmpnam;
mkdir $dir, 0755;
my $tmpnam = "$dir/bench";
my $file = $tmpnam. '.pl';
$TESTS{pl} = sub {
  $cob->write_ref($file, $str);
};
$files{pl} = $file;

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


### load in the rest of the tests that we support
if (eval {require JSON}) {
  my $_file = tmpnam(). '.json';
  $TESTS{json} = sub {
    $cob->write_ref($file, $str);
  };
  $files{json} = $_file;
}

if (eval {require Storable}) {
  my $_file = $tmpnam. '.sto';
  $TESTS{sto} = sub {
    $cob->write_ref($file, $str);
  };
  $files{sto} = $_file;
}

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

if (eval {require YAML}) {
  my $_file = $tmpnam. '.yaml';
  $TESTS{yaml} = sub {
    $cob->write_ref($_file, $str);
  };
  $files{yaml} = $_file;
}

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

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

if (eval {require XML::Simple}) {
  my $_file = $tmpnam. '.xml';
  $TESTS{xml} = sub {
    $cob->write_ref($_file, $str);
  };
  $files{xml} = $_file;
}

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

foreach my $key (keys %TESTS) {
  eval { &{ $TESTS{$key} } };
  if ($@) {
    warn "Test for $key failed - skipping";
    delete $TESTS{$key};
  }
}


cmpthese timethese ($n, \%TESTS);

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

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

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;