Instructional Oracle Perl/DBI Example Script perldbi.pl Description

The Instructional Oracle Perl/DBI Example Script perldbi.pl retrieves and updates the table "counter_table" from a test Instructional Oracle account. ( To review the actual source code see perldbi.pl source code. To execute the script click on this link run perldbi.pl.) This table was created ( you can use the Secure SQL Editor to execute SQL commands on your Instructional Oracle account ) with the following SQL command :

Create table counter_table(
counter number,
last_update_time date);

There is currently one row in this table. The example script first connects to the Instructional Oracle database with the specified Oracle account and password. After a successful connection, the script retrieves the current values from that row. Next the script updates that row by incrementing the counter by one and storing the current time "sysdate" in the date column. It is important to execute a commit before either disconnecting from the database or terminating the script. If the commit command is not issued then the updates will not take effect. After the commit, the script retrieves the current values for that table. The before values and after values are then displayed. This table counter_table effectively tracks the number of times this example script was run and the last time the script was run.

Security Issues

Since the Oracle account and password are stored in the script source, one must set the permissions for the script so that only the owner has read/write/execute permissions. You can check by using the ls command on the script in your campuscgi directory.

tucson.Princeton.EDU% ls -ld perldbi.pl
-rwx------   1 storacle     5931 Aug  2 11:10 perldbi.pl

tucson.Princeton.EDU% chmod 700 perldbi.pl

tucson.Princeton.EDU% chmod 711 perldbi.pl
tucson.Princeton.EDU% ls -ld perldbi.pl
-rwx--x--x   1 storacle     5931 Aug  2 11:10 perldbi.pl

Testing And Debugging Issues

On the Unix arizona machines, users can execute their campuscgi perl scripts directly from their campuscgi directory. This provides a useful environment to test and debug the campuscgi perl scripts.

tucson.Princeton.EDU% pwd
/usr/campuscgi/storacle
tucson.Princeton.EDU% ls
perldbi.pl
tucson.Princeton.EDU% perldbi.pl 
Content-Type: text/html; charset=ISO-8859-1




Instructional Oracle Perl/DBI Example
Values Before Update
Counter[ 5240 ]  Last_Update_Time[ 08/02/2004 11:10 ]
Values After Update
Counter[ 5241 ]  Last_Update_Time[ 08/02/2004 11:11 ]


If your perl scripts generate html output, you can use

Princeton University Campus CGI Facility
 development environment to test and debug your campuscgi perl/dbi/Instructional Oracle account scripts.

 

  Source For Instructional Oracle Perl/DBI Example Script




