view release on metacpan or  search on metacpan

lib/Data/Shark/DIO.pm  view on Meta::CPAN

    } else {
      $stmt .= '  my ($args) = @_;' . "\n" if $dioh->{'cd_type'} eq 'SQL::Abstract';
    }

    # initial audit section
    $audit =~ /[ADB]/ && do {
      $stmt .= "\n" . '  my $ca_id = ' . $ns . '::D_DIO::dio_audit_insert({ca_id => 0,ca_cd_id => ' . $dioh->{'cd_id'} . ',ca_ip => Apache->request->connection->remote_ip,user => $args->{\'user\'}});' . "\n\n";
    };

    # add inkeys for audit if requested
    $audit =~ /[DB]/ && $in_keys && do {
      foreach my $k (keys %{ $in_keys }) {
        $stmt .= '  ' . $ns . '::D_DIO::dio_audit_inkey({ci_ca_id => $ca_id, ci_pos => ' . $k . ', ci_tag => \'' . $in_keys->{$k}{'name'} . '\', ci_value => $args{\'' . $in_keys->{$k}{'name'} . '\'}});' . "\n\n";
      }
    };

    # profile section
    $profile && do {
      $stmt .= '  $' . $p_tag . ' = $' . $p_tag . ' || new Cache::FileCache( {\'namespace\' => \'' . $ns . '_dio_profile\'});' . "\n";
      my $cf = '';
      $cf = '*' if $dioh->{'cd_cache'} eq 'F';
      $stmt .= '  my $pkey = \'' . $diotag . '\';' . "\n";
      if ($in_keys) {
        foreach my $k (@{ $in_keys }{ sort {$a <=> $b} keys %{ $in_keys } }) {
          $stmt .= '  $pkey .= \', \' . $args->{\'' . $k->{'name'} . '\'};' . "\n" if $k->{'name'};
        } 
      }
      $stmt .= '  my $pdata = $' . $p_tag . '->get(\'' . $dions . ',' . $diotag . $cf . '\');' . "\n";
      $stmt .= '  my $t = time();' . "\n";
      $stmt .= '  push @{ $pdata->{\'args\'}{$t} }, $pkey;' . "\n";
      $pstmt = '  push @{ $pdata->{\'time\'}{$t} }, time();' . "\n";
      $pstmt .= '  $' . $p_tag . '->set(\'' . $dions . ',' . $diotag . $cf . '\',$pdata);' . "\n";  
    };

    # cache exp section
    if ($exps) {
      $stmt .= '  my $c;' . "\n";
      # expire dependent keys
      foreach my $k (keys %{ $exps }) {
#        if (ref($dio_list->{$diotag}{'cache_exp'}{$k}) eq 'REF') {
#
#        } else {
          $stmt .= '  $c = new Cache::FileCache({\'namespace\' => \'' . $ns . '_' . $exps->{$k}{'namespace'} . '.' . $k .'\'});' . "\n";
          $stmt .= '  $c->clear() if $c;' . "\n";
#        }
      }
    }
    # cache section
    if ($dioh->{'cd_cache'} eq 'F') {
      # clear existing cache on startup
      my $tc = new Cache::FileCache({'namespace' => $ns . '_' . $dions . '.' . $diotag});
      $tc->clear() if !$debug;
      # setup cache
      $stmt .= '  $' . $c_tag . ' = $' . $c_tag . ' || new Cache::FileCache( {\'namespace\' => \'' . $ns . '_' . $dions . '.' . $diotag . '\'});' . "\n";
      $stmt .= '  my $hkey = \'' . $diotag . '\';' . "\n";
      if ($in_keys) {
        foreach my $k (@{ $in_keys }{ sort {$a <=> $b} keys %{ $in_keys } }) {
          $stmt .= '  $hkey .= $args->{\'' . $k->{'name'} . '\'};' . "\n" if $k->{'name'};
        } 
      }
      $stmt .= '  my $cdata = $' . $c_tag . '->get($hkey);' . "\n";
      $stmt .= 'if ($cdata) { ' . $pstmt . '}' . "\n" if $profile;
      $stmt .= '  return $cdata if $cdata;' . "\n";
    }
    $stmt .= '  my $dbi = ' . $config->{'dbi_func'} . ';' . "\n"; 
    $stmt .= '  my $sth;' . "\n\n";

    # process input
    for ($dioh->{'cd_type'}) {
      /^DBI$/ && do {
        if ($in_keys) {
          $dioh->{'cd_stmt'} =~ s/'/\\'/g;
          $stmt .= '  my $sql = q{' . $dioh->{'cd_stmt'} . '};' . "\n";
          # check for tag based in keys
          my $have_tags = 0;
          foreach my $k (@{ $in_keys }{ keys %{ $in_keys } }) {
            if ($k->{'opt'} eq 'tag_based') {
              unless ($have_tags) {
                $stmt .= '  my %tag_hash;' . "\n";
                $have_tags = 1;
              }
              $k->{'default'} =~ s/[\r\n]/ /g;
              $stmt .= '  if (exists $args->{\'' . $k->{'name'} . '\'} && $args->{\'' . $k->{'name'} . '\'} ne \'\') {' . "\n";
              $stmt .= '    $sql =~ s/:' . $k->{'name'} . '/' . $k->{'default'} . '/;' . "\n"; 
              # check for placeholders
              if ($k->{'default'} =~ /:placeholders/) {
                $stmt .= '    if (ref $args->{\'' . $k->{'name'} . '\'} eq \'ARRAY\') {' . "\n";
                $stmt .= '      $tag_hash{' . $k->{'name'} . '} = $args->{\'' . $k->{'name'} . '\'};' . "\n";
                $stmt .= '    } else {' . "\n";
                $stmt .= '      $tag_hash{' . $k->{'name'} . '} = [$args->{\'' . $k->{'name'} . '\'}];' . "\n";
                $stmt .= '    }' . "\n";
                $stmt .= '    my $placeholders = join(\', \', map { \'?\' } @{$tag_hash{' . $k->{'name'} . '}});' . "\n";
                $stmt .= '    $sql =~ s/' . $k->{'name'} . ':placeholders/$placeholders/;' . "\n"; 
              } else {
                if (index($k->{'default'}, '?') >= 0) {
                  $stmt .= '    if (ref $args->{\'' . $k->{'name'} . '\'} eq \'ARRAY\') {' . "\n";
                  $stmt .= '      $tag_hash{' . $k->{'name'} . '} = $args->{\'' . $k->{'name'} . '\'};' . "\n";
                  $stmt .= '    } else {' . "\n";
                  $stmt .= '      $tag_hash{' . $k->{'name'} . '} = [$args->{\'' . $k->{'name'} . '\'}];' . "\n";
                  $stmt .= '    }' . "\n";
                } else {
                  $k->{'no_bind'} = 1;
                }
              }
              $stmt .= '  } else {' . "\n";
              $stmt .= '    $sql =~ s/:' . $k->{'name'} . '//;' . "\n"; 
              $stmt .= '  }' . "\n";
            }
          }
          
          my $extra = "";
          # check for limit or offset
          foreach my $k (@{ $in_keys }{ keys %{ $in_keys } }) {
            for ($k->{'name'}) {
              /^limit$/ && do { $extra .= ' limit \' . $args->{\'limit\'} . \''; last; };
              /^mysql_limit$/ && do { $extra .= ' limit \' . $args->{\'mysql_limit\'} . \''; last; };
              /^offset$/ && do { $extra .= ' offset \' . $args->{\'offset\'} . \''; last; };
            }
          }
          $stmt .= '  $sth = $dbi->db_prep($sql' . ($extra ? ' . q{' . $extra . '}' : '') . ');' . "\n";
          if ($have_tags) {
            $stmt .= '  my @binds;' . "\n";
            foreach my $k (@{ $in_keys }{ sort {$a <=> $b} keys %{ $in_keys } }) {