|
monsterzero has asked for the wisdom of the Perl Monks concerning the following question:
Hi All,
I have a perl script that I maintain and need some advice as how to improve the code to make it easier to maintain. The code is as follows:
#!/app/bin/perl
use DBI;
use Data::Dumper;
use DateTime;
use DateTime::Span;
use DateTime::Format::Strptime;
use warnings;
use strict;
use Mail::Mailer;
use Text::Table;
use Getopt::Long;
use vars
qw(%convert_name %people %family_list $family $family_release @by_fa
+mily $start $end $normal $dt_set);
my @family = qw(TOTAL NX1 NX2 NX3 NX4 TC_ENG TC_COM SE16 SE17 SE18 W
+EBTOOLS other);
my $parsed_date = DateTime::Format::Strptime->new( pattern => '%m-%d-%
+Y', );
my $success = GetOptions(
'sd=s' => \$start,
'ed=s' => \$end,
'N' => \$normal
);
if ( $start && $end ) {
$dt_set = DateTime::Span->from_datetimes(
start => $parsed_date->parse_datetime($start),
before => $parsed_date->parse_datetime($end),
);
}
else {
my $this_month = DateTime->today->truncate( to => 'month' );
$dt_set = DateTime::Span->from_datetimes(
start => $this_month->clone->subtract( months => 1 ),
before => $this_month,
);
}
#my $dbh = DBI->connect( 'DBI:Ingres:fsing0::prod_db', '', '' )or die"
+Cannot connect";
my $dbh = DBI->connect( 'DBI:Ingres:report::ustac_db', '', '' );
my $statement = "SELECT tac_employee_id, emp_first_name, emp_last_name
FROM tac_employee_table WHERE emp_mgr_id = 'spain' and emp_fla
+g = 'a' and location='CYPRESS'";
my $sth = $dbh->prepare("$statement");
$sth->execute;
while ( my @row = $sth->fetchrow_array ) {
$row[1] =~ s/(\w+)/\u\L$1/g;
$row[2] =~ s/(\w+)/\u\L$1/g;
$convert_name{ $row[0] } = "$row[1] $row[2]";
}
my $format_date =
DateTime::Format::Strptime->new( pattern => '%m-%d-%Y %H:%M:%S', );
my $select_statement = "select cm.family, cm.family_release from ir_ta
+ble ir, call_master_table cm";
my $where_statement = " where ir.ir_id = cm.call_master_id and ";
$where_statement .= " ir.closed_date is not NULL and ";
$where_statement .= "(ir.closed_date >= '" . $format_date->format_date
+time( $dt_set->min ) . "' and";
$where_statement .= " ir.closed_date < '"
. $format_date->format_datetime( $dt_set->max )
. "' ) and cm.user_id = ? ";
my $statement1 = $select_statement . $where_statement;
$sth = $dbh->prepare($statement1);
my %by_family = ();
foreach my $user ( sort keys %convert_name ) {
#print "Processing user $user \n";
$sth->execute($user);
$sth->bind_columns( \$family, \$family_release );
while ( $sth->fetch ) {
$family = trim($family);
( undef, $family_release ) = $family_release =~ /(P|V)(\d+)*/;
#print "$family\n";
SWITCH: for ($family) {
/UNIGRAPHICS_NX/ && do {
if ( $family_release eq "1" ) {
$people{$user}{'NX1'}++;
$people{$user}{TOTAL}++;
}
elsif ( $family_release eq "2" ) {
$people{$user}{'NX2'}++;
$people{$user}{TOTAL}++;
}
else {
$people{$user}{'other'}++;
$people{$user}{TOTAL}++;
}
last SWITCH;
};
/\bNX\b/ && do {
if ( $family_release eq "3" ) {
$people{$user}{'NX3'}++;
$people{$user}{TOTAL}++;
}
elsif ( $family_release eq "4" ) {
$people{$user}{'NX4'}++;
$people{$user}{TOTAL}++;
}
last SWITCH;
};
/SOLID_EDGE/ && do {
if ( $family_release eq "18" ) {
$people{$user}{'SE18'}++;
$people{$user}{TOTAL}++;
}
elsif ( $family_release eq "16" ) {
$people{$user}{'SE16'}++;
$people{$user}{TOTAL}++;
}
elsif ( $family_release eq "17" ) {
$people{$user}{'SE17'}++;
$people{$user}{TOTAL}++;
}
else {
$people{$user}{'other'}++;
$people{$user}{TOTAL}++;
}
last SWITCH;
};
/WEBTOOLS/ && do {
if ( defined $people{$user}{$family} ) {
$people{$user}{$family}++;
$people{$user}{TOTAL}++;
}
else {
$people{$user}{$family} = 1;
$people{$user}{TOTAL}++;
}
last SWITCH;
};
/TC_ENGR-IMAN/ && do {
if ( defined $people{$user}{'TC_ENG'} ) {
$people{$user}{'TC_ENG'}++;
$people{$user}{TOTAL}++;
}
else {
$people{$user}{'TC_ENG'} = 1;
$people{$user}{TOTAL}++;
}
last SWITCH;
};
/TC_COMMUNITY/ && do {
if ( defined $people{$user}{'TC_COM'} ) {
$people{$user}{'TC_COM'}++;
$people{$user}{TOTAL}++;
}
else {
$people{$user}{'TC_COM'} = 1;
$people{$user}{TOTAL}++;
}
last SWITCH;
};
# DEFAULT
if ( defined $people{$user}{other} ) {
$people{$user}{other}++;
$people{$user}{TOTAL}++;
}
else {
$people{$user}{other} = 1;
$people{$user}{TOTAL}++;
}
} # end for
} #end while
}
$dbh->disconnect;
#print Dumper( \%people );
while ( my ( $item, $record ) = each %people ) {
no warnings 'uninitialized';
$by_family{$_} += $record->{$_} for @family;
}
my %percent;
$percent{$_} = 100 * $by_family{$_} / $by_family{TOTAL} for @family;
$_ = sprintf '%.0f', $_ for values %percent;
while ( my ( $item, $record ) = each %people ) {
$record->{'TOTAL'} = '0' unless ( defined $record->{'TOTAL'} );
}
my $tb = Text::Table->new(
{ is_sep => 1, title => '|' },
{
title => 'Name',
align => 'left',
align_title => 'center'
},
{ is_sep => 1, title => '|' },
{
title => 'Total',
align => 'center',
align_title => 'center'
},
{ is_sep => 1, title => ' | ' },
@family[ 1 .. $#family ],
{ is_sep => 1, title => ' |' },
);
$tb->add( " $convert_name{$_} ", @{ $people{$_} }{@family} ) for sort
+keys %convert_name;
$tb->add( ' Total: ', @by_family{@family} );
$tb->add( ' Percent Total: ',
'100.0', @percent{ @family[ 1 .. $#family ] } );
my $curr_row = 0;
my $title1 = "SYSTEMS CLOSED CALLS BY FAMILY";
my $title2;
$title2 = ( $dt_set->min->strftime("%D") );
$title2 .= (" through ");
$title2 .= ( $dt_set->max->strftime("%D") );
my $num_spaces = ( $tb->width - length($title1) ) / 2;
my $report = sprintf( ' ' x $num_spaces );
$report .= sprintf($title1);
$report .= sprintf("\n");
$num_spaces = ( $tb->width - length($title2) ) / 2;
$report .= sprintf( ' ' x $num_spaces );
$report .= sprintf($title2);
$report .= sprintf("\n");
$report .= $tb->rule( '-', '+' );
$report .= $tb->title;
$report .= $tb->rule( '-', '+' );
do {
$report .= $tb->body($curr_row);
$curr_row++;
} until ( $curr_row >= ( $tb->body_height - 2 ) );
$report .= $tb->rule( '-', '+' );
$report .= $tb->body( $tb->body_height - 2 );
$report .= $tb->rule( '=', '+' );
$report .= $tb->body( $tb->body_height - 1 );
$report .= $tb->rule( '-', '+' );
#print $report;
mail_report($report, $title2);
sub trim {
my @out = @_;
for (@out) {
s/^\s+//;
s/\s+$//;
}
return wantarray ? @out : $out[0];
}
sub mail_report {
my ($message, $title2) = @_;
my $mailer = new Mail::Mailer 'smtp', Server => 'cysmtp.ugs.com';
#my $mailer = new Mail::Mailer qw(sendmail);
my %headers = (
'To' => 'you@example.com',
'Cc' => 'me@example.com',
'Reply-To' => 'you@example.com',
'Subject' => "System Closed Calls By Family (from fsing0) - $
+title2"
);
$mailer->open( \%headers );
print $mailer $message;
$mailer->close;
return;
}
The issue is that wehenever I need to add a product I need to edit the script to add a new product. This involves adding/changing the switch statement. This is where I sometimes make a mistake and I end up adding to the wrong product or make a typo and the totals don't add up. I was looking for a way where I can add/delete/change a product without messing with the switch statement.
I hope this is clear.
Thanks :-) |
Re: Coding for maintainability
by merlyn (Sage) on Feb 16, 2006 at 19:18 UTC
|
The first thing I'd do to make that more maintainable is refactor it all into a series of well-named minimized-coupling subroutines, no longer than 20-30 lines each, and ideally about 10 lines each. That'd also remove about 90% of the global variables, which are generally also a sign of fragile code.
The second thing I'd do is take that middle switch out of there, and capture the regularities with code, and the irregularites with data. I bet you wrote a lot of it with cut and paste, and that should always be a clue.
Let me repeat. Cut and paste is generally a clue that you're doing something wrong.
On a longer-term basis, factoring out some of that code for re-use might be useful, which would also make testing easier. But unless you're also doing some similar tasks later, that might be an expense with no payback.
| [reply] |
|
|
Let me repeat. Cut and paste is generally a clue that you're doing something wrong
or writing a throwaway
| [reply] |
|
|
| [reply] |
Re: Coding for maintainability
by jdporter (Paladin) on Feb 16, 2006 at 19:57 UTC
|
Just for fun, I converted your monster switch into a data-driven function. The data are "rules"; the function performs a generic matching operation on those rules. For compactness of representation, I've written the rule data as one specially formatted text block, which means there's a parsing function as well.
{
my @ruleset;
sub define_rules
{
my $rules = shift;
for my $rp ( split /\n\n/, $rules )
{
my @rules = grep !/^#/, split /\n/, $rp;
s/#.*// for @rules;
s/^\s+// for @rules;
s/\s+$// for @rules;
my $fam_pat = shift @rules;
my %rules = map {
my( $when ) = $_->[0] =~ /(.*):/; # will be undef if n
+o colon
defined $when or $when = '';
( $when => $_->[1] )
} map { /(.*)\bkey\s*=\s*(.*)/ ? [ $1, $2 ] : () } @rules;
push @ruleset, [ $fam_pat, \%rules, ];
}
}
# $key = get_key_by_rules( $family, $family_release );
# if it matches a rule but the rule doesn't specify a key to retur
+n,
# this function returns its first argument (i.e. $family).
# if no match occurs, it returns undef; but your ruleset should
# probably have a catch-all condition at the end so this never hap
+pens.
sub get_key_by_rules
{
my( $major, $minor ) = @_;
defined $minor or $minor = '';
for my $ruleset ( @ruleset )
{
my( $maj_pat, $rules_hr, $default ) = @$ruleset;
if ( $major =~ /$maj_pat/ )
{
if ( exists $rules_hr->{$minor} )
{
my $ret = $rules_hr->{$minor};
return $ret gt '' ? $ret : $major;
}
elsif ( exists $rules_hr->{''} )
{
my $ret = $rules_hr->{''};
return $ret gt '' ? $ret : $major;
}
else
{
return();
}
}
}
return();
}
}
So you'd call define_rules first, passing it the text string defining the rules in the compact notation:
define_rules( <<'EOF' );
# careful - all whitespace is significant in this format.
# use whole-line comments if you need spacers.
UNIGRAPHICS_NX
1: key = NX1
2: key = NX2
key = other
\bNX\b
3: key = NX3
4: key = NX4
SOLID_EDGE
18: key = SE18
16: key = SE16
17: key = SE17
key = other
WEBTOOLS
key = # use the default key, which is $family
TC_ENGR-IMAN
key = TC_ENG
TC_COMMUNITY
key = TC_COM
# default. Unfortunately, this "comment" isn't optional. :-(
key = other
EOF
Then you'd call it like so:
$family = trim($family);
( undef, $family_release ) = $family_release =~ /(P|V)(\d+)*/;
#print "$family\n";
my $key = get_key_by_rules( $family, $family_release );
$people{$user}{$key}++;
$people{$user}{TOTAL}++;
Yep, it's that simple. Although you'd actually want to test that $key isn't undef;
that's the case when there is no rule that matches the given family/release.
We're building the house of the future together.
| [reply]
[d/l]
[select] |
|
|
Wow, Thanks for taking the time to respond to my question.
| [reply] |
Re: Coding for maintainability
by dragonchild (Archbishop) on Feb 16, 2006 at 18:07 UTC
|
You need a modified dispatch table. A dispatch table is where you have (generally) a hash of names where the values are references to subroutines.
my %dispatch = (
foo => sub { print "foo\n"; },
bar => \&bar,
);
chomp( my $input = <> );
unless ( exists $dispatch{ $input } ) {
die "I don't know what to do with '$input'\n";
}
$dispatch{$input}->();
sub bar { print "bar\n"; }
The modification needed is that you aren't matching on a simple string. There's a few ways to improve this. One is to pass $family to every function and let them determine if they want to handle it. Then, the function returns either true (I handled it) or false (I don't deal with this value). Errors would be propagated with die and caught with an eval-block.
Then, whenever you add something, you're working with a much smaller piece of the puzzle because the engine and the parts are separated.
My criteria for good software:
- Does it work?
- Can someone else come in, make a change, and be reasonably certain no bugs were introduced?
| [reply]
[d/l] |
|
|
| [reply] |
|
|
Hello,
Currently I have used the code provided by jdporter instead of my switch statement. However, I will now look at the dispatch table option that you have recommended and see if that will make this script easier to maintain.
Thanks for your reply
| [reply] |
Re: Coding for maintainability
by jdporter (Paladin) on Feb 16, 2006 at 18:23 UTC
|
if ( defined $people{$user}{'TC_ENG'} ) {
$people{$user}{'TC_ENG'}++;
$people{$user}{TOTAL}++;
}
else {
$people{$user}{'TC_ENG'} = 1;
$people{$user}{TOTAL}++;
}
You should know that incrementing a variable containing an undefined value first treats the
undef like a zero, which means it ends up with the value 1. And that doing this to a hash key
which doesn't even exist yet makes it exist first. So the above can be replaced by
$people{$user}{'TC_ENG'}++;
$people{$user}{TOTAL}++;
We're building the house of the future together.
| [reply]
[d/l]
[select] |
Re: Coding for maintainability
by jdporter (Paladin) on Feb 16, 2006 at 18:28 UTC
|
Personally, I don't like how you're setting $where_statement, with all those additional appends.
I'd prefer to use a HERE doc for multi-line chunks of embedded source code, e.g.
my $dt_min = $format_date->format_datetime( $dt_set->min );
my $dt_max = $format_date->format_datetime( $dt_set->max );
my $where_statement = <<EOF;
where ir.ir_id = cm.call_master_id and
ir.closed_date is not NULL and
(ir.closed_date >= '$dt_min' and
ir.closed_date < '$dt_max' ) and cm.user_id = ?
EOF
JMHO, of course.
We're building the house of the future together.
| [reply]
[d/l]
[select] |
Re: Coding for maintainability
by xorl (Deacon) on Feb 16, 2006 at 18:05 UTC
|
Keep the products and the prices in either an array or hash. Then loop thru it, checking if the product matches what has been selected. If it does match then you add to the total and our email body.
Bascially replace the entire switch with somethign like this untested code:
my %products;
$products{"Product1"}{"price"}=100;
$products{"Product1"}{"description"}="A worthless widget";
foreach my $product (keys %products) {
if ($product == $whatevertheuserselected) {
# do something cool here
$total =+ $products{$product}{"price"};
$email_body .= $products{$product}{"description"};
}
}
| [reply]
[d/l] |
Re: Coding for maintainability
by trammell (Priest) on Feb 16, 2006 at 19:45 UTC
|
I suppose this is a matter of style, but I find a few succinct comments add greatly to the maintainability of my code. | [reply] |
Re: Coding for maintainability
by adrianh (Chancellor) on Feb 17, 2006 at 11:19 UTC
|
I have a perl script that I maintain and need some advice as how to improve the code to make it easier to maintain
And if you're spending your time doing lots of maintainence work I would thoroughly recommend getting copies of Perl Medic and Perl Best Practices.
| [reply] |
|
|
