view release on metacpan or  search on metacpan

lib/CGI/Ex/Conf.pm  view on Meta::CPAN

  ### do has odd behavior in that it turns a simple hashref
  ### into hash - help it out a little bit
  my @ref = do $file;
  return ($#ref != 0) ? {@ref} : $ref[0];
}

sub read_handler_json {
  my $file = shift;
  local *IN;
  open (IN, $file) || die "Couldn't open $file: $!";
  CORE::read(IN, my $text, -s $file);
  close IN;
  require JSON;
  my $decode = JSON->can('decode') ? 'decode' : 'jsonToObj';
  return scalar JSON->new->$decode($text);
}

sub read_handler_storable {
  my $file = shift;
  require Storable;
  return Storable::retrieve($file);
}

sub read_handler_yaml {
  my $file = shift;
  local *IN;
  open (IN, $file) || die "Couldn't open $file: $!";
  CORE::read(IN, my $text, -s $file);
  close IN;
  return yaml_load($text);
}

sub yaml_load {
  my $text = shift;
  require YAML;
  my @ret = eval { YAML::Load($text) };
  if ($@) {
    die "$@";
  }
  return ($#ret == 0) ? $ret[0] : \@ret;
}

sub read_handler_xml {
  my $file = shift;
  require XML::Simple;
  return XML::Simple::XMLin($file);
}

### this handler will only function if a html_key (such as validation)
### is specified - actually this somewhat specific to validation - but
### I left it as a general use for other types

### is specified
sub read_handler_html {
  my $file = shift;
  my $args = shift;
  if (! eval { require YAML }) {
    my $err   = $@;
    my $found = 0;
    my $i     = 0;
    while (my($pkg, $file, $line, $sub) = caller($i++)) {
      return undef if $sub =~ /\bpreload_files$/;
    }
    die $err;
  }

  ### get the html
  local *IN;
  open (IN, $file) || return undef;
  CORE::read(IN, my $html, -s $file);
  close IN;

  return html_parse_yaml_load($html, $args);
}

sub html_parse_yaml_load {
  my $html = shift;
  my $args = shift || {};
  my $key  = $args->{html_key} || $HTML_KEY;
  return undef if ! $key || $key !~ /^\w+$/;

  my $str = '';
  my @order = ();
  while ($html =~ m{
    (document\.    # global javascript
     | var\s+      # local javascript
     | <\w+\s+[^>]*?) # input, form, select, textarea tag
      \Q$key\E   # the key
      \s*=\s*    # an equals sign
      ([\"\'])   # open quote
      (.+?[^\\]) # something in between
      \2        # close quote
    }xsg) {
    my ($line, $quot, $yaml) = ($1, $2, $3);
    if ($line =~ /^(document\.|var\s)/) { # js variable
      $yaml =~ s/\\$quot/$quot/g;
      $yaml =~ s/\\n\\\n?/\n/g;
      $yaml =~ s/\\\\/\\/g;
      $yaml =~ s/\s*$/\n/s; # fix trailing newline
      $str = $yaml; # use last one found
    } else { # inline attributes
      $yaml =~ s/\s*$/\n/s; # fix trailing newline
      if ($line =~ m/<form/i) {
        $yaml =~ s/^\Q$1\E//m if $yaml =~ m/^( +)/s;
        $str .= $yaml;

      } elsif ($line =~ m/\bname\s*=\s*('[^\']*'|"[^\"]*"|\S+)/) {
        my $key = $1;
        push @order, $key;
        $yaml =~ s/^/ /mg; # indent entire thing
        $yaml =~ s/^(\ *[^\s&*\{\[])/\n$1/; # add first newline
        $str .= "$key:$yaml";
      }
    }
  }
  $str .= "group order: [".join(", ",@order)."]\n"
    if $str && $#order != -1 && $key eq 'validation';

  return undef if ! $str;
  my $ref = eval { yaml_load($str) };
  if ($@) {