local.*@ARGV results from the CPAN

DBIx-BulkUtil

view release on metacpan or search on metacpan

  : @drop_cols        ? grep !$drop{$_}, @$hdr
  : @$hdr;
  my %hdr_idx; @hdr_idx{@$hdr} = 0..$#$hdr;

  $csv->print($out_fh, [@$hdr[@hdr_idx{@cols}]]) if $opts->{Header};
  while ( my $row = $csv->getline_hr($in_fh) ) {
    $csv->print($out_fh, [@$row{@cols}]);
  }
  close $in_fh;
  close $out_fh;
}

sub add_header {
  my ($self, $table, $file, $opts) = @_;
  $opts ||= {};

  my $cols;
  if ( $opts->{Header} || $opts->{Columns} ) {
    my $sel_str =
      $opts->{Columns}
      ?  ref($opts->{Columns})
        ? join(",", @{$opts->{Columns}})
        : $opts->{Columns}
      : '*';
    my $sth = $self->{DBH}->prepare("SELECT $sel_str FROM $table WHERE 1=0");
    $sth->execute();
    $cols = $sth->{NAME_lc};
    $sth->finish();
  }

  return $self->add_quotes($table, $file, $cols, $opts) if $opts->{QuoteFields};

  # If quotes are not required, this is more efficient
  # I doubt anyone uses either option anyway
  # but highly doubt anyone uses the quoting
  require File::Copy;
  my $d = $opts->{Delimiter} || $self->{DELIMITER};
  local $/ = $opts->{RowDelimiter} || "\n";

  open(my $fh, ">", "$file.bak") or die "Failed to open $file.bak: $!";

  # Unbuffer the filehandle for printing header
  # because File::Copy uses unbuffered syswrite
  # $fh->flush() after the print would also work depending on
  # version of perl and whether IO::Handle is loaded
  for ( select $fh ) { $| = 1; select $_ }
  print $fh join($d, @$cols), $/;

  File::Copy::copy($file, $fh) or die "Failed to copy $file to $file.bak: $!";
  close $fh;

  return "$file.bak";
}

sub add_quotes {
  my ($self, $table, $file, $cols, $opts) = @_;
  my $d = $opts->{Delimiter} || $self->{DELIMITER};
  my $dre = quotemeta($d);

  local ($_, $., $ARGV, *ARGV);
  local ( $^I, @ARGV ) = ( '.bak', $file );
  local $/ = $opts->{RowDelimiter} || "\n";
  my $done;
  while ( <> ) {
    print join($d, @$cols), $/ if !$done++ && $opts->{Header};

    if ($opts->{QuoteFields}) {
      chomp;
      my @fields = split /$dre/;
      /\s/ and $_ = qq("$_") for @fields;
      $_ = join($d, @fields) . $/;
    }
    print;
  }
  return "$file.bak";
}

sub type {
  my $self = shift;
  return $self->{DBH}{Driver}{Name};
}

# Because of Sybase and its stupid mixed case column names,
# we need to be able to find the actual cased name for a given
# uncased column name.
# Just pray that there are not two columns with the same name
# in the same table that are differently cased.
memoize('column_info');

