Perl DBI and Sybase IMAGE fields

Sybase IMAGE fields and TEXT fields can be a right pain when working with Perl and the ct_ libraries. The manual pages are a little rough and don't give full examples, often missing out essential parts. So here it is in one section.

NOTE: Your LANG variable must be unset!

I noticed whilst identifying the issue for them that Sybase will allow dumps up to a certain size, e.g. the /etc/passwd file would quite happily fit into an IMAGE field if you use the following;


use strict;
use DBI;

# Open the connection to the database
my $dbh=DBI->connect('dbi:Sybase:server=STEVE;database=test','sa','') || die "Can't connect";

sub Insert
{
# Insert data
open(FH,"/etc/passwd");
local $/; # Slurp mode to suck in the file into one scalar
my $filename=<FH>; # read in the data
$/=1; # Return to normal newline mode
close FH;
$filename=unpack("H*",$filename); # Hex convert the entire file

my $length=length($filename);

$dbh->do("INSERT INTO data VALUES(4,'$filename')"); # Note the single quotes '

print "Insert done\n";

}

sub GetData

{

# Get data

my $sth=$dbh->prepare("SELECT * from data where id=4");

$sth->execute();

open(OFH, ">mytcap"); my $line;

while ( $line = $sth->fetchrow_hashref() )

{

my $data=$line->{'file'};

$data=pack('H*',$data); # Unpack the hex data

while ( $data =~ /(.{2})/g ) # Take each 2 characters from the hex code

{

print chr(hex($1)); # Turn the hex back into text

}

}

close(OFH);

$sth->finish();

}

Insert();

GetData();

$dbh->disconnect();

However, if the data became larger, e.g. the /etc/httpd/conf/httpd.conf file then you would start to see complaints from Sybase saying that the maximum size is only 30. That is, it can't move the point to the next available page size for the IMAGE. Which lead to the need for the ct_ functions as below;

use strict;

use DBI;

my $dbh=DBI->connect('dbi:Sybase:server=STEVE;database=test','sa','') || die "Can't connect";

sub Insert

{

# Insert data

$dbh->do("INSERT INTO data VALUES(4,'0xab')"); # Put some rubbish in the IMAGE field

}

sub Update

{

my $size = -s '/etc/httpd/conf/httpd.conf'; # Open a large file

open(FH,"/etc/httpd/conf/httpd.conf");

local $/;

my $filename=<FH>;

$/=1;

close FH;

$filename=unpack("H*",$filename); # Convert it to hex

my $sth=$dbh->prepare("select file from data where id=4"); # Grab the inserted new row

$sth->execute();

while($sth->fetch) # Fetch an array reference

{

$sth->syb_ct_data_info('CS_GET',1); # Set the pointer

}

$sth->syb_ct_prepare_send();

# Tell Sybase how much data we plan to send and turn the log on

$sth->syb_ct_data_info('CS_SET',1, {total_txtlen => length($filename), log_on_update => 1});

$sth->syb_ct_send_data($filename, length($filename)); # Send the data

$sth->syb_ct_finish_send();

}

sub GetData

{

# Get data

my $data;

my $sth=$dbh->prepare("SELECT datalength(file) AS len from data where id=4");

$sth->execute();

my $length=${$sth->fetchrow_hashref()}{'len'},"\n"; # Get the length of the IMAGE data

$sth->finish();

$dbh->{LongReadLen}=$length+1; # Tell Sybase how much data we plan to fetch

$sth=$dbh->prepare("SELECT id,file from data where id=4"); # What record do we want

$sth->{syb_no_bind_blob}=1; # Tell Sybase we are fetching binary

$sth->execute();

my ($len,$d);

while ( $d = $sth->fetch ) # Get array ref of data

{

$len = $sth->syb_ct_get_data(2,\$data,0); # Fetch all the data, $len contains number of bytes

# NOTE: \$data is the reference that will capture the data

while ( $data =~ /(.{2})/g ) # Do our favourite conversion on the returned data

{

print chr(hex($1)); # Print out the converted characters

}

}

$sth->finish();

}

Insert();

Update();

GetData();

$dbh->disconnect();

Note that with these examples I use Perl's unpack function to place the data into hex form before inserting it into the database, so that no quote or special character conversions are required. On retrieving the data I make use of the chr and hex functions to convert every 2 hex values into their decimal number and then chr to get the real character.

Perl action indicator using Term::Cap

