DBD / DBI：プログラムがフォークするとクラッシュします。

$crashパラメーターが設定されていない場合は、次のプログラムが実行されます。

$ perl example mysql://:tange@/tange/mytable
dburl mysql://:tange@/tange/mytable
databasedriver mysql user  password tange host  port  database tange table mytable query 
run DROP TABLE IF EXISTS mytable;
run CREATE TABLE mytable
                (Seq INT,
                 Exitval INT
                 );
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);

$ crashが設定されている場合、bzip2はopen3を介して実行され、フォークされたプロセスを介してデータを転送し、DBD / DBIがクラッシュする可能性があります。

$ perl example mysql://:tange@/tange/mytable 1
dburl mysql://:tange@/tange/mytable
databasedriver mysql user  password tange host  port  database tange table mytable query 
run DROP TABLE IF EXISTS mytable;
run CREATE TABLE mytable
                (Seq INT,
                 Exitval INT
                 );
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);
Orig:
As bzip2:BZh9rE8P�
1
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);
DBD::mysql::st execute failed: MySQL server has gone away at example line 157.
DBD::mysql::st execute failed: MySQL server has gone away at example line 157.

Postgresqlを使用しても同様です。

$ perl example pg:////mytable 
dburl pg:////mytable
databasedriver pg user  password  host  port  database  table mytable query 
run DROP TABLE IF EXISTS mytable;
run CREATE TABLE mytable
                (Seq INT,
                 Exitval INT
                 );
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);

そして$ crashを設定します。

$ perl example pg:////mytable 1
dburl pg:////mytable
databasedriver pg user  password  host  port  database  table mytable query 
run DROP TABLE IF EXISTS mytable;
run CREATE TABLE mytable
                (Seq INT,
                 Exitval INT
                 );
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);
Orig:
As bzip2:BZh9rE8P�
1
run INSERT INTO mytable (Seq,Exitval) VALUES (?,?);
DBD::Pg::st execute failed: server closed the connection unexpectedly
        This probably means the server terminated abnormally
        before or while processing the request. at example line 157.
DBD::Pg::st execute failed: server closed the connection unexpectedly
        This probably means the server terminated abnormally
        before or while processing the request. at example line 157.

なぜ？解決策はありますか？

私にとって、open3とフォークはDBD / DBIとはまったく関係ありません。

---

#!/usr/bin/perl

use IPC::Open3;

my $sql = SQL->new(shift);
my $crash = shift;
$Global::debug = "all";
$sql->create_table();
$sql->insert_records(2);
$crash and print length string_zip("abc"),"\n";
$sql->insert_records(3);

sub string_zip {
    # Pipe string through 'cmd'
    my $cmd = shift;
    my($zipin_fh, $zipout_fh,@base64);
    ::open3($zipin_fh,$zipout_fh,">&STDERR","bzip2 -9");
    if(fork) {
    close $zipin_fh;
    @base64 = <$zipout_fh>;
    close $zipout_fh;
    } else {
    close $zipout_fh;
    print $zipin_fh @_;
    close $zipin_fh;
    exit;
    }
    ::debug("zip","Orig:@_\nAs bzip2:@base64\n");
    return @base64;
}

sub undef_if_empty {
    if(defined($_[0]) and $_[0] eq "") {
    return undef;
    }
    return $_[0];
}

