input a number and output the Fibonacci number recursively Perl - perl

For a given value N I am trying to output the corresponding Fibonacci number F(N). My script doesn't seem to enter the recursive stage. fibonnaci($number) is not calling the subroutine. It is simply outputing "fibonacci(whatever number is inputted)".
Here is my code:
#!/usr/bin/perl -w
use warnings;
use strict;
print "Please enter value of N: ";
my $number = <STDIN>;
chomp($number);
sub fibonacci
{
my $f;
if ( $number == 0 ) { # base case
$f = 0;
} elsif ( $number == 1 ) {
$f = 1;
} else { # recursive step
$f = fibonacci( $number - 1 ) + fibonacci( $number - 2 );
}
return $f;
}
print "\nf($number) = fibonacci($number)\n";
Sample Output:
Please enter value of N: 4
f(4) = fibonacci(4)
user1:~>recursiveFib.pl
Please enter value of N: 5
f(5) = fibonacci(5)
user1:~>recursiveFib.pl
Please enter value of N: 10
f(10) = fibonacci(10)
user1:~>
Not sure where I went wrong. Any help would be greatly appreciated.

You need to accept the function arguments properly and take the function call out of the quotes.
use warnings;
use strict;
sub fibonacci {
my ($number) = #_;
if ($number < 2) { # base case
return $number;
}
return fibonacci($number-1) + fibonacci($number-2);
}
print "Please enter value of N: ";
my $number = <STDIN>;
chomp($number);
print "\n$number: ", fibonacci($number), "\n";
A more efficient but still recursive version:
sub fib_r {
my ($n,$a,$b) = #_;
if ($n <= 0) { return $a; }
else { return fib_r($n-1, $b, $a+$b); }
}
sub fib { fib_r($_[0], 0, 1); } # pass initial values of a and b
print fib(10), "\n";

Other answers have already mentioned the lack of taking an argument correctly to the fibonacci function, and that you can't interpolate a function call in the print string like that. Lately my favourite way to interpolate function calls into print strings is to use the ${\ ... } notation for embedding arbitrary expressions into strings:
print "f($number) = ${\ fibonacci($number) }\n";
Other techniques include separate arguments:
print "f($number) = ", fibonacci($number), "\n";
or a helper variable:
my $result = fibonacci($number);
print "f($number) = $result\n";
or even printf:
printf "f(%d) = %d\n", $number, fibonacci($number);
Of all these techniques I tend to prefer either of the first two, because they lead to putting the expressions "in-line" with the rest of the text string, whereas in the latter two they sit elsewhere, making it harder to see at a glance what gets printed where. Especially with printf's positional arguments, it can be easy to be "off-by-one" with a large number of arguments, and put everything in the wrong place.

You are printing in wrong way. you just need to handle the return value. Also the way you are using Number in the sub is also not seems relevant. I have updated the and its working fine.
Also the values that you wanted to print is depend on the start up of the series. whether you want to start from 0 or 1.
The series example start with 1 is 1, 1, 2, 3, 5, 8, 13, 21, 34, 55, so if you put 10 you will get 55.
#!/usr/bin/perl -w
use warnings;
use strict;
print "Please enter value of N: ";
my $number = <STDIN>;
chomp($number);
my $result=fibonacci($number);
sub fibonacci
{
my $f =0;
if ($_[0] == 1 ) { # base case
$f = 1;
} elsif ( $_[0] == 2 ) {
$f = 1;
} else { # recursive step
$f= fibonacci( $_[0] - 1 ) + fibonacci( $_[0] - 2 );
}
return $f;
}
print "\nf($number) = $result\n";

Related

No values being output

