ssmith001 has asked for the wisdom of the Perl Monks concerning the following question:

I'm a Perl newbie, and I am trying to write a script that will allow my users to update records in an Oracle DB using screen interation. They basically need to specify which column name, which I then validate. Then they specify the location number for the update. Then they give me the value to update to. At this point I need to do some validation to make sure the value is reasonable based on criteria I've indicated in the code. As a test I have entered p_dlruom as the column to update, location = O991, and value for the update = "JOHN" (which I know is not a valid value), but the code is telling me it is valid. Does anyone have an idea of what may be going on here? I'm certain there is an easier way to do this. 
#!/usr/bin/perl

use strict;
use DBI;
use Getopt::Long;

my ($colname, $updatemethod, $dealer, @supplier, @altsupplier, $min, $
+updateval);
my $instance      = 'mdit1';

##########
# VALIDATION VALUES. This section defines valid values for each user-d
+efined column
##########

###>>>>>>>> TO DO:  allow update of MINSS column on SSPARAM table

#
# TEXT
#
my @p_abc                                    = ("A","B","C","D","E");
my $p_altdlrsplrcode        = 50;
my $p_commenttext            = 50;        
my @p_deleteme              = ("","DELETEME");
my $p_distchan                         = 50;        
my $p_dlrrslnumber          = 50;
my $p_dlrsplrcode            = 50;           
my @p_dlruom                = ("EACH","FEET","FT","IN","UNIT");
my @p_lastabc                = ("A","B","C","D","E");
my $p_mdiplannercode        = 50;
my $p_minimumname            = 22;        
my $p_ordermethodcode     = 50;
my $p_primarybintext        = 50;
my $p_secondarybintext    = 50;
my $p_workinglistname        = 50;
#
# NUMBER
#
my $p_12monthdemandqty    = 80000;
my $p_12monthhitcount        = 100000;
my $p_abcunitstotqty        = 25000;
my $p_buyqty              = 0;
my $p_count                  = 1;
my $p_custallocqty          = 1000;
my $p_dlrmaxstkqty          = 60000;
my $p_dlrminstkqty          = 90000;
my $p_dlrnet                             = 250000;
my $p_dlruomfactor          = 250;
my $p_fropqty                = 0;
my $p_jobqty                             = 5000;
my $p_manualparameters        = 5;
my $p_mtddemandqty          = 5500;
my $p_mtdlostsalesqty        = 6500;
my $p_mustplansw            = 0;
my $p_palletfctr                     = 100;
my $p_seasonalitysw          = 1;
my $p_ytdemgergencyqty      = 20000;
my $p_ytdlostsalesqty        = 85000;
my $p_ytdstockoutcount    = 100;
#
# DATE
#
my $p_stkprotctexpdate      = "1/1/2015";
my $p_sunsetdate          = "1/1/2025";

#GetOptions("colname=s"      => \$colname,
#           "updatemethod=i" => \$updatemethod,
#                       "dealer=s"       => \$dealer,
#           "supplier:s"     => \@supplier,
#           "altsupplier:s"  => \@altsupplier,
#           "min=s"          => \$min) or usage();

#GetOptions("colname=s"      => \$colname,
#           "updatemethod=i" => \$updatemethod,
#                     "dealer=s"       => \$dealer,
#                     "update_val=s"   => \$updateval) or usage();

#@supplier = split(/,/, join(',', @supplier));
#@altsupplier = split(/,/, join(',', @altsupplier));

#print "\n";
#print "You have entered:\n\n";
#print "     Column name:  $colname\n";
#print "   Update method:  $updatemethod " . " (Single record update u
+sing command line)\n" if ( $updatemethod == 1 );
#print "   Update method:  $updatemethod " . " (Multi-record update us
+ing semicolon delimited file)\n" if ( $updatemethod == 2 );
#print "          Dealer:  $dealer\n";
#print "Value for Update:  $updateval\n\n";
#print "Supplier = @supplier\n" if @supplier;
#print "Alt Supplier = @altsupplier\n" if @altsupplier;
#print "Min = $min\n";


#
# Perform the connection using the Oracle driver
#
my %attr = (
       PrintError => 0,        #PrintError => 1,
       RaiseError => 0,
       AutoCommit => 0,
           );

my $dbh = DBI->connect("dbi:Oracle:$instance", "stsc", "stsc", \%attr)
      or die "Can't connect to Oracle!", $DBI::errstr, "\n";

# Define the actions to take
my %action_to_take = (
    '1' => \&Update_from_command_line,
    '2' => \&Update_from_csv,
    '3' => \&do_exit,
);