sub debug {
    # Uses:
    #   $Global::debug
    #   %Global::fd
    # Returns: N/A
    print @_[1..$#_];
}

package SQL;

sub new {
    my $class = shift;
    my $dburl = shift;
    $Global::use{"DBI"} ||= eval "use DBI; 1;";
    my %options = parse_dburl($dburl);
    my %driveralias = ("sqlite" => "SQLite",
               "sqlite3" => "SQLite",
               "pg" => "Pg",
               "postgres" => "Pg",
               "postgresql" => "Pg");
    my $driver = $driveralias{$options{'databasedriver'}} || $options{'databasedriver'};
    my $database = $options{'database'};
    my $host = $options{'host'} ? ";host=".$options{'host'} : "";
    my $port = $options{'port'} ? ";port=".$options{'port'} : "";
    my $dsn = "DBI:$driver:dbname=$database$host$port";
    my $userid = $options{'user'};
    my $password = $options{'password'};;
    my $dbh = DBI->connect($dsn, $userid, $password, { RaiseError => 1 })
    or die $DBI::errstr;
    return bless {
    'dbh' => $dbh,
    'max_number_of_args' => undef,
    'table' => $options{'table'},
    }, ref($class) || $class;
}

sub parse_dburl {
    my $url = shift;
    my %options = ();
    # sql:mysql://[[user][:password]@][host][:port]/[database[/table][?sql query]]

    if($url=~m!(?:sql:)? # You can prefix with 'sql:'
               ((?:oracle|ora|mysql|pg|postgres|postgresql)(?:s|ssl|)|
                 (?:sqlite|sqlite2|sqlite3)):// # Databasedriver ($1)
               (?:
                ([^:@/][^:@]*|) # Username ($2)
                (?:
                 :([^@]*) # Password ($3)
                )?
               @)?
               ([^:/]*)? # Hostname ($4)
               (?:
                :
                ([^/]*)? # Port ($5)
               )?
               (?:
                /
                ([^/?]*)? # Database ($6)
               )?
               (?:
                /
                ([^?]*)? # Table ($7)
               )?
               (?:
                \?
                (.*)? # Query ($8)
               )?
              !ix) {
    $options{databasedriver} = ::undef_if_empty(lc(uri_unescape($1)));
    $options{user} = ::undef_if_empty(uri_unescape($2));
    $options{password} = ::undef_if_empty(uri_unescape($3));
    $options{host} = ::undef_if_empty(uri_unescape($4));
    $options{port} = ::undef_if_empty(uri_unescape($5));
    $options{database} = ::undef_if_empty(uri_unescape($6));
    $options{table} = ::undef_if_empty(uri_unescape($7));
    $options{query} = ::undef_if_empty(uri_unescape($8));
    ::debug("sql","dburl $url\n");
    ::debug("sql","databasedriver ",$options{databasedriver}, " user ", $options{user},
          " password ", $options{password}, " host ", $options{host},
          " port ", $options{port}, " database ", $options{database},
          " table ",$options{table}," query ",$options{query}, "\n");

    } else {
    ::error("$url is not a valid DBURL");
    exit 255;
    }
    return %options;
}

sub uri_unescape {
    # Copied from http://cpansearch.perl.org/src/GAAS/URI-1.55/URI/Escape.pm
    # to avoid depending on URI::Escape
    # This section is (C) Gisle Aas.
    # Note from RFC1630:  "Sequences which start with a percent sign
    # but are not followed by two hexadecimal characters are reserved
    # for future extension"
    my $str = shift;
    if (@_ && wantarray) {
    # not executed for the common case of a single argument
    my @str = ($str, @_);  # need to copy
    foreach (@str) {
        s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
    }
    return @str;
    }
    $str =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg if defined $str;
    $str;
}

sub run {
    my $self = shift;
    my $stmt = shift;
    my $dbh = $self->{'dbh'};
    ::debug("sql","run $stmt\n");
    # Execute with the rest of the args - if any
    my $rv;
    my $sth;
    $sth = $dbh->prepare($stmt);
    $rv = $sth->execute(@_);
    return $sth;
}

sub table {
    my $self = shift;
    return $self->{'table'};
}

sub create_table {
    my $self = shift;
    my $table = $self->table();
    $self->run(qq(DROP TABLE IF EXISTS $table;));
    $self->run(qq{CREATE TABLE $table
        (Seq INT,
         Exitval INT
         }.
           qq{);});
}

sub insert_records {
    my $self = shift;
    my $seq = shift;
    my $record_ref = shift;
    my $table = $self->table();
    $self->run("INSERT INTO $table (Seq,Exitval) ".
           "VALUES (?,?);", $seq, -1000);
}