I'm having a problem coding my first Perl program.
What I'm trying to do here is getting the maximum, minimum,total and average of a list of numbers using a subroutine for each value and another subroutine to print the final values. I'm using a "private" for all my variables, but I still couldn't print my values.
Here is my code:
&max(<>);
&print_stat(<>);
sub max {
my ($mymax) = shift #_;
foreach (#_) {
if ( $_ > $mymax ) {
$mymax = $_;
}
}
return $mymax;
}
sub print_stat {
print max($mymax);
}
Please try this one:
use strict;
use warnings;
my #list_nums = qw(10 21 30 42 50 63 70);
ma_xi(#list_nums);
sub ma_xi
{
my #list_ele = #_;
my $set_val_max = '0'; my $set_val_min = '0';
my $add_all_vals = '0';
foreach my $each_ele(#list_ele)
{
$set_val_max = $each_ele if($set_val_max < $each_ele);
$set_val_min = $each_ele if($set_val_min eq '0');
$set_val_min = $each_ele if($set_val_min > $each_ele);
$add_all_vals += $each_ele;
}
my $set_val_avg = $add_all_vals / scalar(#list_ele) + 1;
print "MAX: $set_val_max\n";
print "MIN: $set_val_min\n";
print "TOT: $add_all_vals\n";
print "AVG: $set_val_avg\n";
#Return these values into array and get into the new sub routine's
}
Some notes
Use plenty of whitespace to lay out your code. I have tidied the Perl code in your question so that I could read it more easily, without changing its semantics
You must always use strict and use warnings 'all' at the top of every Perl program you write
Never use an ampersand & in a subroutine call. That hasn't been necessary or desirable since Perl 4 over twenty-five years ago. Any tutorial that tells you otherwise is wrong
Using <> in a list context (such as the parameters to a subroutine call) will read all of the file and exhaust the file handle. Thereafter, any calls to <> will return undef
You should use chomp to remove the newline from each line of input
You declare $mymax within the scope of the max subroutine, but then try to print it in print_stat where it doesn't exists. use strict and use warnings 'all' would have caught that error for you
Your max subroutine returns the maximum value that it calculated, but you never use that return value
Below is a fixed version of your code.
Note that I've read the whole file into array #values and then chomped them all at once. In general it's best to read and process input one line at a time, which would be quite possible here but I wanted to say as close to your original code as possible
I've also saved the return value from max in variable $max, and then passed that to print_stat. It doesn't make sense to try to read the file again and pass all of those values to print_stat, as your code does
I hope this helps
use strict;
use warnings 'all';
my #values = <>;
chomp #values;
my $max = max(#values);
print_stat( $max );
sub max {
my $mymax = shift;
for ( #_ ) {
if ( $_ > $mymax ) {
$mymax = $_;
}
}
return $mymax;
}
sub print_stat {
my ($val) = #_;
print $val, "\n";
}
Update
Here's a version that calculates all of the statistics that you mentioned. I don't think subroutines are a help in this case as the solution is short and no code is reusable
Note that I've added the data at the end of the program file, after __DATA__, which lets me read it from the DATA file handle. This is often handy for testing
use strict;
use warnings 'all';
my ($n, $max, $min, $tot);
while ( <DATA> ) {
next unless /\S/; # Skip blank lines
chomp;
if ( not defined $n ) {
$max = $min = $tot = $_;
}
else {
$max = $_ if $max < $_;
$min = $_ if $min > $_;
$tot += $_;
}
++$n;
}
my $avg = $tot / $n;
printf "\$n = %d\n", $n;
printf "\$max = %d\n", $max;
printf "\$min = %d\n", $min;
printf "\$tot = %d\n", $tot;
printf "\$avg = %.2f\n", $avg;
__DATA__
7
6
1
5
1
3
8
7
output
$n = 8
$max = 8
$min = 1
$tot = 38
$avg = 4.75

Splitting and tallying substrings within mixed integer-string data

Input Data (example):
40A3B35A3C
30A5B28A2C2B
Desired output (per-line) is a single number determined by the composition of the code 40A3B35A3C and the following rules:
if A - add the proceeding number to the running total
if B - add the proceeding number to the running total
if C - subtract the proceeding number from the running total
40A 3B 35A 3C would thus produce 40 + 3 + 35 - 3 = 75.
Output from both lines:
75
63
Is there an efficient way to achieve this for a particular column (such as $F[2]) in a tab-delimited .txt file using a one-liner? I have considered splitting the entire code into individual characters, then performing if statement checks to detect A/B/C, but my Perl knowledge is limited and I am unsure how to go about this.
When you use split with a capture, the captured group is returned from split, too.
perl -lane '
#ar = split /([ABC])/, $F[2];
$s = 0;
$s += $n * ("C" eq $op ? -1 : 1) while ($n, $op) = splice #ar, 0, 2;
print $s
' < input
Or maybe more declarative:
BEGIN { %one = ( A => 1,
B => 1,
C => -1 ) }
#ar = split /([ABC])/, $F[2];
$s = 0;
$s += $n * $one{$op} while ($n, $op) = splice #ar, 0, 2;
print $s
When working through a string like this, it's useful to know that regular expressions can return a list of results.
E.g.
my #matches = $str =~ m/(\d+[A-C])/g; #will catch repeated instances
So you can do something like this:
#!/usr/bin/env perl
use strict;
use warnings;
while (<DATA>) {
my $total;
#break the string into digit+letter groups.
for (m/(\d+[A-C])/g) {
#separate out this group into num and code.
my ( $num, $code ) = m/(\d+)([A-C])/;
print "\t",$num, " => ", $code, "\n";
if ( $code eq "C" ) {
$total -= $num;
}
else {
$total += $num;
}
}
print $total, " => ", $_;
}
__DATA__
40A3B35A3C
30A5B28A2C2B
perl -lne 'push #a,/([\d]+)[AB]/g;
push #b,/([\d]+)[C]/g;
$sum+=$_ for(#a);$sum-=$_ for(#b);
print $sum;#a=#b=();undef $sum' Your_file
how it works
use the command line arg as the input
set the hash "%op" to the
operations per letter
substitute the letters for operators in the
input evaluate the substituted input as an expression
use strict;
use warnings;
my %op=qw(A + B + C -);
$ARGV[0] =~ s/(\d+)(A|B|C)/$op{$2} $1/g;
print eval($ARGV[0]);

Perl: Using Algorithm::Loops

I'm trying to construct a permutation program in Perl using the NestedLoops function. Here's my code:
use strict;
use warnings;
use Algorithm::Loops qw(NestedLoops);
my #a = 'a'..'o';
my $length = 5;
my $start = 0;
my $depth = 2;
NestedLoops([
[0..$length],
( sub {
$start = 0 if $start == $depth;
$start++;
[$start * $length..$start * $length + $length - 1]
}) x $depth,
], \&permute,);
sub permute {
my #ind = #_;
foreach my $i (#ind) {
print $a[$i];
}
print "\n";
}
So I've got an array that holds the letters 'a' to 'o' (size being 15). I'm treating the array as if it had 3 rows, so my imagination of the array is this:
abcde
fghij
klmno
Then each loop corresponds to each row... and I want to build permutations like:
afk
afl
afm
afn
afo
agk // fails here... I end up getting agg
...
It works for the first 5 values (the entire run of the lowest for loop), but then the second run fails because the last row's value of $start gets reset to 0... this is a problem because that breaks everything.
So what I want to know is, how can I keep the value of $start persistent based on the level... So what I'm asking for is essentially having constants. My loops really should look like this:
for my $a (0..5) { # 0 at this level and never change
for my $b (5..10) { # $start should be 5 at this level and never change
for my $c (10..15) { # $start should be 10 at this level and never change
permute($a, $b, $c);
}
}
}
Now, because I will have a variable length of for loops, I can't hard code each start value, so I'm looking for a way to initially create those start values, and then keep them for when the loop gets reset.
I realize this is a confusing question, so please ask questions, and I will help clarify.
You are making this harder than it has to be.
Part of the problem is that the documentation for NestedLoops doesn't go into much detail about how a subroutine reference in the first argument, will be used.
For the following examples, assume this is written somewhere above them.
use strict;
use warnings;
use Algorithm::Loops qw'NestedLoops';
Really the simplest way to call NestedLoops to get what you want is like this:
NestedLoops(
[
['a'..'e'],
['f'..'j'],
['k'..'o'],
],
\&permute
);
sub permute {
print #_, "\n";
}
If you really want the arguments to NestedLoops to be generated on the fly, I would recommend using part from List::MoreUtils.
use List::MoreUtils qw'part';
my #a = 'a'..'o';
my $length = 5;
my $index;
NestedLoops(
[
part {
$index++ / $length
} #a
],
\&permute
);
sub permute {
print #_, "\n";
}
If for some reason you want to call NestedLoops with indexes into the array, It is still easy with part.
use List::MoreUtils qw'part';
my #a = 'a'..'o';
my $length = 5;
NestedLoops(
[
part {
$_ / $length
} 0..#a-1
],
\&permute
);
sub permute {
print map { $a[$_] } #_;
print "\n";
}
Really the main problem you're having is that the two subroutine references that you give to NestedLoops are modifying the same variables, and they are both called multiple times.
The best way to fix this is to rely on the last value given to the subroutine when it is called. ( From looking at the implementation, this seems to be closer to how it was meant to be used. )
my #a = 'a'..'o';
my $length = 5;
my $depth = 3;
NestedLoops(
[
[0..$length-1],
(sub{
return unless #_;
my $last = pop;
my $part = int( $last / $length ) + 1; # current partition
my $start = $part * $length; # start of this partition
my $end = $start + $length;
[$start..$end-1] # list of variables in this partition
}) x ($depth-1)
],
\&permute
);
sub permute {
print map { $a[$_] } #_;
print "\n";
}
When you use a subroutine to generate the range of a loop, it is called every time that one of the nested loops must start. That means once for each iteration of the containing loop. Before each call $_ is set to the current value of the containing loop's variable, and the values of all the containing loop variables are passed as parameters.
To clarify this, the NestedLoops statement you have coded is equivalent to
sub loop_over {
$start = 0 if $start == $depth;
$start++;
[$start * $length..$start * $length + $length - 1]
};
NestedLoops([
[0..$length],
(\&loop_over) x $depth,
], \&permute,);
which, in raw Perl, looks something like
for my $i (0 .. $length) {
$_ = $i;
my $list = loop_over($i);
for my $j (#$list) {
$_ = $j;
my $list = loop_over($i, $j);
for my $k (#$list) {
permute($i, $j, $k);
}
}
}
so perhaps it is clearer now that your calculation of $start is wrong? It is reevaluated several times for the innermost level before execution ascends to restart the containing loop.
Since the parameters passed to the subroutine consist of all the values of the containing loop variables, the size of #_ can be checked to see for which level of the loop to generate a range. For instance, in the code above, if #_ contains two values they are $i and $j, so the values for $k must be returned; alternatively, if there is only one parameter then it is the value of $i, and the returned value must be the range for $j. So the correct value for your $start is simply the number of elements in #_ and can be set using my $start = #_;.
Using this method the subroutine can return the range for the outermost loop as well. The code looks like this
use strict;
use warnings;
use Algorithm::Loops qw(NestedLoops);
my #a = 'a'..'o';
my $length = 5;
my $start = 0;
my $depth = 2;
NestedLoops([
(sub {
$start = #_;
[$start * $length .. $start * $length + $length - 1];
}) x ($depth + 1)
], \&permute,);
sub permute {
print map { $a[$_] } #_;
print "\n";
}

Output only last value

I have some code that reads from a file, and outputs the Fibonacchi numbers. E.g: 5 = 1, 1, 2, 3, 5
How can I make my code ONLY print out the last value?
Thanks
#!/usr/bin/perl
use strict;
my $fibFile = shift;
if (!defined($fibFile)) {
die "[*] No file specified...\n";
}
open (FILE, "<$fibFile");
my #numbers = <FILE>;
foreach my $n (#numbers) {
my $a = 1;
my $b = 1;
for (0..($n - 1)) {
print "$a\n";
($a, $b) = ($b,($a + $b));
}
print "\n";
}
close (FILE);
I suggest using a subroutine to take a chunk of code out of the loop
sub fib {
my $n = shift();
my #fib = (1, 1);
push #fib, $fib[-1] + $fib[-2] while #fib < $n;
#fib[0 .. $n-1];
}
for my $n (1 .. 5) {
printf "%d = %s\n", $n, join ', ', fib $n;
}
Do you need to recalculate the Fibonacci series for every value in the file? If not then just move the #fib array declaration outside the subroutine and the data won't need to be recalculated.
I'm sorry I didn't answer the question! To print out only the last value in the sequence, change the loop limit in your code to $n-2 and move the line print "$a\n"; outside the loop to replace the line print "\n";

How do I determine the longest similar portion of several strings?

As per the title, I'm trying to find a way to programmatically determine the longest portion of similarity between several strings.
Example:
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
Ideally, I'd get back file:///home/gms8994/Music/, because that's the longest portion that's common for all 3 strings.
Specifically, I'm looking for a Perl solution, but a solution in any language (or even pseudo-language) would suffice.
From the comments: yes, only at the beginning; but there is the possibility of having some other entry in the list, which would be ignored for this question.
Edit: I'm sorry for mistake. My pity that I overseen that using my variable inside countit(x, q{}) is big mistake. This string is evaluated inside Benchmark module and #str was empty there. This solution is not as fast as I presented. See correction below. I'm sorry again.
Perl can be fast:
use strict;
use warnings;
package LCP;
sub LCP {
return '' unless #_;
return $_[0] if #_ == 1;
my $i = 0;
my $first = shift;
my $min_length = length($first);
foreach (#_) {
$min_length = length($_) if length($_) < $min_length;
}
INDEX: foreach my $ch ( split //, $first ) {
last INDEX unless $i < $min_length;
foreach my $string (#_) {
last INDEX if substr($string, $i, 1) ne $ch;
}
}
continue { $i++ }
return substr $first, 0, $i;
}
# Roy's implementation
sub LCP2 {
return '' unless #_;
my $prefix = shift;
for (#_) {
chop $prefix while (! /^\Q$prefix\E/);
}
return $prefix;
}
1;
Test suite:
#!/usr/bin/env perl
use strict;
use warnings;
Test::LCP->runtests;
package Test::LCP;
use base 'Test::Class';
use Test::More;
use Benchmark qw(:all :hireswallclock);
sub test_use : Test(startup => 1) {
use_ok('LCP');
}
sub test_lcp : Test(6) {
is( LCP::LCP(), '', 'Without parameters' );
is( LCP::LCP('abc'), 'abc', 'One parameter' );
is( LCP::LCP( 'abc', 'xyz' ), '', 'None of common prefix' );
is( LCP::LCP( 'abcdefgh', ('abcdefgh') x 15, 'abcdxyz' ),
'abcd', 'Some common prefix' );
my #str = map { chomp; $_ } <DATA>;
is( LCP::LCP(#str),
'file:///home/gms8994/Music/', 'Test data prefix' );
is( LCP::LCP2(#str),
'file:///home/gms8994/Music/', 'Test data prefix by LCP2' );
my $t = countit( 1, sub{LCP::LCP(#str)} );
diag("LCP: ${\($t->iters)} iterations took ${\(timestr($t))}");
$t = countit( 1, sub{LCP::LCP2(#str)} );
diag("LCP2: ${\($t->iters)} iterations took ${\(timestr($t))}");
}
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
Test suite result:
1..7
ok 1 - use LCP;
ok 2 - Without parameters
ok 3 - One parameter
ok 4 - None of common prefix
ok 5 - Some common prefix
ok 6 - Test data prefix
ok 7 - Test data prefix by LCP2
# LCP: 22635 iterations took 1.09948 wallclock secs ( 1.09 usr + 0.00 sys = 1.09 CPU) # 20766.06/s (n=22635)
# LCP2: 17919 iterations took 1.06787 wallclock secs ( 1.07 usr + 0.00 sys = 1.07 CPU) # 16746.73/s (n=17919)
That means that pure Perl solution using substr is about 20% faster than Roy's solution at your test case and one prefix finding takes about 50us. There is not necessary using XS unless your data or performance expectations are bigger.
The reference given already by Brett Daniel for the Wikipedia entry on "Longest common substring problem" is very good general reference (with pseudocode) for your question as stated. However, the algorithm can be exponential. And it looks like you might actually want an algorithm for longest common prefix which is a much simpler algorithm.
Here's the one I use for longest common prefix (and a ref to original URL):
use strict; use warnings;
sub longest_common_prefix {
# longest_common_prefix( $|# ): returns $
# URLref: http://linux.seindal.dk/2005/09/09/longest-common-prefix-in-perl
# find longest common prefix of scalar list
my $prefix = shift;
for (#_) {
chop $prefix while (! /^\Q$prefix\E/);
}
return $prefix;
}
my #str = map {chomp; $_} <DATA>;
print longest_common_prefix(#ARGV), "\n";
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
If you truly want a LCSS implementation, refer to these discussions (Longest Common Substring and Longest Common Subsequence) at PerlMonks.org. Tree::Suffix would probably be the best general solution for you and implements, to my knowledge, the best algorithm. Unfortunately recent builds are broken. But, a working subroutine does exist within the discussions referenced on PerlMonks in this post by Limbic~Region (reproduced here with your data).
#URLref: http://www.perlmonks.org/?node_id=549876
#by Limbic~Region
use Algorithm::Loops 'NestedLoops';
use List::Util 'reduce';
use strict; use warnings;
sub LCS{
my #str = #_;
my #pos;
for my $i (0 .. $#str) {
my $line = $str[$i];
for (0 .. length($line) - 1) {
my $char= substr($line, $_, 1);
push #{$pos[$i]{$char}}, $_;
}
}
my $sh_str = reduce {length($a) < length($b) ? $a : $b} #str;
my %map;
CHAR:
for my $char (split //, $sh_str) {
my #loop;
for (0 .. $#pos) {
next CHAR if ! $pos[$_]{$char};
push #loop, $pos[$_]{$char};
}
my $next = NestedLoops([#loop]);
while (my #char_map = $next->()) {
my $key = join '-', #char_map;
$map{$key} = $char;
}
}
my #pile;
for my $seq (keys %map) {
push #pile, $map{$seq};
for (1 .. 2) {
my $dir = $_ % 2 ? 1 : -1;
my #offset = split /-/, $seq;
$_ += $dir for #offset;
my $next = join '-', #offset;
while (exists $map{$next}) {
$pile[-1] = $dir > 0 ?
$pile[-1] . $map{$next} : $map{$next} . $pile[-1];
$_ += $dir for #offset;
$next = join '-', #offset;
}
}
}
return reduce {length($a) > length($b) ? $a : $b} #pile;
}
my #str = map {chomp; $_} <DATA>;
print LCS(#str), "\n";
__DATA__
file:///home/gms8994/Music/t.A.T.u./
file:///home/gms8994/Music/nina%20sky/
file:///home/gms8994/Music/A%20Perfect%20Circle/
It sounds like you want the k-common substring algorithm. It is exceptionally simple to program, and a good example of dynamic programming.
My first instinct is to run a loop, taking the next character from each string, until the characters are not equal. Keep a count of what position in the string you're at and then take a substring (from any of the three strings) from 0 to the position before the characters aren't equal.
In Perl, you'll have to split up the string first into characters using something like
#array = split(//, $string);
(splitting on an empty character sets each character into its own element of the array)
Then do a loop, perhaps overall:
$n =0;
#array1 = split(//, $string1);
#array2 = split(//, $string2);
#array3 = split(//, $string3);
while($array1[$n] == $array2[$n] && $array2[$n] == $array3[$n]){
$n++;
}
$sameString = substr($string1, 0, $n); #n might have to be n-1
Or at least something along those lines. Forgive me if this doesn't work, my Perl is a little rusty.
If you google for "longest common substring" you'll get some good pointers for the general case where the sequences don't have to start at the beginning of the strings.
Eg, http://en.wikipedia.org/wiki/Longest_common_substring_problem.
Mathematica happens to have a function for this built in:
http://reference.wolfram.com/mathematica/ref/LongestCommonSubsequence.html (Note that they mean contiguous subsequence, ie, substring, which is what you want.)
If you only care about the longest common prefix then it should be much faster to just loop for i from 0 till the ith characters don't all match and return substr(s, 0, i-1).
From http://forums.macosxhints.com/showthread.php?t=33780
my #strings =
(
'file:///home/gms8994/Music/t.A.T.u./',
'file:///home/gms8994/Music/nina%20sky/',
'file:///home/gms8994/Music/A%20Perfect%20Circle/',
);
my $common_part = undef;
my $sep = chr(0); # assuming it's not used legitimately
foreach my $str ( #strings ) {
# First time through loop -- set common
# to whole
if ( !defined $common_part ) {
$common_part = $str;
next;
}
if ("$common_part$sep$str" =~ /^(.*).*$sep\1.*$/)
{
$common_part = $1;
}
}
print "Common part = $common_part\n";
Faster than above, uses perl's native binary xor function, adapted from perlmongers solution (the $+[0] didn't work for me):
sub common_suffix {
my $comm = shift #_;
while ($_ = shift #_) {
$_ = substr($_,-length($comm)) if (length($_) > length($comm));
$comm = substr($comm,-length($_)) if (length($_) < length($comm));
if (( $_ ^ $comm ) =~ /(\0*)$/) {
$comm = substr($comm, -length($1));
} else {
return undef;
}
}
return $comm;
}
sub common_prefix {
my $comm = shift #_;
while ($_ = shift #_) {
$_ = substr($_,0,length($comm)) if (length($_) > length($comm));
$comm = substr($comm,0,length($_)) if (length($_) < length($comm));
if (( $_ ^ $comm ) =~ /^(\0*)/) {
$comm = substr($comm,0,length($1));
} else {
return undef;
}
}
return $comm;
}