If you are wondering how to make one of those whirling "I'm doing something" indicator on a screen in Perl, here is some code that will get you going. There are many libraries out there, but for those of you in companies where they won't let you use just any old CPAN library, here is a Termcap version which is standard with all Unix/Linux distributions of Perl.

use Term::Cap;
use POSIX;

# Load terminal IO library
my $termios = new POSIX::Termios;
# Get terminal settings
$termios->getattr;
# Get terminal speed
my $ospeed = $termios->getospeed;

$|=1;
$terminal = Tgetent Term::Cap { TERM => undef, OSPEED => $ospeed };
$terminal->Trequire(qw/ce ku kd/);

# Array for spinning thingy
my @seq=qw(| / - | \ -);
my $count=0;

# Position on the screen left to right (0 being left of screen)
my $x = 0;
# Position on the screen top to bottom (0 being top of screen)
my $y = 10;

while (1)
{
 $terminal->Tputs('cl',1,*STDOUT); # Clear screen
 $terminal->Tputs('cd',1,*STDOUT); # Clear data

 # Set cursor position on screen
 $terminal->Tgoto('cm',$x,$y,*STDOUT);
 # Print one of the chars | / - \
 print "$seq[$count++]";
 sleep 1;
 if ( $count > 5 )
 {
  $count = 0;
 }
}

Dynamic Perl Subroutines

You've got a set of subroutines that take similar numbers of parameters, but need to call a different constructor from different modules which use OO Perl. Here is an example of how that can be done using dynamic Perl subroutines.

---------- mod1.pm ----------
package mod1;

sub new
{
        my ($modname,$a,$b) = @_;
        print "In module 1\n";
        return bless {'a'=>"$a","b"=>"$b"};
}

1;

---------- mod2.pm ----------
package mod2;

sub new
{
        my ($modname,$a,$b) = @_;
        print "In Module 2\n";
        return bless {'a'=>"$a","b"=>"$b"};
}

1;


---------- main program -----
#!/usr/bin/perl

use mod1;
use mod2;

sub declared
{
        my $module = shift;
        # $cmd contains the code which will be the body of our subroutine
        $cmd="my (\$name, \$fullname) = \@_; $module(\$name, \$fullname);";
        # perform and evaluation on $cmd so that it becomes an anonymous subroutine reference
        $cmd = eval("sub { $cmd };");
        # return the subroutine reference (a normal Perl thing)
        return $cmd;
};

# Create a subroutine reference that calls the new method from mod1
my $campus=declared("new mod1");
# Create a subroutine reference that calls the new method from mod2
my $camp=declared("new mod2");
# Now call the 2 subroutines from the different modules
my $f=&$campus("Module 1","blah blah");
my $g=&$camp("Module 2","more blah");
# Show that we did get different results from the 2 methods
print "f: ",$f->{a}," and ",$f->{b},"\n";
print "g: ",$g->{a}," and ",$g->{b},"\n";

What fun was that. Now you are all going to want to go away and reduce your code :-)

Perl writing STDERR to a variable

Further to the problem of preventing STDERR from being displayed we wanted to capture the error message in a variable.

---------------- p.pm ---------------------------
package p;

sub dothis
{
      print STDERR "There's a problem";
      return 2;
}

1;
---------------- p.pm ---------------------------

The program code that temporarily prevents the STDERR from being displayed is as follows;

---------------- stopstderr ---------------------------
#!/usr/bin/perl
# using perl 5.8

use p;

# Open a new file handle to remember where STDERR really points to
open (OLDER, ">&", \*STDERR) || die "Can't dup stderr";
close STDERR;
# Repoint STDERR to a memory location so that we can capture the error message
open (STDERR, ">", \$var) || die "Can't remap STDERR";
print "No message here: ";
# No message printed from the module
my $s=p->dothis();
print "\n";
print "Return value is $s\n";
print "Trying to print to STDERR directly: ";
# No output printed to STDERR so next line goes to /dev/null
print STDERR "Can you see this?\n";
print "\n";
close STDERR;
# Let's print our the message captured in the variable $var even though we closed STDERR
print "The captured error message: $var\n";
# Repoint STDERR to where it normally goes
open (STDERR, ">&", \*OLDER) || die "Can't repoint STDERR";
close OLDER;
# Ensure that everything prints out when expected
select STDERR; $| = 1;
select STDOUT; $| = 1;
# Everything is happy again
print "Now STDERR is back, message here: ";
print STDERR "Cool :-)\n";

---------------- stopstderr ---------------------------

What fun :-)