sub column_info {
  my $self = shift;
  my $table = shift;

  my $schema;
  my $dbtype = $self->type();
  my ($tmp_db, $curr_db) = (undef,'');
  my $dbh = $self->{DBH};
  my %col_dflt;
  if ( $dbtype eq 'Oracle' ) {
    $table = uc($table);
    if ( $table =~ /^(\w+)\.(\w+)$/ ) {
      ($schema, $table) = ($1,$2);
    } else { $schema = $self->curr_schema() }
  } elsif ( $dbtype eq 'Sybase' ) {

    $tmp_db = $curr_db = $self->curr_db();

    if ( $table =~ /^#/ ) {
      $table = $self->temp_table_name($table);
    }

    if ( $table =~ /^(?:(\w+)\.)?(\w*)\.(#?\w+)$/ ) {
      ($tmp_db, $schema, $table) = ($1,$2,$3);
      $schema ||= undef;

      # We can only get column info on the current database
      $dbh->do("USE $tmp_db") if defined($tmp_db) and $tmp_db ne $curr_db;
    }

    $schema ||= '%';

lib/DBIx/BulkUtil.pm view on Meta::CPAN


  my $curr_db = $self->curr_db();
  if ( !$curr_db and $table =~ /^(\w+)\.\w*\.\w+$/ ) {
    $curr_db = $1;
  }
  confess "Can not determine database" unless $curr_db;

  my $base_table =
    (!$curr_db or $table =~ /^\w+\.\w*\.\w+$/)  ? $table
  : ($table =~ /^\w+$/)                         ? "$curr_db..$table"
  : ($table =~ /^\w*\.\w+$/)                    ? "$curr_db.$table"
  : confess "Can not determine database for view";

  ( my $tmp_view = $base_table ) =~ s/.*\.//;
  $tmp_view = substr($tmp_view, 0, 19) if length($tmp_view) > 19;

  $dbh->do("USE $scratchdb") unless $self->is_iq();

  my $cnt;
  while (1) {
    my ($sec, $min, $hr) = localtime;
    my $id = sprintf("%05d%02d%02d%02d", $$, $hr, $min, $sec);

    $view = "${tmp_view}${id}";
    $db_view = $self->is_iq() ? $view : "$scratchdb..$view";
    my $sql = sprintf(
      "CREATE VIEW %s AS SELECT %s FROM %s",
      $view,
      $column_str,
      $base_table,
    );
    $sql .= " $opts[0]{Filter}" if @opts && $opts[0]{Filter};
    print "Creating view $db_view\n";
    print "Executing: $sql\n";
    my $result = eval { $dbh->do($sql) };
    return $view if $result;
    confess $@ unless $@ =~ /already an object/;
    $cnt++;
    confess "Too many retries trying to create view $db_view. Aborting"
      if $cnt > 20;
    print "View $db_view already exists, retrying #$cnt...";
    sleep 2;
  }

}

# Fix native date format from Sybase bcp out
{   my %mons = qw( Jan 1 Feb 2 Mar 3 Apr 4 May 5 Jun 6 Jul 7 Aug 8 Sep 9 Oct 10 Nov 11 Dec 12 );
    my $mon_str = join '|', keys %mons;
    my $mon_re = qr/$mon_str/;

    sub fix_bcp_file {
        my ( $self, $file ) = @_;
        my $opts = {};
        if (ref $_[-1]) {
          $opts = pop @_;
        }
        my $delimiter = $opts->{Delimiter} || $self->{DELIMITER} || '|';
        my $dre = quotemeta($delimiter);
        local ($_, $., $ARGV, *ARGV);
        local ( $^I, @ARGV ) = ( '.bak', $file );
        local $/ = $opts->{RowDelimiter} || $/;
        while ( <> ) {
            1 while s!(^|$dre)($mon_re)\s{1,2}(\d{1,2})\s(\d{4})\s\s?(\d\d?):(\d\d):(\d\d):(\d{3})([AP])M($dre|$/)!
              $1 .
              sprintf( '%04d-%02d-%02d %02d:%02d:%02d.%03d',
                $4,
                $mons{ $2 },
                $3,
                ( $9 eq 'P' && $5 < 12) ? $5 + 12 : ( $9 eq 'A' && $5 == 12 ) ? 0 : $5,
                $6,
                $7,
                $8 ) .
              $10
            !eg;
            1 while s!(^|$dre)($mon_re)\s{1,2}(\d{1,2})\s(\d{4})\s\s?(\d\d?):(\d\d)([AP])M($dre|$/)!
              $1 .
              sprintf( '%04d-%02d-%02d %02d:%02d',
                $4,
                $mons{ $2 },
                $3,
                ( $7 eq 'P' && $5 < 12) ? $5 + 12 : ( $7 eq 'A' && $5 == 12 ) ? 0 : $5,
                $6 ) .
              $8
            !eg;
            1 while s!(^|$dre)($mon_re)\s{1,2}(\d{1,2})\s(\d{4})($dre|$/)!
              $1 .
              sprintf( '%04d-%02d-%02d',
                $4,
                $mons{ $2 },
                $3 ) .
              $5
            !eg;
            print;
        }
        return "$file.bak";
    }
}

{
my %type_map = ( 'V' => 'V', 'P' => 'P', 'U' => 'T' );

sub obj_type {
  my ( $self, $name ) = @_;
  my $dbh = $self->{DBH};
  my $qname = $dbh->quote($name);
  my ( $type ) = $dbh->selectrow_array("select type from sysobjects where name = $qname");
  return unless $type;
  return $type_map{$type} || confess "Don't know about type $type for object $name";
}
}

sub curr_db { 
  my $self = shift;

  $self->get('db_name()');
}

sub curr_schema { undef }

{

lib/DBIx/BulkUtil.pm view on Meta::CPAN

      next;
    }

    # Catch direct path errors
    if ( /was not re-(?:enabled|validated)/ ) {
      # These errors do not cause non-zero exit status
      $dp_errors++;
      $error_msg .= $_ if $err_cnt < 1000;
      next;
    }
    if ( /^index \S+ was made unusable/ ) {
      $dp_errors++;
      $error_msg .= $_ if ++$err_cnt <= 1000;
      next;
    }

  }
  close $fh;

  if (!$close_success or $dp_errors) {
    $error_msg ||= '';
    if ( $exit_stat != 0 or $dp_errors ) {
      if ( $exit_stat == 2 or $dp_errors ) {
        # Exit status 2 is just a warning
        # But we should consider it an error if we exceeded the max errors allowed
        # Or if load was discontinued for any reason
        # Or for any direct path errors
        my $first = ($max_errors > 0) ? 'first ' : '';
        confess "sqlldr exited with status $exit_stat [$error_msg]" if $dp_errors;
        confess "sqlldr exited with status $exit_stat [$error_msg] - ${first}rejected record:[$bad_row]" if $error_rows > $max_errors;
        confess "sqlldr exited with status $exit_stat [$error_msg]" if $discontinued;
      } else {
        confess "sqlldr exited with status $exit_stat [$error_msg]";
      }
    }
    confess "sqlldr received signal $exit_sig [$error_msg]" if $exit_sig > 0;
    confess "sqlldr coredumped [$error_msg]"                if $exit_core;
  }
  return $rows;
}
}

