Detecting Deadlocks in Perl scripts.

Assuming you are using sybperl, with a require sybperl.pl at the top of your perl script.
You need to create your own sybperl.pl, I call it nacm_sybperl.pl (after my current employer), with the contents:

# @(#)sybperl.pl        1.7     8/7/95
#

# Copyright (c) 1991, 1992, 1993, 1994
#   Michael Peppler
#
#   You may copy this under the terms of the GNU General Public License,
#   or the Artistic License, copies of which should have accompanied
#   your Perl kit.


# The only purpose of this file is to provide backward compatibility
# with sybperl 1.0xx.

# NACM Modification
# call nacm_sybutil.pl rather than sybutil.pl
# to include deadlock checks
# Paul Stephenson, 7th June 1999.

use Sybase::Sybperl;


require 'nacm_sybutil.pl';

1;

Now create your own sybutil.pl, called here nacm_sybutil.pl. This does the _REAL_ work. It catches sybase errors, and if it is 1205 - the deadlock error, sets an internal flag. This can then be obtained from a procedure call.

# @(#)sybutil.pl        1.8     03/25/98
#
# Copyright (c) 1994, 1998
#   Michael Peppler
#
#   You may copy this under the terms of the GNU General Public License,
#   or the Artistic License, copies of which should have accompanied
#   your Perl kit.

#
# A couple of utility stuff for both Sybase::DBlib and Sybase::Sybperl
#

# NACM Modification
# Include deadlock detection
# &is_deadlocked() tells you if a deadlock has occurred since the last call
#                  to is_deadlocked or reset_deadlock
# &reset_deadlock() will reset the deadlock status
# Paul Stephenson, 7th June 1999

sub message_handler
{
    my ($db, $message, $state, $severity, $text, $server, $procedure, $line)
        = @_;

    # Don't display 'informational' messages:
    if ($severity > 10)
    {
        print STDERR ("Sybase message ", $message, ", Severity ", $severity,
               ", state ", $state);
        print STDERR ("\nServer `", $server, "'") if defined ($server);
        print STDERR ("\nProcedure `", $procedure, "'") if defined ($procedure);
        print STDERR ("\nLine ", $line) if defined ($line);
        print STDERR ("\n    ", $text, "\n\n");

# &dbstrcpy returns the command buffer.

        if(defined($db))
        {
            my ($lineno, $cmdbuff) = (1, undef);
            my $row;

            $cmdbuff = &Sybase::DBlib::dbstrcpy($db);

            foreach $row (split (/\n/, $cmdbuff))
            {
                print STDERR (sprintf ("%5d", $lineno ++), "> ", $row, "\n");
            }
        }

# catch deadlocks and set status flag

        if ($message == 1205)
        {
            print "Deadlock detected in nacm_sybutil.pl\n";
            $deadlock_occured = 1;
        }
    }
    elsif ($message == 0)
    {
        print STDERR ($text, "\n");
    }

    0;
}

# allow user to see if deadlock occurred.
# resets deadlock flag after use, so no unintentional infinite loops.

sub is_deadlocked {
    $return_status = $deadlock_occured;
    $deadlock_occured = 0;
    if ($return_status == 1)
    {
        print "Deadlock status ",$return_status," in nacm_sybutil.pl\n";
    }
    return $return_status;
}

# allows user to explicitly reset deadlock status flag.
sub reset_deadlock {
    $deadlock_occured = 0;
}

sub error_handler {
    my ($db, $severity, $error, $os_error, $error_msg, $os_error_msg)
        = @_;
    # Check the error code to see if we should report this.
    if ($error != SYBESMSG) {
        print STDERR ("Sybase error: ", $error_msg, "\n");
        print STDERR ("OS Error: ", $os_error_msg, "\n") if defined ($os_error_msg);
    }

    INT_CANCEL;
}

&dbmsghandle (\&message_handler);
&dberrhandle (\&error_handler);

1;

Code Segment to show how to use this.
You need to create a Deadlock loop around your transactionally sound code, and at the end of the loop, make a call to &is_deadlocked(), looping if true.

# include files
require "nacm_sybperl.pl";

# Set values for Sybase login
require "landmark.cfg";

# Login to database
$dbproc = &dblogin($sybUser, $sybPass, $sybServer);
&dbuse($dbproc, $sybDB);

# just to see what the server and databases are
print "INFO : Processing server : ";
@results = &sql($dbproc, 'select @@servername');
foreach $res (@results)
{
        print $res, "\n";
}

print "INFO : Using database : ";
@results = &sql($dbproc, 'select db_name()');
foreach $res (@results)
{
        print $res, "\n";
}

$oasys_rec_len = 255;

do
{
  &reset_deadlock;

  $sqlcmd = "execute landmark_client..broker_trades_upload ".
            "$account_group_id ";

  $dbcmdRV = &dbcmd($dbproc,$sqlcmd);
  unless ($dbcmdRV == 1)
  {
    die "SQL ERROR: Error adding to command buffer: $sqlcmd\n";
  }

  $dbexecRV = &dbsqlexec($dbproc);
  unless ($dbexecRV == 1)
  {
    die "SQL ERROR: Error executing command: $sqlcmd\n";
  }

  while (&dbresults($dbproc) != $NO_MORE_RESULTS)
  {
    while(@dataRow = &dbnextrow($dbproc))
    {
      $record_id = $dataRow[4];
      $trade_data = $dataRow[5];
      $trade_data = $trade_data . " " x ($oasys_rec_len - length($trade_data));
      print($record_id, $trade_data);
    }
  }
} while (&is_deadlocked());

$sqlerror = &dbretstatus($dbproc);

&dbcanquery($dbproc);

&dbclose($dbproc);

if ($sqlerror != 0)
{
        print "**ERROR: Broker upload process failed to complete successfully.";
        exit(-1);
}
else
{
        exit(0)
}

Back to home page