Related
I would imagine this is too big and too specific for a normal StackOverflow question, so I can understand if there isn't any possible help. However I will try and show what is the issue I am facing. Also I am new to Perl and I know you shouldn't declare all variables at the start, I'm just trying to see if I can get this implemented first.
I have a Perl script:
use 5.010;
use Math::Trig ':radial';
use Math::Trig;
use List::Util qw(max min);
#Input parameters:
#The ouput filename:
$outfile = 'Tree.scad';
#The coordinates of the points that is to be supported.
$min_X=0;
$max_X=60;
$min_Y=0;
$max_Y=60;
$distance=10;
#The minimum angle from horizontal your printer can make, in degrees
$min_angle= 40;
#Ignore the next line, it is not an input parameter.
($X_ref,$Y_ref)=grid($min_X,$max_X,$min_Y,$max_Y,$distance);#X=#$X_ref;#Y=#{$Y_ref};
for $i (0..$#X){
$Z[$i]=20;#The function that defined the height of each point. This setting wil give you a flat roof. For a more advanced tree, try:
#$Z[$i]=-0.01*$X[$i]**2+0.2*$Y[$i]-0.005*$Y[$i]**2+20;
}
#End of input parameters.
$min_radian = deg2rad($min_angle);
$b = tan($min_radian);
#Z=map{$_/$b}#Z;
open $output, '>', $outfile or die "error writing to '$outfile'";
print $output "width=2;\n";
print $output "sphere_radius=0;\n";
print $output "base_plate_size=10;\n\n";
while ($#X>0){
($I,$J)=find_min_dist(\#X,\#Y,\#Z);
($X_branch,$Y_branch,$Z_branch)=find_branch($X[$I],$Y[$I],$Z[$I],$X[$J],$Y[$J],$Z[$J]);
#X_list=($X_branch,$X[$I],$X[$J]);
#Y_list=($Y_branch,$Y[$I],$Y[$J]);
#Z_list=($Z_branch,$Z[$I],$Z[$J]);
for $j (0..$#Y_list){
if (abs($X_list[$j]) < 0.001){
$X_list[$j]=0;
}
if (abs($Y_list[$j]) < 0.001){
$Y_list[$j]=0;
}
if (abs($Z_list[$j]) < 0.001){
$Z_list[$J]=0;
}
}
branch(\#X_list,\#Y_list,\#Z_list);
splice(#X,$I,1,$X_branch);
splice(#X,$J,1);
splice(#Y,$I,1,$Y_branch);
splice(#Y,$J,1);
splice(#Z,$I,1,$Z_branch);
splice(#Z,$J,1);
}
print $output 'if(base_plate_size>0){';
print $output "\n translate([$X[0],$Y[0],$Z[0]*$b])\n";
print $output "cube([base_plate_size,base_plate_size,1],center=true);}";
sub grid{
my $d=$_[4];
#X_values=$_[0]/$d..$_[1]/$d;
#X_values=map{$_*$d} #X_values;
#Y_values=$_[2]/$d..$_[3]/$d;
#Y_values=map{$_*$d} #Y_values;
for $i (0..$#X_values){
#Y=(#Y,#Y_values);
for $j (0..$#Y_values){
$X[$i*($#Y_values+1)+$j]= $X_values[$i];
}
}
return (\#X,\#Y);
}
sub branch{
my #X=#{ $_[0] };
my #Y=#{ $_[1] };
my #Z=#{ $_[2] };
#Z=map{$_*$b}#Z;
for $i (1..$#X){
($rho, $theta, $phi) = cartesian_to_spherical($X[$i]-$X[0],$Y[$i]-$Y[0],$Z[$i]-$Z[0]);
$phi = rad2deg($phi);
if (abs($phi)<0.001){$phi=0;}
$theta = rad2deg($theta)+90;
if (abs($theta)<0.001){$theta=0;}
if (abs($rho)>0.001){
print $output "translate([$X[0],$Y[0],$Z[0]])\n";
print $output "rotate([0,0,$theta])\n";
print $output "rotate([$phi,0,0])\n";
print $output "translate([-width/2,-width/2,0])";
print $output "cube([width,width,$rho]);\n";
print $output 'if (sphere_radius>0){';
print $output "\n translate([$X[$i],$Y[$i],$Z[$i]])\n";
print $output "sphere(sphere_radius,center=1);}\n";}
}
}
sub find_min_dist{
my #X=#{ $_[0] };
my #Y=#{ $_[1] };
my #Z=#{ $_[2] };
my $min_dist=($X[0]-$X[1])**2+($Y[0]-$Y[1])**2+($Z[0]-$Z[1])**2;
my $max_Z=$Z[0];
my $I=0;
my $J=1;
for $i (1..$#Z){
if ($Z[$i]>=$max_Z){
$max_Z=$Z[$i];
$I=$i;}
}
for $j (0..$#X){
if ($j!=$I){
$dist=(($X[$I]-$X[$j])**2+($Y[$I]-$Y[$j])**2+($Z[$I]-$Z[$j])**2);
if ($min_dist>$dist){
$min_dist=$dist;
$J=$j;
}}}
return ($I,$J);
}
sub find_branch{
my $X1=$_[0];
my $Y1=$_[1];
my $Z1=$_[2];
my $X2=$_[3];
my $Y2=$_[4];
my $Z2=$_[5];
$rXY=sqrt(($X1-$X2)**2+($Y1-$Y2)**2);
if (abs($Z1-$Z2) < $rXY) {
$Z_branch=($Z1+$Z2-$rXY)/2;
$a=($Z1-$Z_branch)/$rXY;
$X_branch=(1-$a)*$X1+$a*$X2;
$Y_branch=(1-$a)*$Y1+$a*$Y2;
}
elsif ($Z1 < $Z2) {
$X_branch=$X1;
$Y_branch=$Y1;
$Z_branch=$Z1;
}
else {
$X_branch=$X2;
$Y_branch=$Y2;
$Z_branch=$Z2;
}
return ($X_branch,$Y_branch,$Z_branch);
}
Which produces a scad file and outputs it as this:
I thought it would be good to implement this method in a slicing program, Slic3r. Now what I have done is attempted to still keep it separate since I would like to show at least this structure in the program and decide whether or not it is possible to do.
Slic3r Original Code: https://github.com/slic3r/Slic3r/blob/21eb603cc16946b14e77d3c10cbee2f1163503c6/lib/Slic3r/Print/SupportMaterial.pm
Modified Slic3r Code: https://pastebin.com/aHzXT4RW
So the comparison is, I removed the generate_pillar_supports and added my grid subroutine. I assumed I would just have to call it since this script is separate to how it's generated compared to the other support structures on:
So replaced this:
my $shape = [];
if ($self->object_config->support_material_pattern eq 'pillars') {
$self->generate_pillars_shape($contact, $support_z, $shape);
}
With this:
my $shape = [];
if ($self->object_config->support_material_pattern eq 'pillars') {
$self->grid($min_X,$max_X,$min_Y,$max_Y,$distance);
}
However unfortunately, I have not been able to get a nice structure to form but rather this:
As I said, I know this is a large question and I'm not diving into the entire Slic3ing program so it might be even harder to understand. However just from a brief look, would anyone know what the issue is? Am I calling the subroutine wrong, does the script only work to produce a scad file, etc. All I would need is just to see if this is able to show or not. Thanks.
sub grid does not appear to be a method, but you are calling it as one
$self->grid($min_X,$max_X,$min_Y,$max_Y,$distance);
This syntax actually sends $self as the first argument, so that call is equivalent to the function call
grid($self,$min_X,$max_X,$min_Y,$max_Y,$distance);
What you probably want is to just say
grid($min_X,$max_X,$min_Y,$max_Y,$distance);
(You also really want to say
use strict;
use warnings;
at the top of every script)
Using sub prototypes, we can define our own subs that look like map or grep. That is, the first coderef argument has shorter syntax than a normal anonymous sub. For example:
sub thunked (&) { $_[0] }
my $val = thunked { 2 * 4 };
Works great here, since the first argument is the coderef. For latter arguments however, it simple won't parse properly.
I made a with sub designed to make writing GTK2 code cleaner. It's meant to look like this (untested since it's hypothetical code):
use 5.012;
use warnings;
use Gtk2 '-init';
sub with ($&) {
local $_ = $_[0];
$_[1]->();
$_;
}
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(with Gtk2::VBox->new {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
Gtk2->main;
It doesn't work because with needs to take the block as a first argument for the nice syntax to work. Is there any way to pull it off?
The module Devel::Declare contains tools for extending Perl's syntax in a relatively safe way.
Using Devel::Declare you would create a hook on the with token, which will stop the parser when it reaches that word. From there, you have control over the parser and you can read ahead until you reach a { symbol. At that point, you have what you need to work with, so you rewrite it into valid Perl, and pass it back to the parser.
in the file With.pm:
package With;
use warnings;
use strict;
use Devel::Declare;
sub import {
my $caller = caller;
Devel::Declare->setup_for (
$caller => {with => {const => \&parser}}
);
no strict 'refs';
*{$caller.'::with'} = sub ($&) {
$_[1]() for $_[0];
$_[0]
}
}
our $prefix = '';
sub get {substr Devel::Declare::get_linestr, length $prefix}
sub set { Devel::Declare::set_linestr $prefix . $_[0]}
sub parser {
local $prefix = substr get, 0, length($_[0]) + $_[1];
my $with = strip_with();
strip_space();
set "scalar($with), sub " . get;
}
sub strip_space {
my $skip = Devel::Declare::toke_skipspace length $prefix;
set substr get, $skip;
}
sub strip_with {
strip_space;
my $with;
until (get =~ /^\{/) {
(my $line = get) =~ s/^([^{]+)//;
$with .= $1;
set $line;
strip_space;
}
$with =~ s/\s+/ /g;
$with
}
and to use it:
use With;
sub Window::add {say "window add: ", $_[1]->str}
sub Window::new {bless [] => 'Window'}
sub Box::new {bless [] => 'Box'}
sub Box::add {push #{$_[0]}, #_[1..$#_]}
sub Box::str {"Box(#{$_[0]})"}
sub Button::new {"Button($_[1])"}
with Window->new {
$_->add(with Box->new {
for my $num (1 .. 4) {
$_->add(Button->new($num))
}
})
};
Which prints:
window add: Box(Button(1) Button(2) Button(3) Button(4))
A completely different approach would be to skip the with keyword altogether and write a routine to generate constructor subroutines:
BEGIN {
for my $name (qw(VBox)) { # and any others you want
no strict 'refs';
*$name = sub (&#) {
use strict;
my $code = shift;
my $with = "Gtk2::$name"->new(#_);
$code->() for $with;
$with
}
}
}
and then your code could look like
for (Gtk2::Window->new('toplevel')) {
$_->set_title('Test Application');
$_->add(VBox {
my $box = $_;
$box->add(Gtk2::Button->new("Button $_")) for (1..4);
});
$_->show_all;
}
One way that you could deal with it is to add a fairly useless keyword:
sub perform(&) { $_[0] }
with GTK2::VBox->new, perform { ... }
where perform is really just a sugarier alternative to sub.
Another way is to write a Devel::Declare filter or a Syntax::Keyword:: plugin to implement your with, as long as you have some way to tell when you're done parsing the with argument and ready to start parsing the block — balanced parentheses would do (so would an opening curly brace, but then hashes become a problem). Then you could support something like
with (GTK2::VBox->new) { ... }
and let the filter rewrite it to something like
do {
local $_ = GTK2::VBox->new;
do {
...;
};
$_;
}
which, if it works, has the advantage of not actually creating a sub, and thus not interfering with #_, return, and a few other things. The two layers of do-age I think are necessary for being able to install an EndOfScope hook in the proper place.
The obvious disadvantages of this are that it's tricky, it's hairy, and it's a source filter (even if it's a tame one) which means there are problems you have to solve if you want any code using it to be debuggable at all.
I don't grok Perl subroutine attributes at all.
I have never seen them in actual code and perldoc perlsub and the perldoc attributes fail to answer my questions:
What are attributes useful for?
What do they bring to the table that is not already present in Perl best practices?
Are there any CPAN modules (well-known or otherwise) that make use of attributes?
It would be great if someone could put together a detailed example of attributes being used the way they should be.
For those who are as clueless as me, attributes are the parameters after the colon in the attributes SYNOPSIS examples below:
sub foo : method ;
my ($x,#y,%z) : Bent = 1;
my $s = sub : method { ... };
use attributes (); # optional, to get subroutine declarations
my #attrlist = attributes::get(\&foo);
use attributes 'get'; # import the attributes::get subroutine
my #attrlist = get \&foo;
Attributes allow you annotate variables to perform auto-magic behind the scenes. A similar concept is java annotations. Here is a small example that might help. It uses Attribute::Handlers to create the loud attributes.
use Attribute::Handlers;
sub UNIVERSAL::loud : ATTR(CODE) {
my ( $pkg, $sym, $code ) = #_;
no warnings 'redefine';
*{$sym} = sub {
return uc $code->(#_);
};
}
sub foo : loud {
return "this is $_[0]";
}
say foo("a spoon");
say foo("a fork");
Whenever a sub is declared with the loud attribute the UNIVERSAL::loud callback triggers exposing meta-information on the sub. I redefined the function to actually call an anonymous sub, which in turn calls the original sub and passes it to uc
This outputs:
THIS IS A SPOON
THIS IS A FORK
Now let's looks a the variable example from the SYNOPSIS:
my ($x,#y,%z) : Bent = 1;
Breaking this down into small perl statement without taking into account attributes we have
my $x : Bent
$x = 1;
my #y : Bent
#y = 1;
my %Z : Bent
%z = 1;
We can now see that each variable has been attributed the Bent annotation in a concise way, while also assigning all variables the value 1. Here is a perhaps more interesting example:
use Attribute::Handlers;
use Tie::Toggle;
sub UNIVERSAL::Toggle : ATTR(SCALAR) {
my ($package, $symbol, $referent, $attr, $data, $phase) = #_;
my #data = ref $data eq 'ARRAY' ? #$data : $data;
tie $$referent, 'Tie::Toggle', #data;
}
my $x : Toggle;
say "x is ", $x;
say "x is ", $x;
say "x is ", $x;
Which outputs:
x is
x is 1
x is
You can use this to do logging, create test annotations, add type details to variables, syntactic sugar, do moose-ish role composition and many other cool things.
Also see this question: How do Perl method attributes work?.
What are attributes useful for?
It is a way to pass some additional information (the attribute)
about a variable or subroutine.
You can catch this information (the attribute) as a string ( at COMPILE TIME !)
and handle it however you like. You can generate additional code,
modify stashs ... . It is up to you.
What do they bring to the table that is not already present in Perl best practices?
Sometimes it makes life easier. See example below.
Some people use it. Do a : find . -name *.p[ml] | xargs grep 'use attributes;'
at your perl installation path to look at packages using attributes.
Catalyst extensively uses attributes to handle requests based on the given path.
Example :
Say you like to execute subroutines in a certain order. And you want to tell the
subroutine when it has to execute ( by a run number RUNNR ). Using attributes
the implementation could be :
#!/usr/bin/env perl
use strict;
use warnings;
use Runner; # immplements the attribute handling
# some subroutines to be scheduled :
# attibutes automatically filling #$Runner::schedule
sub func_a : RUNNR(2) {return "You called func_a !"};
sub func_b : RUNNR(1) {return "You called func_b !"};
sub func_c : RUNNR(3) {return "You called func_c !"};
# run the subroutines according to the their RUNNR
sub run {
# #$Runner::schedule holds the subroutine refs according
# to their RUNNR
foreach my $func (#$Runner::schedule) {
if ( defined $func ) {
print "Running : $func --> ", $func->(), "\n";
}
}
}
print "Starting ...\n\n";
run();
print "\nDone !\n";
The attribute handling is in package Runner using the MODIFY_CODE_ATTRIBUTES
hook.
package Runner;
use strict;
use warnings;
use attributes;
BEGIN {
use Exporter ();
our (#ISA, #EXPORT);
#ISA = qw(Exporter);
#EXPORT = qw(&MODIFY_CODE_ATTRIBUTES); # needed for use attributes;
}
# we have subroutines with attributes : <type> is CODE in MODIFY_<type>_ATTRIBUTES
# MODIFY_CODE_ATTRIBUTES is executed at COMPILE TIME ! try perl -c <prog_name> to prove it :-)
sub MODIFY_CODE_ATTRIBUTES {
# for each subroutine of a package we get
# the code ref to it and the attribute(s) as string
my ($pckg, $code_ref, #attr) = #_;
# whatever you like to do with the attributes of the sub ... do it
foreach my $attr (#attr) {
# here we parse the attribute string(s), extract the number and
# save the code ref of the subroutine
# into $Runner::schedule array ref according to the given number
# that is how we 'compile' the RUNNR of subroutines into
# a schedule
if ( $attr =~ /^RUNNR\((\d+)\)$/ ) {
$Runner::schedule->[$1] = $code_ref;
}
}
return(); # ERROR if returning a non empty list
}
1;
The output will be :
Starting ...
Running : CODE(0x129c288) --> You called func_b !
Running : CODE(0x129c2b8) --> You called func_a !
Running : CODE(0x12ed460) --> You called func_c !
Done !
If you really want to understand what attributes do and when what happens you
have to 'perldoc attributes', read it step by step and play with it. The interface
is cumbersome but in principle you hook in at compile time and handle
the information provided.
You can use attributes to tie a variable upon creation. See the silly module Tie::Hash::Cannabinol which lets you do:
use Tie::Hash::Cannabinol;
my %hash;
tie %hash, 'Tie::Hash::Cannabinol';
## or ##
my %hash : Stoned;
Edit: upon deeper examination, T::H::C (hehe) uses Attribute::Handlers too (as JRideout's answer already suggests) so perhaps that is the place to look.
Here's an example that I ran on perl 5.26.1 with Carp::Assert. Perl attributes seem to generate nice syntax for decorator pattern. Was sort of a pain to implement MODIFY_CODE_ATTRIBUTES though b.c. of the damn eval and Perl's auto reference counting.
use strict;
use Carp::Assert;
# return true if `$func` is callable, false otherwise
sub callable {
my ($func) = #_;
return defined(&$func);
}
# get the symbol table hash (stash) and the inverse of it the
# coderef table hash (crtash) where coderefs are keys and symbols are
# values. The return value is a pair of hashrefs ($stash, $crtash)
sub get_stash_and_crtash {
my $stash = eval("\\%" . __PACKAGE__ . "::");
my %coderef_to_sym;
while (my ($k, $v) = each(%$stash)) {
$coderef_to_sym{$v} = $k if (callable($v));
}
return ($stash, \%coderef_to_sym);
}
# return an eval string that inserts `$inner` as the first argument
# passed into the function call string `$outer`. For example, if
# `$inner` is "$foo" (the lvalue NAME, not the lvalue itself), and
# `$outer` is "bar(1)", then the resulting eval string will be
# "bar($foo, 1)"
sub insert_context {
my ($inner, $outer) = #_;
my $args_pat = qr/\((.*)\)$/;
$outer .= '()' if ($outer !~ /\)$/);
$outer =~ /$args_pat/;
$1 ?
$outer =~ s/$args_pat/($inner, $1)/ :
$outer =~ s/$args_pat/($inner)/;
return $outer;
}
# hook that gets called when appending attributes to functions.
# `$cls` is the package at the point of function declaration/definition,
# `$ref` is the coderef to the function being declared/defined,
# `#attrs` is a list to the attributes being added. Attributes are function
# call strings.
sub MODIFY_CODE_ATTRIBUTES {
my ($cls, $ref, #attrs) = #_;
assert($cls eq 'main');
assert(ref($ref) eq 'CODE');
for (#attrs) {
assert(/^appender_d\(.*\)$/ || $_ eq 'upper_d');
}
my #non_decorators = grep { !/^\w+_d\b/ } #attrs;
return #non_decorators if (#non_decorators);
my ($stash, $crtash) = get_stash_and_crtash();
my $sym = $crtash->{$ref};
$stash->{$sym} = sub {
my $ref = $ref;
my $curr = '$ref';
for my $attr (#attrs) {
$curr = insert_context($curr, $attr);
}
eval("${curr}->()");
};
return ();
}
sub appender_d {
my ($func, $chars) = #_;
return sub { $func->() . $chars };
}
sub upper_d {
my ($func) = #_;
return sub { uc($func->()) };
}
sub foo : upper_d appender_d('!') {
return "foo";
}
sub main {
print(foo());
}
main();
I have written a Perl script that would start a SNMP session and extracting the data/counters and it's value to a csv file. There are 7 perl scripts; different properties/definition/variables on the top.. but the engine is the same.
At this point, those 7 perl scripts are redundant except for the defined variables. Is there a way to keep the execution perl script as a properties/execution file and keep the engine in a another file? This properties/execution perl script will call the engine (using the properties defined in it's own script).
So in short, I want to use the variables in their own script (as an execution as well), but calls a specific function from a unified "engine".
i.e.
retrieve_mibs1.pl retrieve_mibs2.pl
retrieve_mibs3.pl
retrieve_mibs4.pl
retrieve_mibs5.pl
retrieve_mibs6.pl
retrieve_mibs7.pl
retrieve_mibs1.pl
#!/usr/local/bin/perl
use Net::SNMP;
##DEFINITION START
my #Servers = (
'server1',
'server2',
);
my $PORT = 161;
my $COMMUNITY = 'secret';
my $BASEOID = '1.2.3.4.5.6.7.8';
my $COUNTERS = [
[11,'TotalIncomingFromPPH'],
[12,'TotalFailedIncomingFromPPH'],
];
##ENGINE START
sub main {
my $stamp = gmtime();
my #oids = ();
foreach my $counter (#$COUNTERS) {
push #oids,("$BASEOID.$$counter[0].0");
}
foreach my $server (#Servers) {
print "$stamp$SEPARATOR$server";
my ($session,$error) = Net::SNMP->session(-version => 1,-hostname => $server,-port => $PORT,-community => $COMMUNITY);
if ($session) {
my $result = $session->get_request(-varbindlist => \#oids);
if (defined $result) {
foreach my $oid (#oids) {
print $SEPARATOR,$result->{$oid};
}
} else {
print STDERR "$stamp Request error: ",$session->error,"\n";
print "$SEPARATOR-1" x scalar(#oids);
}
} else {
print STDERR "$stamp Session error: $error\n";
print "$SEPARATOR-1" x scalar(#oids);
}
print "\n";
}
}
main();
You could do it using eval: set up the variables in one file, then open the engine and eval it's content.
variables.pl (set up your variables and call the engine):
use warnings;
use strict;
use Carp;
use English '-no_match_vars';
require "engine.pl"; # so that we can call it's subs
# DEFINITION START
our $VAR1 = "Hello";
our $VAR2 = "World";
# CALL THE ENGINE
print "START ENGINE:\n";
engine(); # call engine
print "DONE\n";
engine.pl (the actual working stuff):
sub engine{
print "INSIDE ENGINE\n";
print "Var1: $VAR1\n";
print "Var2: $VAR2\n";
}
1; # return a true value
Other alternatives would be:
pass the definitions as command line parameters directly to engine.pl and evaluate the contents of #ARGV
write a perl module containing the engine and use this module
store the parameters in a config file and read it in from your engine (e.g. using Config::IniFiles)
Two thoughts come to mind immediately:
Build a Perl module for your common code, and then require or use the module as your needs dictate. (The difference is mostly whether you want to run LynxLee::run_servers() or run_servers() -- do you want the module to influence your current scope or not.)
Use symbolic links: create these symlinks: retrieve_mibs1.pl -> retrieve_mibs.pl retrieve_mibs2.pl -> retrieve_mibs.pl, and so on, then set the variables based on the program name:
#!/usr/bin/perl -w
use File::Basename;
my $name = basename($0);
my #Servers, $PORT, $COMMUNITY, $BASEOID, $COUNTERS;
if($name ~= /retrieve_mibs1\.pl/) {
#Servers = (
'server1',
'server2',
);
# ...
} elsif ($name ~= /retrieve_mibs2\.pl/) {
#Servers = (
'server3',
'server4',
);
# ...
}
Indexing into a hash with the name of the program to retrieve the parameters would be much cleaner, but I'm not so good at Perl references. :)
I'm not sure what the problem is so I'm guessing a little. You have code in various places that is the same each time save for some variables. This is the very definition of a subroutine.
Maybe the problem is that you don't know how to include the common code in those various scripts. This is fairly easy: You write that code in a perl module. This is basically a file ending in pm instead of pl. Of course you have to take care of a bunch of things such as exporting your functions. Perldoc should be of great help.
I'm an experienced developer, but not in Perl. I usually learn Perl to hack a script, then I forget it again until the next time. Hence I'm looking for advice from the pros.
This time around I'm building a series of data analysis scripts. Grossly simplified, the program structure is like this:
01 my $config_var = 999;
03 my $result_var = 0;
05 foreach my $file (#files) {
06 open(my $fh, $file);
07 while (<$fh>) {
08 &analyzeLine($_);
09 }
10 }
12 print "$result_var\n";
14 sub analyzeLine ($) {
15 my $line = shift(#_);
16 $result_var = $result_var + calculatedStuff;
17 }
In real life, there are up to about half a dozen different config_vars and result_vars.
These scripts differ mostly in the values assigned to the config_vars. The main loop will be the same in every case, and analyzeLine() will be mostly the same but could have some small variations.
I can accomplish my purpose by making N copies of this code, with small changes here and there; but that grossly violates all kinds of rules of good design. Ideally, I would like to write a series of scripts containing only a set of config var initializations, followed by
do theCommonStuff;
Note that config_var (and its siblings) must be available to the common code, as must result_var and its lookalikes, upon which analyzeLine() does some calculations.
Should I pack my "common" code into a module? Create a class? Use global variables?
While not exactly code golf, I'm looking for a simple, compact solution that will allow me to DRY and write code only for the differences. I think I would rather not drive the code off a huge table containing all the configs, and certainly not adapt it to use a database.
Looking forward to your suggestions, and thanks!
Update
Since people asked, here's the real analyzeLine:
# Update stats with time and call data in one line.
sub processLine ($) {
my $line = shift(#_);
return unless $line =~ m/$log_match/;
# print "$1 $2\n";
my ($minute, $function) = ($1, $2);
$startMinute = $minute if not $startMinute;
$endMinute = $minute;
if ($minute eq $currentMinute) {
$minuteCount = $minuteCount + 1;
} else {
if ($minuteCount > $topMinuteCount) {
$topMinute = $currentMinute;
$topMinuteCount = $minuteCount;
printf ("%40s %s : %d\n", '', $topMinute, $topMinuteCount);
}
$totalMinutes = $totalMinutes + 1;
$totalCount = $totalCount + $minuteCount;
$currentMinute = $minute;
$minuteCount = 1;
}
}
Since these variables are largely interdependent, I think a functional solution with separate calculations won't be practical. I apologize for misleading people.
Two comments: First, don't post line numbers as they make it more difficult than necessary to copy, paste and edit. Second, don't use &func() to invoke a sub. See perldoc perlsub:
A subroutine may be called using an explicit & prefix. The & is optional in modern Perl, ... Not only does the & form make the argument list optional, it also disables any prototype checking on arguments you do provide.
In short, using & can be surprising unless you know what you are doing and why you are doing it.
Also, don't use prototypes in Perl. They are not the same as prototypes in other languages and, again, can have very surprising effects unless you know what you are doing.
Do not forget to check the return value of system calls such as open. Use autodie with modern perls.
For your specific problem, collect all configuration variables in a hash. Pass that hash to analyzeLine.
#!/usr/bin/perl
use warnings; use strict;
use autodie;
my %config = (
frobnicate => 'yes',
machinate => 'no',
);
my $result;
$result += analyze_file(\%config, $_) for #ARGV;
print "Result = $result\n";
sub analyze_file {
my ($config, $file) = #_;
my $result;
open my $fh, '<', $file;
while ( my $line = <$fh> ) {
$result += analyze_line($config, $line);
}
close $fh;
return $result;
}
sub analyze_line {
my ($line) = #_;
return length $line;
}
Of course, you will note that $config is being passed all over the place, which means you might want to turn this in to a OO solution:
#!/usr/bin/perl
package My::Analyzer;
use strict; use warnings;
use base 'Class::Accessor::Faster';
__PACKAGE__->follow_best_practice;
__PACKAGE__->mk_accessors( qw( analyzer frobnicate machinate ) );
sub analyze_file {
my $self = shift;
my ($file) = #_;
my $result;
open my $fh, '<', $file;
while ( my $line = <$fh> ) {
$result += $self->analyze_line($line);
}
close $fh;
return $result;
}
sub analyze_line {
my $self = shift;
my ($line) = #_;
return $self->get_analyzer->($line);
}
package main;
use warnings; use strict;
use autodie;
my $x = My::Analyzer->new;
$x->set_analyzer(sub {
my $length; $length += length $_ for #_; return $length;
});
$x->set_frobnicate('yes');
$x->set_machinate('no');
my $result;
$result += $x->analyze_file($_) for #ARGV;
print "Result = $result\n";
Go ahead and create a class hierarchy. Your task is an ideal playground for OOP style of programming.
Here's an example:
package Common;
sub new{
my $class=shift;
my $this=bless{},$class;
$this->init();
return $this;
}
sub init{}
sub theCommonStuff(){
my $this=shift;
for(1..10){ $this->analyzeLine($_); }
}
sub analyzeLine(){
my($this,$line)=#_;
$this->{'result'}.=$line;
}
package Special1;
our #ISA=qw/Common/;
sub init{
my $this=shift;
$this->{'sep'}=','; # special param: separator
}
sub analyzeLine(){ # modified logic
my($this,$line)=#_;
$this->{'result'}.=$line.$this->{'sep'};
}
package main;
my $c = new Common;
my $s = new Special1;
$c->theCommonStuff;
$s->theCommonStuff;
print $c->{'result'}."\n";
print $s->{'result'}."\n";
If all the common code is in one function, a function taking your config variables as parameters, and returning the result variables (either as return values, or as in/out parameters), will do. Otherwise, making a class ("package") is a good idea, too.
sub common_func {
my ($config, $result) = #_;
# ...
$result->{foo} += do_stuff($config->{bar});
# ...
}
Note in the above that both the config and result are hashes (actually, references thereto). You can use any other data structure that you feel will suit your goal.
Some thoughts:
If there are several $result_vars, I would recommend creating a separate subroutine for calculating each one.
If a subroutine relies on information outside that function, it should be passed in as a parameter to that subroutine, rather than relying on global state.
Alternatively wrap the whole thing in a class, with $result_var as an attribute of the class.
Practically speaking, there are a couple ways you could implement this:
(1) Have your &analyzeLine function return calculatedStuff, and add it to &result_var in a loop outside the function:
$result_var = 0;
foreach my $file (#files) {
open(my $fh, $file);
while (<$fh>) {
$result_var += analyzeLine($_);
}
}
}
sub analyzeLine ($) {
my $line = shift(#_);
return calculatedStuff;
}
(2) Pass $result_var into analyzeLine explicitly, and return the changed $result_var.
$result_var = 0;
foreach my $file (#files) {
open(my $fh, $file);
while (<$fh>) {
$result_var = addLineToResult($result_var, $_);
}
}
}
sub addLineToResult ($$) {
my $running_total = shift(#_);
my $line = shift(#_);
return $running_total + calculatedStuff;
}
The important part is that if you separate out functions for each of your several $result_vars, you'll be more readily able to write clean code. Don't worry about optimizing yet. That can come later, when your code has proven itself slow. The improved design will make optimization easier when the time comes.
why not create a function and using $config_var and $result_var as parameters?