# Dummy method for compatibility with Sybase
sub mk_view { }

sub date_masks_from_file {
  my $self = shift;
  my ($files, $columns, $is_date, $opts) = @_;

  return unless $is_date and %$is_date;

  $opts ||= {};

  my $sample_rows = $opts->{DateSampleRows} || 1000;
  my $d = $opts->{Delimiter} || $self->{DELIMITER};
  my $rd = $opts->{RowDelimiter};
  my $year_mask = $opts->{Year2Mask} || 'YY';

  local ($., $_, $ARGV, *ARGV);
  local $/ = $rd if $rd;
  local @ARGV = @$files;

  my $row_cnt;
  my (%remaining, %got);
  $remaining{$_}++ for keys %$is_date;

  my %fmt;
  my $dc_fmt = $opts->{DateColumnFmt} || {};
  for my $col ( keys %$dc_fmt ) {
    my $c = uc($col);
    $fmt{$c} = $dc_fmt->{$col};
    delete $remaining{$c}
  }

  my %row;
  while (<>) {
    next if $opts->{Header} and $. <= $opts->{Header};
    chomp;
    @row{@$columns} = $opts->{QuoteFields} ? split_quoted( $_, $d ) : split /\Q$d/;
    for (keys %remaining) {
      if ( $row{$_} ) {
        delete $remaining{$_};
        $got{$_} = $row{$_};
        last if !%remaining;
      }
    }

    # If we haven't found values by now, give up
    last if ++$row_cnt >= $sample_rows;
  }

  $fmt{$_} = $self->date_mask($got{$_}, $year_mask) for keys %got;

  return %fmt;
}

# If we allow quoted fields, need to split correctly and
# handle embedded quotes and delimiters
sub split_quoted {
  my ($line,$d) = @_;
  my @result;
  while ( $line =~ s/\A("?)((?:""|.)*?)\1(\Q$d\E|\z)//s ) {
    my ( $q, $s,$got_d ) = ( $1, $2, $3 );
    $s =~ s/""/"/g if $q;
    push @result, $s;
    last if length($got_d) == 0;
  }
  return @result;
}

{

my @mon    =  qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
my $mon_str = join("|", @mon);
my $mon_re = qr/(?i)$mon_str/;
my @months =  qw( January February March April May June July August September October November December );
my $month_str = join("|", @months);
my $month_re = qr/(?i)$month_str/;
my @days = qw( Mon Tue Wed Thu Fri Sat Sun );
my $day_str = join("|", @days);
my $day_re  = qr/(?i)$day_str/;

( run in 0.687 second using v1.01-cache-2.11-cpan-302cb4679cc )