#!/usr/psr.oit/solaris9/bin/perl

     use CGI;
     use DBI;
     use Oraperl;

     local(@Error_Lines);
     my($i);
     my $my_error = "";

     # set flag not to buffer output
     $|       = 1;
     undef(@Before_Counter);
     undef(@Before_Date);
     undef(@After_Counter);
     undef(@After_Date);
     $query = new CGI;
     $title="Instructional Oracle Perl/DBI Example";
     $query = new CGI;
     $my_error_string=&dbiconnect;
     if($my_error_string ne "") {
        $title="Connect Error";
     } else {
        #define my global array to hold return values
        undef(@value1_array);
        undef(@value2_array);
        $sql="select counter,to_char(last_update_time,'MM/DD/YYYY HH24:MI') from counter_table";
        #expect two values returned from each row found
        #so passed the address of my sub "load_two_values" which handles the returned values
        $my_error=&dbiselect_and_ret_error($sql,\&load_two_values);
        if($my_error ne "") {
           $title="Sql Error";
           $my_error="Error[$my_error] from sql[$sql]";
        } else {
           #copy returned values to my destination arrays
           @Before_Counter=@value1_array;
           @Before_Date=@value2_array;
           #now go update this table
           undef(@value1_array);
           undef(@value2_array);
           $sql="update counter_table set counter=counter+1,last_update_time=sysdate";
           #expect no values returned but need to pass address of valid sub so reuse "load_two_values"
           $my_error=&dbiselect_and_ret_error($sql,\&load_two_values);
           if($my_error ne "") {
              $title="Sql Error";
              $my_error="Error[$my_error] from sql[$sql]";
           } else {
              #now go commit the update
              if(&dbicommit) {
                 #go retrieve the new values
                 undef(@value1_array);
                 undef(@value2_array);
                 $sql="select counter,to_char(last_update_time,'MM/DD/YYYY HH24:MI') from counter_table";
                 $my_error=&dbiselect_and_ret_error($sql,\&load_two_values);
                 if($my_error ne "") {
                    $title="Sql Error";
                    $my_error="Error[$my_error] from sql[$sql]";
                 } else {
                    #copy returned values to my destination arrays
                    @After_Counter=@value1_array;
                    @After_Date=@value2_array;
                 }
              } else {
                 $title="Commit Error";
                 $my_error="Unable to commit update";
              }
           }
        }
     }
     if($my_error eq "") {
        &dbidisconnect;
        print $query->header;
        print $query->start_html($title);
        print "<H2>$title</H2>\n";
        print "<H3>Values Before Update</H3>\n";
        for($i=0;$i<=$#Before_Counter;$i++) {
           print "Counter[ $Before_Counter[$i] ]  Last_Update_Time[ $Before_Date[$i] ]\n";
        }
        print "<H3>Values After Update</H3>\n";
        for($i=0;$i<=$#After_Counter;$i++) {
           print "Counter[ $After_Counter[$i] ]  Last_Update_Time[ $After_Date[$i] ]\n";
        }
        print $query->end_html;
     } else {
        push(@Error_Lines,$my_error);
        &Print_Error_Lines($query,$title,*Error_Lines);
     }

     sub dbiconnect {
        local($user,$password)=@_;
        my($Connect_Error);

        #PUT YOUR Instructional Oracle account/Oracle password HERE
        $user="";
        $password="";
        #use the oracle_home associated with psr (so this avoids having to install oracle client software on local machine)
        $ENV{'ORACLE_HOME'} = "/usr/psr.oit/solaris9/share/oracle-barebone";
        my $twotask = 'storacle8.world';

        # Load the Oracle driver.
        $driver = DBI->install_driver('Oracle');
        if(!$driver) {
           $Connect_Error="Unable to load database driver ".$DBI::errstr;
        } else {
           # Tell Oracle to return longs in a big buffer.
           $Oraperl::ora_long = 8192;
           $database = $driver->connect( $twotask, $user, $password);
           if(!$database) {
              $Connect_Error=$driver->errstr;
           } else {
              $connected = 1;
           }
        }
        return $Connect_Error;
     }

     sub dbidisconnect {
        local($disconnect_done);
        $disconnect_done=$database->disconnect;
        return($disconnect_done);
     }

     sub dbicommit {
        local($commit_done);
        $commit_done=$database->commit;
        return($commit_done);
     }

     sub dbiselect_and_ret_error {
        my ($sql, $rowcmd) = @_;

        my $cursor;
        my($my_error);
        $my_error="";
        $cursor = $database->prepare($sql)
                or return($database->errstr);

        $cursor->execute
                or return($cursor->errstr);

        my @row;
        while ( @row = $cursor->fetchrow ) {
                if ( defined($rowcmd) ) {
                        &$rowcmd(@row);
                }
        }

        $cursor->finish;
        return($my_error);
     }

     sub Print_Error_Lines {
        local($query,$title,*Error_Lines) =@_;
        my($line);

        print $query->header;
        print $query->start_html(-title=>$title,-BGCOLOR=>'white');
        print "<H2>$title</H2>\n";
        print "<font color=\"red\">\n";
        if($#Error_Lines > -1) {
           print "<p>\n";
           foreach $line(@Error_Lines) {
              print "$line\n";
           }
           print "</p>\n";
        } else {
          print "error_line_cnt[$#Error_Lines]\n";
        }
        print "<br>\n";
        print "</font>\n";
        print $query->end_html;
     }

     sub load_two_values {
        local($value1,$value2) = @_;

     #  subroutine which expects two input values
        push(@value1_array,$value1);
        push(@value2_array,$value2);
     }