# Print the menu selection
print <<"EOT";

This script will allow you to update user-defined columns on the SKU t
+able.

Select one of:

1. Update from command line
2. Update using comma delimited file
3. Exit
EOT

# Get the user's input
my $menu_item = <>;
chomp($menu_item);

# Take action based on the user's choice
if (defined $action_to_take{$menu_item}) {
    $action_to_take{$menu_item}->();
} else {
    print "I didn't understand the command.\n";
    do_exit();
}

exit 0;

#
# Disconnect from the database
#
$dbh->disconnect(  );

###############
# SUBROUTINES
###############

sub Update_from_command_line() 
{
    print "What column do you want to update? ";
    my $column_to_update = <>;
    chomp($column_to_update);

        # we need to check to make sure the column that the planner is
+ wanting to 
        # update actually exists as a user defined column on the SKU t
+able
        my $result = validate_colname( $dbh, $column_to_update );

        if ($result == 0)
        {
            # column name is not valid so we exit the script here
            #LogMsg("There is no column called $column_to_update on th
+e SKU table. Exiting...\n");
            print "There is no column called $column_to_update on the 
+SKU table. Exiting...\n";
            exit;
        }

    print "For what dealer? ";
    my $dealer = <>;
    chomp($dealer);

    print "Update to what value? ";
    my $value_for_update = <>;
    chomp($value_for_update);
        
        my $valid = validate_fields( $value_for_update, $column_to_upd
+ate );  # we need to validate the value the planner has entered to ma
+ke sure it's reasonable
        
        if ($valid == 1)
        {
            print "The update value of \"$value_for_update\" is valid\
+n\n";
            print "\nYou are going to update the $column_to_update col
+umn to \"$value_for_update\" for all SKUs for dealer $dealer\n";
        print "\n";
        }
        else
        {    
            print "The update value of \"$value_for_update\" is invali
+d\n\n";
    }
        
    return;
}

sub Update_from_csv() 
{
    print "\nPlease enter the location of the import file:\n";
    my $dir = <>;
    chomp($dir);
    print "\nYou have entered $dir\n\n";
    
    if (! -d $dir)
    {
        LogMsg("The $dir does not exist");           
        do_exit()
    }
            
    return;
}

sub do_exit() {
    print "Exiting...\n";
    return;
}

sub validate_colname
{
      # this subroutine will validate that the column the planner is t
+rying to 
      # update actually exists as a user-defined column on the SKU tab
+le
      
      my ( $dbh, $colname ) = @_;
      
      my $sth;
      
      my $sql = "SELECT cname FROM col WHERE cname = upper(?) AND tnam
+e = 'SKU'";
      
    $sth = $dbh->prepare($sql) or die "Can't prepare SQL statement: $D
+BI::errstr\n";
  
    $sth->execute($colname) or die "Can't execute SQL statement: $DBI:
+:errstr\n";
    
       my $total=0;
  
      while ($sth->fetch) {$total++};
  
    if ($@) 
    {
        # There is no such column, return FALSE
      LogMsg( "There is no column called $colname on the SKU table");
      return 0;
    }
    else 
    {
        # There are records, return TRUE
        return $total;
    } 
}

#
# Here's where we start to validate each of the column values that pla
+nner may want to update
#

sub validate_fields
{
     my ($updateval, $colname) = @_;
        
   #
   # NUMBER validation
   #
   validate_number( $updateval, $p_12monthdemandqty, "p_12monthdemandq
+ty" ) if ($colname eq "P_12MONTHDEMANDQTY");
   validate_number( $updateval, $p_12monthhitcount, "p_12monthhitcount
+" ) if ($colname eq "P_12MONTHHITCOUNT");
   validate_number( $updateval, $p_abcunitstotqty, "p_abcunitstotqty" 
+) if ($colname eq "P_ABCUNITSTOTQTY");
   validate_number( $updateval, $p_buyqty, "p_buyqty" ) if ($colname e
+q "P_BUYQTY");
   validate_number( $updateval, $p_count, "p_count" ) if ($colname eq 
+"P_COUNT");
   validate_number( $updateval, $p_custallocqty, "p_custallocqty" ) if
+ ($colname eq "P_CUSTALLOCQTY");
   validate_number( $updateval, $p_dlrmaxstkqty, "p_dlrmaxstkqty" ) if
+ ($colname eq "P_DLRMAXSTKQTY");
   validate_number( $updateval, $p_dlrminstkqty, "p_dlrminstkqty" ) if
+ ($colname eq "P_DLRMINSTKQTY");
   validate_number( $updateval, $p_dlrnet, "p_dlrnet" ) if ($colname e
+q "P_DLRNET");
   validate_number( $updateval, $p_dlruomfactor, "p_dlruomfactor" ) if
+ ($colname eq "P_DLRUOMFACTOR");
   validate_number( $updateval, $p_fropqty, "p_fropqty" ) if ($colname
+ eq "P_FROPQTY");
   validate_number( $updateval, $p_jobqty, "p_jobqty" ) if ($colname e
+q "P_JOBQTY");
   validate_number( $updateval, $p_manualparameters, "p_manualparamete
+rs" ) if ($colname eq "P_MANUALPARAMETERS");
   validate_number( $updateval, $p_mtddemandqty, "p_mtddemandqty" ) if
+ ($colname eq "P_MTDDEMANDQTY");
   validate_number( $updateval, $p_mtdlostsalesqty, "p_mtdlostsalesqty
+" ) if ($colname eq "P_MTDLOSTSALESQTY");
   validate_number( $updateval, $p_mustplansw, "p_mustplansw" ) if ($c
+olname eq "P_MUSTPLANSW");
   validate_number( $updateval, $p_palletfctr, "p_palletfctr" ) if ($c
+olname eq "P_PALLETFCTR");
   validate_number( $updateval, $p_seasonalitysw, "p_seasonalitysw" ) 
+if ($colname eq "P_SEASONALITYSW");
   validate_number( $updateval, $p_ytdemgergencyqty, "p_ytdemgergencyq
+ty" ) if ($colname eq "P_YTDEMGERGENCYQTY");
   validate_number( $updateval, $p_ytdlostsalesqty, "p_ytdlostsalesqty
+" ) if ($colname eq "P_YTDLOSTSALESQTY");
   validate_number( $updateval, $p_ytdstockoutcount, "p_ytdstockoutcou
+nt" ) if ($colname eq "P_YTDSTOCKOUTCOUNT");
   
   #
   # VARCHAR validation
   #
   validate_p_abc( $updateval ) if ($colname eq "P_ABC");
   validate_char( $updateval, $p_altdlrsplrcode, "p_altdlrsplrcode" ) 
+if ($colname eq "P_ALTDLRSPLRCODE");
   validate_char( $updateval, $p_commenttext, "p_commenttext" ) if ($c
+olname eq "P_COMMENTTEXT");
   validate_p_deleteme( $updateval ) if ($colname eq "P_DELETEME");
   validate_char( $updateval, $p_distchan, "p_distchan" ) if ($colname
+ eq "P_DISTCHAN");
   validate_char( $updateval, $p_dlrrslnumber, "p_dlrrslnumber" ) if (
+$colname eq "P_DLRRSLNUMBER");
   validate_char( $updateval, $p_dlrsplrcode, "p_dlrsplrcode" ) if ($c
+olname eq "P_DLRSPLRCODE");    
   validate_p_dlruom( $updateval ) if ($colname eq "P_DLRUOM");
   validate_p_lastabc( $updateval ) if ($colname eq "P_LASTABC");
   validate_char( $updateval, $p_mdiplannercode, "p_mdiplannercode" ) 
+if ($colname eq "P_MDIPLANNERCODE");
   validate_char( $updateval, $p_minimumname, "p_minimumname" ) if ($c
+olname eq "P_MINIMUMNAME");
   validate_char( $updateval, $p_ordermethodcode, "p_ordermethodcode" 
+) if ($colname eq "P_ORDERMETHODCODE");
   validate_char( $updateval, $p_primarybintext, "p_primarybintext" ) 
+if ($colname eq "P_PRIMARYBINTEXT");
   validate_char( $updateval, $p_secondarybintext, "p_secondarybintext
+" ) if ($colname eq "P_SECONDARYBINTEXT");
   validate_char( $updateval, $p_workinglistname, "p_workinglistname" 
+) if ($colname eq "P_WORKINGLISTNAME");
   
   #
   # DATE validation
   #
   # how do I do this???
   my $result = isvaliddate($p_sunsetdate);
   my $result = isvaliddate($p_stkprotctexpdate);
   
   return 1;
}

sub validate_p_abc
{
      my $val = @_;
    
      my @match = grep (/$val/i, @p_abc);
      
      LogMsg("The value of $val you have chosen for P_ABC is outside o
+f the allowable range.") if !(@match);
    
        if (@match)
        {
            return 1;
        }
        else
        {
            return 0;
        }        
}

sub validate_p_dlruom
{
      my $val = shift;

      my @match = grep (/$val/i, @p_dlruom);
    
      LogMsg("The value of $val you have chosen for P_DLRUOM is outsid
+e of the allowable range.") if !(@match);

}

sub validate_p_lastabc
{
      my $val = shift;

      my @match = grep (/$val/i, @p_lastabc);
    
      LogMsg("The value of $val you have chosen for P_LASTABC is outsi
+de of the allowable range.") if !(@match);
    
}

sub validate_p_deleteme
{
      my $val = shift;

      my @match = grep (/$val/i, @p_deleteme);
    
      LogMsg("The value of $val you have chosen for P_DELETEME is outs
+ide of the allowable range.") if !(@match);
    
}

sub update_sku
{
      my ( $colname, $loc, $updateval ) = @_;
      
      my $sql = "UPDATE sku SET $colname = ? WHERE loc = ?";
    
    my $sth = $dbh->prepare($sql) or die "Can't prepare SQL statement:
+ $DBI::errstr\n";
    
    $sth->execute($updateval, $loc) or die "Can't execute SQL statemen
+t: $DBI::errstr\n";
    
    $dbh->commit;
    
}    

sub format_supplier
{
    my $qry = "UPDATE stsc.sku SET p_minimumname = ?";
    
    $qry .= " WHERE loc = ? AND p_dlrsplrcode IN (" . join( ', ', ('?'
+) x @supplier ) . ')';
    
    print "\n$qry\n";

}

sub format_altsupplier
{
    my $qry = "UPDATE stsc.sku SET p_minimumname = ?";
    
    $qry .= " WHERE loc = ? AND p_altdlrsplrcode IN (" . join( ', ', (
+'?') x @altsupplier ) . ')';
    
    print "\n$qry\n";

}

sub LogMsg
{
    my ($msg) = @_;
    print "*** ", scalar localtime, " $msg\n";
}

sub validate_number
{
   my ( $val, $maxval, $colname ) = @_;

   if ($val > $maxval)
   {
     LogMsg("The value of $val you have chosen for $colname is outside
+ of the allowable range [<= $maxval]");
     return 1;
   }
   else
   {
     return 0;
   }
}

sub validate_char
{
   my ( $val, $maxval, $colname ) = @_;

   if (length($val) > $maxval)
   {
     LogMsg("The value of $val you have chosen for $colname is outside
+ of the allowable range [<= $maxval chars]");
     return 1;
   }
   else
   {
     return 0;
   }
}

sub usage()
{
   print STDERR << "EOF";

usage: $0 [-dealer -supplier -altsupplier -min]

  -h             : this (help) message
  -dealer        : dealer to use for the update
  -supplier      : supplier code
  -altsupplier   : alternate supplier code
  -min           : minimum name

  example: $0 -dealer A875 -supplier CM CX -min TEST123
       or: $0 -dealer A875 -altsupplier AA BB -min TEST123

EOF
  exit;
}

sub isvaliddate
{
   # validates a date
   # example:
   # my $dateval = "12-28-2007";
   # my $result = isvaliddate($dateval);
   
   my $input = shift;
  
   if ($input =~ m!^((0[1-9]|1[012])[- /.](0[1-9]|[12][0-9]|3[01])[- /
+.](19|20)\d\d)$!)
   {
     # At this point, $1 holds the year, $2 the month and $3 the day o
+f the date entered
     if ($3 == 31 and ($2 == 4 or $2 == 6 or $2 == 9 or $2 == 11))
     {
       return 0; # 31st of a month with 30 days
     }
     elsif ($3 >= 30 and $2 == 2)
     {
       return 0; # February 30th or 31st
     }
     elsif ($2 == 2 and $3 == 29 and not ($1 % 4 == 0 and ($1 % 100 !=
+ 0 or $1 % 400 == 0)))
     {
       return 0; # February 29th outside a leap year
     }
     else
     {
       return 1; # Valid date
     }
   }
   else
   {
     return 0; # Not a date
   }
}

[download]

Edit: g0n - readmore tags

Replies are listed 'Best First'.
Re: Need help with Validation script
by Corion (Patriarch) on Jul 16, 2007 at 17:18 UTC

    Seriously, it took me about 5 minutes to understand your lengthy code, so I really wonder - what have you done so far to find out where your code does go wrong? Have you traced it in the debugger? Have you sprinkled diagnostic print or warn statements?

    As a hint, Perl does not consider two strings identical if they differ in case. For example the following prints not equal:

    my $col_name = 'P_DLRUOM';
my $entered_value = 'p_dlruom';

sub check_colname {
    if ($col_name eq $entered_value) {
        return 'equal';
    };
    return 'not equal';
};

    [download]

    If this hint is not yet enough information for you, compare the next code with the code you have in validate_fields:

    
sub validate_fields {
    my ($colvalue,$colname) = @_;

    if ($colname eq 'P_DLRUOM') {
        warn "Checking '$colvalue' for validity in 'P_DLRUOM':";
        return validate_p_dlruom( $updateval );
    } elsif ($colname eq 'FOO') {
        warn "Checking '$colvalue' for validity in 'FOO':";
        return validate_foo( $updateval );
    } else {
        warn "Unknown column name '$colname' passed.";
        return;
    };
};

    [download]

    Coincidentially, your whole data setup is horrible - you should store the whole information about your table in a data structure and then use that data structure to run your program instead of hardcoding all the column names and possible values. Perl has a very good data structure for such things, the hash. It maps names to other things, for example subroutines:

    # Map the column name to the validator code:
my %validator = (
    P_12MONTHDEMANDQTY => \&validate_number,
    ...
    P_DLRUOM => \&validate_p_dlruom,
    ...
);

sub validate_fields
{
    my ($updateval, $colname) = @_;
    if (! exists $validator{ $colname }) {
        warn "'$colname' is not a valid column name.";
    };
    my $code = $validator{ $colname };
    if (! $code->($updateval, $colname)) {
        warn "'$updateval' is not a valid value for '$colname'.";
    } else {
        warn "'$updateval' is a valid value for '$colname'.";
        return 1
    };
}

    [download]

    Far fewer opportunities to forget a value or to return the wrong value with this. You might want to do a search on dispatch tables here to learn more.

[reply]
[d/l]
[select]
      Thanks for your input. I'm still trying to get my hands around this concept of dispatch tables by construnction a small example here below: 
      #!/usr/bin/perl -w


my @p_dlruom = ("EACH","FEET","FT","IN","UNIT");

my %validator = (
    P_12MONTHDEMANDQTY => \&validate_number,
    P_DLRUOM => \&validate_p_dlruom
);


validate_fields(EACH, P_DLRUOM);



sub validate_fields
{
    my ($updateval, $colname) = @_;

    #print "$updateval $colname\n";

    if (! exists $validator{ $colname }) {
        print "'$colname' is not a valid column name.";
    };

    my $code = $validator{ $colname };

    if (! $code->($updateval, $colname)) {
        print "'$updateval' is not a valid value for '$colname'.";
    } else {
        print "'$updateval' is a valid value for '$colname'.";
        return 1
    };
}

sub validate_p_dlruom
{
 my $val = shift;

 my @match = grep (/$val/i, @p_dlruom);

 print "The value of $val you have chosen for P_DLRUOM is outside of t
+he allowable range.\n" if !(@match);

}

      [download]
[reply]
[d/l]

        I'm not sure exactly what feed back you are looking for on this code, but I have a couple of comments:

        • Be careful passing around barewords. Use strict and warnings to catch this. In your code, I'm specifically referring to this line: 
          validate_fields(EACH, P_DLRUOM);

          [download]
          Which will error under strictures and who knows what it will do otherwise. Instead, make sure you quote the words: 
          validate_fields('EACH', 'P_DLRUOM');

          [download]
          or: 
          validate_fields( qw( EACH P_DLRUOM ) );

          [download]
        • You are checking for the return value of your coderef, but the coderef you call doesn't actually explicitly return anything. In its current state, it will always return true, or rather, it will return the result of the print statement, as it is the last thing that happens in the subroutine
        • This doesn't make a big difference, but be careful about how you pass arguments. validate_p_dlruom only looks at the first argument, but you pass two. Generally, I like to do this: 
          foo( { arg1 => 'val1', arg2 => 'val2' } );

sub foo{
    my $arg_ref = shift;

    # do some stuff with $arg_ref->{arg1} and
    # $arg_ref->{arg_2}

...

    return;
}

          [download]
          Then you have a better idea of what you are passing around and you don't have to rely on the order in which they are passed. 
        perl -e 'split//,q{john hurl, pest caretaker}and(map{print @_[$_]}(joi
+n(q{},map{sprintf(qq{%010u},$_)}(2**2*307*4993,5*101*641*5261,7*59*79
+*36997,13*17*71*45131,3**2*67*89*167*181))=~/\d{2}/g));'

        [download]
[reply]
[d/l]
[select]

Back to Seekers of Perl Wisdom