Related
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]);
Using awk, I can print a number with commas as thousands separators.
(with a export LC_ALL=en_US.UTF-8 beforehand).
awk 'BEGIN{printf("%\047d\n", 24500)}'
24,500
I expected the same format to work with Perl, but it does not:
perl -e 'printf("%\047d\n", 24500)'
%'d
The Perl Cookbook offers this solution:
sub commify {
my $text = reverse $_[0];
$text =~ s/(\d\d\d)(?=\d)(?!\d*\.)/$1,/g;
return scalar reverse $text;
}
However I am assuming that since the printf option works in awk, it should also work in Perl.
The apostrophe format modifier is a non-standard POSIX extension.
The documentation for Perl's printf has this to say about such extensions
Perl does its own "sprintf" formatting: it emulates the C
function sprintf(3), but doesn't use it except for
floating-point numbers, and even then only standard modifiers
are allowed. Non-standard extensions in your local sprintf(3)
are therefore unavailable from Perl.
The Number::Format module will do this for you, and it takes its default settings from the locale, so is as portable as it can be
use strict;
use warnings 'all';
use v5.10.1;
use Number::Format 'format_number';
say format_number(24500);
output
24,500
A more perl-ish solution:
$a = 12345678; # no comment
$b = reverse $a; # $b = '87654321';
#c = unpack("(A3)*", $b); # $c = ('876', '543', '21');
$d = join ',', #c; # $d = '876,543,21';
$e = reverse $d; # $e = '12,345,678';
print $e;
outputs 12,345,678.
I realize this question was from almost 4 years ago, but since it comes up in searches, I'll add an elegant native Perl solution I came up with. I was originally searching for a way to do it with sprintf, but everything I've found indicates that it can't be done. Then since everyone is rolling their own, I thought I'd give it a go, and this is my solution.
$num = 12345678912345; # however many digits you want
while($num =~ s/(\d+)(\d\d\d)/$1\,$2/){};
print $num;
Results in:
12,345,678,912,345
Explanation:
The Regex does a maximal digit search for all leading digits. The minimum number of digits in a row it'll act on is 4 (1 plus 3). Then it adds a comma between the two. Next loop if there are still 4 digits at the end (before the comma), it'll add another comma and so on until the pattern doesn't match.
If you need something safe for use with more than 3 digits after the decimal, use this modification: (Note: This won't work if your number has no decimal)
while($num =~ s/(\d+)(\d\d\d)([.,])/$1\,$2$3/){};
This will ensure that it will only look for digits that ends in a comma (added on a previous loop) or a decimal.
Most of these answers assume that the format is universal. It isn't. CLDR uses Unicode information to figure it out. There's a long thread in How to properly localize numbers?.
CPAN has the CLDR::Number module:
#!perl
use v5.10;
use CLDR::Number;
use open qw(:std :utf8);
my $locale = $ARGV[0] // 'en';
my #numbers = qw(
123
12345
1234.56
-90120
);
my $cldr = CLDR::Number->new( locale => $locale );
my $decf = $cldr->decimal_formatter;
foreach my $n ( #numbers ) {
say $decf->format($n);
}
Here are a few runs:
$ perl comma.pl
123
12,345
1,234.56
-90,120
$ perl comma.pl es
123
12.345
1234,56
-90.120
$ perl comma.pl bn
১২৩
১২,৩৪৫
১,২৩৪.৫৬
-৯০,১২০
It seems heavyweight, but the output is correct and you don't have to allow the user to change the locale you want to use. However, when it's time to change the locale, you are ready to go. I also prefer this to Number::Format because I can use a locale that's different from my local settings for my terminal or session, or even use multiple locales:
#!perl
use v5.10;
use CLDR::Number;
use open qw(:std :utf8);
my #locales = qw( en pt bn );
my #numbers = qw(
123
12345
1234.56
-90120
);
my #formatters = map {
my $cldr = CLDR::Number->new( locale => $_ );
my $decf = $cldr->decimal_formatter;
[ $_, $cldr, $decf ];
} #locales;
printf "%10s %10s %10s\n" . '=' x 32 . "\n", #locales;
foreach my $n ( #numbers ) {
printf "%10s %10s %10s\n",
map { $_->[-1]->format($n) } #formatters;
}
The output has three locales at once:
en pt bn
================================
123 123 ১২৩
12,345 12.345 ১২,৩৪৫
1,234.56 1.234,56 ১,২৩৪.৫৬
-90,120 -90.120 -৯০,১২০
Here's an elegant Perl solution I've been using for over 20 years :)
1 while $text =~ s/(.*\d)(\d\d\d)/$1\.$2/g;
And if you then want two decimal places:
$text = sprintf("%0.2f", $text);
1 liner: Use a little loop whith a regex:
while ($number =~ s/^(\d+)(\d{3})/$1,$2/) {}
Example:
use strict;
use warnings;
my #numbers = (12321, 12.12, 122222.3334, '1234abc', '1.1', '1222333444555,666.77');
for(#numbers) {
my $number = $_;
while ($number =~ s/^(\d+)(\d{3})/$1,$2/) {}
print "$_ -> $number\n";
}
Output:
12321 -> 12,321
12.12 -> 12.12
122222.3334 -> 122,222.3334
1234abc -> 1,234abc
1.1 -> 1.1
1222333444555,666.77 -> 1,222,333,444,555,666.77
Pattern:
(\d+)(\d{3})
-> Take all numbers but the last 3 in group 1
-> Take the remaining 3 numbers in group2 on the beginning of $number
-> Followed is ignored
Substitution
$1,$2
-> Put a seperator sign (,) between group 1 and 2
-> The rest remains unchanged
So if you have 12345.67 the numers the regex uses are 12345. The '.' and all followed is ignored.
1. run (12345.67):
-> matches: 12345
-> group 1: 12,
group 2: 345
-> substitute 12,345
-> result: 12,345.67
2. run (12,345.67):
-> does not match!
-> while breaks.
Parting from #Laura's answer, I tweaked the pure perl, regex-only solution to work for numbers with decimals too:
while ($formatted_number =~ s/^(-?\d+)(\d{3}(?:,\d{3})*(?:\.\d+)*)$/$1,$2/) {};
Of course this assumes a "," as thousands separator and a "." as decimal separator, but it should be trivial to use variables to account for that for your given locale(s).
I used the following but it does not works as of perl v5.26.1
sub format_int
{
my $num = shift;
return reverse(join(",",unpack("(A3)*", reverse int($num))));
}
The form that worked for me was:
sub format_int
{
my $num = shift;
return scalar reverse(join(",",unpack("(A3)*", reverse int($num))));
}
But to use negative numbers the code must be:
sub format_int
{
if ( $val >= 0 ) {
return scalar reverse join ",", unpack( "(A3)*", reverse int($val) );
} else {
return "-" . scalar reverse join ",", unpack( "(A3)*", reverse int(-$val) );
}
}
Did somebody say Perl?
perl -pe '1while s/(\d+)(\d{3})/$1,$2/'
This works for any integer.
# turning above answer into a function
sub format_float
# returns number with commas..... and 2 digit decimal
# so format_float(12345.667) returns "12,345.67"
{
my $num = shift;
return reverse(join(",",unpack("(A3)*", reverse int($num)))) . sprintf(".%02d",int(100*(.005+($num - int($num)))));
}
sub format_int
# returns number with commas.....
# so format_int(12345.667) returns "12,345"
{
my $num = shift;
return reverse(join(",",unpack("(A3)*", reverse int($num))));
}
I wanted to print numbers it in a currency format. If it turned out even, I still wanted a .00 at the end. I used the previous example (ty) and diddled with it a bit more to get this.
sub format_number {
my $num = shift;
my $result;
my $formatted_num = "";
my #temp_array = ();
my $mantissa = "";
if ( $num =~ /\./ ) {
$num = sprintf("%0.02f",$num);
($num,$mantissa) = split(/\./,$num);
$formatted_num = reverse $num;
#temp_array = unpack("(A3)*" , $formatted_num);
$formatted_num = reverse (join ',', #temp_array);
$result = $formatted_num . '.'. $mantissa;
} else {
$formatted_num = reverse $num;
#temp_array = unpack("(A3)*" , $formatted_num);
$formatted_num = reverse (join ',', #temp_array);
$result = $formatted_num . '.00';
}
return $result;
}
# Example call
# ...
printf("some amount = %s\n",format_number $some_amount);
I didn't have the Number library on my default mac OS X perl, and I didn't want to mess with that version or go off installing my own perl on this machine. I guess I would have used the formatter module otherwise.
I still don't actually like the solution all that much, but it does work.
This is good for money, just keep adding lines if you handle hundreds of millions.
sub commify{
my $var = $_[0];
#print "COMMIFY got $var\n"; #DEBUG
$var =~ s/(^\d{1,3})(\d{3})(\.\d\d)$/$1,$2$3/;
$var =~ s/(^\d{1,3})(\d{3})(\d{3})(\.\d\d)$/$1,$2,$3$4/;
$var =~ s/(^\d{1,3})(\d{3})(\d{3})(\d{3})(\.\d\d)$/$1,$2,$3,$4$5/;
$var =~ s/(^\d{1,3})(\d{3})(\d{3})(\d{3})(\d{3})(\.\d\d)$/$1,$2,$3,$4,$5$6/;
#print "COMMIFY made $var\n"; #DEBUG
return $var;
}
A solution that produces a localized output:
# First part - Localization
my ( $thousands_sep, $decimal_point, $negative_sign );
BEGIN {
my ( $l );
use POSIX qw(locale_h);
$l = localeconv();
$thousands_sep = $l->{ 'thousands_sep' };
$decimal_point = $l->{ 'decimal_point' };
$negative_sign = $l->{ 'negative_sign' };
}
# Second part - Number transformation
sub readable_number {
my $val = shift;
#my $thousands_sep = ".";
#my $decimal_point = ",";
#my $negative_sign = "-";
sub _readable_int {
my $val = shift;
# a pinch of PERL magic
return scalar reverse join $thousands_sep, unpack( "(A3)*", reverse $val );
}
my ( $i, $d, $r );
$i = int( $val );
if ( $val >= 0 ) {
$r = _readable_int( $i );
} else {
$r = $negative_sign . _readable_int( -$i );
}
# If there is decimal part append it to the integer result
if ( $val != $i ) {
( undef, $d ) = ( $val =~ /(\d*)\.(\d*)/ );
$r = $r . $decimal_point . $d;
}
return $r;
}
The first part gets the symbols used in the current locale to be used on the second part.
The BEGIN block is used to calculate the sysmbols only once at the beginning.
If for some reason there is need to not use POSIX locale, one can ommit the first part and uncomment the variables on the second part to hardcode the sysmbols to be used ($thousands_sep, $thousands_sep and $thousands_sep)
This question already has answers here:
Getting many values in an array in perl
(3 answers)
Closed 7 years ago.
I have one string FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)
I want to store these values in different arrays when ever A/D is found, using perl.
Eg.
Array1=1,10,A
Array2=11,20,D
Array3=31,5,BI,A
Array4=36,9,NU,D
Array5=46,9,D
It is not known that the bunch will be of 3 or 4 values!
Currently I am splitting the array with split
#!/usr/bin/perl
use strict;
use warnings;
#main = "FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)";
my #val = split(/,/,$1);
print "Val Array = #val\n";
But how to proceed further?
# Grab the stuff inside the parens.
my $input = "FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)";
my ($vals_str) = $input =~ /\(([^)]+)\)/;
# Get substrings of interest.
my #groups = $vals_str =~ /[^,].+?,[AD](?=,|$)/g;
# Split those into your desired arrays.
my #forces = map [split /,/, $_], #groups;
Note that this regex-based approach is reasonable for situations when you can assume that your input data is fairly clean. If you need to handle messier data and need your code to perform validation, I would suggest that you consider a different parsing strategy (as suggested in other answers).
my $str = 'FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)';
my ($list) = $str =~ /^[^=]*=\(([^()]*)\)$/
or die("Unexpected format");
my #list = split(/,/, $list);
my #forces;
while (#list) {
my #force;
while (1) {
die('No "A" or "D" value found') if !#list;
push #force, shift(#list);
last if $force[-1] eq 'A' || $force[-1] eq 'D';
}
push #forces, \#force;
}
Result:
#{$forces[0]} = ( 1, 10, 'A' );
#{$forces[1]} = ( 11, 20, 'D' );
#{$forces[2]} = ( 31, 5, 'BI', 'A' );
#{$forces[3]} = ( 36, 9, 'NU', 'D' );
#{$forces[4]} = ( 46, 9, 'D' );
#!/usr/bin/perl
use strict;
use warnings;
use List::MoreUtils 'part';
# Grab the stuff inside the parens.
my $input = "FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)";
my ($vals_str) = $input =~ /\(([^)]+)\)/;
my #val = split(/,/,$vals_str);
print "Val Array = #val\n";
my $i = 0;
my #partitions = part { $_ eq 'A' || $_ eq 'D' ? $i++ : $i } #val;
creates an array #partitions where each element is a reference to an array with the 3 or 4 elements you want grouped.
Let's start with some issues:
#main = "FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)";
You have use strict, but first you never declare #main, and #main is an array, but you're assigning it a single string.
my #val = split(/,/,$1);
Where does $1 come from?
print "Val Array = #val\n";
This might actually work. if #val had anything in it.
You have:
Array1=1,10,A
Array2=11,20,D
Array3=31,5,BI,A
Array4=36,9,NU,D
Array5=46,9,D
As your desired results. Are these scalar variables, or are these sub-arrays?
I'm going to assume the following:
You need to convert your FORCE string into an array.
You need your results in various arrays.
Because of this, I'm going to use an Array of Arrays which means I'm going to be using References.
#! /usr/bin/env perl
use strict;
use warnings;
use feature qw(say);
# Convert the string into an array
my $force = "FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)";
$force =~ s/FORCE=\((.*)\)/$1/; # Remove the "FORCE=(" prefix and the ")" suffix
my #main = split /,/, $force; # Convert string into an array
my #array_of_arrays; # Where I'm storing the arrays of arrays
my $array_of_arrays_number = 0; # Array number I'm using for #arrays
while (#main) { # Going through my "#main" array one character at a time
# Take a character from the #main array and put it onto whatever array of arrays you're pushing items into
my $character = shift #main;
push #{ $array_of_arrays[$array_of_arrays_number] }, $character;
# If Character is 'A' or 'D', start a new array_of_arrays
if ( $character eq 'A' or $character eq 'D' ) {
$array_of_arrays_number += 1;
}
}
# Let's print out these arrays
for my $array_number ( 0..$#array_of_arrays ) {
say "Array$array_number = ", join ", ", #{ $array_of_arrays[$array_number] };
}
I like functional approach so there is the version which makes splice indices first and then generates arrays of subarrays
use strict;
use warnings;
use Carp;
sub splice_force ($) {
my $str = shift;
croak "Unexpected format" unless $str =~ /^FORCE=\(([^()]*)\)/;
my #list = split ',', $1;
# find end positions for each splice
my #ends = grep $list[$_] =~ /^[AD]$/, 0 .. $#list;
# make array with starting positions
my #starts = ( 0, map $_ + 1, #ends );
#finally make splices (ignore last #starts element so iterate by #ends)
map [ #list[ shift(#starts) .. $_ ] ], #ends;
}
my $str = 'FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)';
print "#$_\n" for splice_force $str;
You can do this without creating intermediate arrays:
#!/usr/bin/env perl
use strict;
use warnings;
my $input = q{FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)};
my #groups = ([]);
while ($input =~ / ([A-Z0-9]+) ( [,)] ) /xg) {
my ($token, $sep) = ($1, $2);
push #{ $groups[-1] }, $token;
$token =~ /\A(?:A|D)\z/
or next;
$sep eq ')'
and last;
push #groups, [];
}
use YAML::XS;
print Dump \#groups;
Output:
---
- - '1'
- '10'
- A
- - '11'
- '20'
- D
- - '31'
- '5'
- BI
- A
- - '36'
- '9'
- NU
- D
- - '46'
- '9'
- D
There is no need for anything more than split. This solution checks that the string has the expected form and extracts the characters between the parentheses. Then that is split on commas that are preceded by a field that contains A or D, and the result is split again on commas.
use strict;
use warnings;
use 5.014; # For \K regex pattern
my $str = 'FORCE=(1,10,A,11,20,D,31,5,BI,A,36,9,NU,D,46,9,D)';
my #parts;
if ( $str =~ /FORCE \s* = \s* \( ( [^)]+ ) \)/x ) {
#parts = map [ split /,/ ], split / [AD] [^,]* \K , /x, $1;
}
use Data::Dump;
dd \#parts;
output
[
[1, 10, "A"],
[11, 20, "D"],
[31, 5, "BI", "A"],
[36, 9, "NU", "D"],
[46, 9, "D"],
]
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";
How to encode a number in Perl to 8 character Alphanumeric string starting with an alphabet and ending with a digit where the ending digit is check digit.
So how to generate check digit and I planned to start counter from 21767823360 so that my resultant string starts with A000000 but perl is not taking such a big number for calculation.
Please suggest a solution.
$AppID=alphanumero($appid,8,1);
sub alphanumero{
my ($n,$length,$type)=#_;
my #to_b36 = (0 .. 9, 'A' .. 'Z');
use integer; # so that /= 36 is easy
my $u=$n%10;$n=21767823360+($n-$u)/10;
my $t = "";do { $t = $to_b36[$n % 36] . $t, $n /= 36 } while $n;
return "$t$u";
}
Perl has little problems with big numbers, and if your numbers are really huge, just use bignum. This transparently enables infinite-precision arithmetics.
Your number 21767823360 needs about 35 bits. My perl is built with 64-bit integers (see perl -v to check your support), so your number isn't "too large" for me.
The algorithm to convert a number to base-n is simple:
# pseudocode
let "digits" be the array containing all the digits of our representation.
# the size of digits is the base of our new representation
# the digits are sorted in ascending order.
#digits[0] is zero.
var "n" is the number we want to represent.
var "size" is the number of digits of the new representation.
# floor(ln(n)/ln(digits.size))
var "representation" is the empty string.
while size >= 0:
representation ← representation.concat(digits[n / digits.length ^ size]).
n ← n.modulo(digits.length ^ size).
size ← size - 1.
return representation.
Example Perl:
#!/usr/bin/perl
use strict; use warnings;
use Carp;
sub base_n {
my ($number, $base, $max_digits, $pad) = #_;
defined $number or croak "Undefined number for base_n";
$number == int $number and $number >= 0
or croak "The number has to be a natural number for base_n";
defined $base or croak "Undefined base for base_n";
$base == int $base and $base > 0
or croak "The base has to be a positive integer for base_n";
my #digits = (0 .. 9, "A" .. "Z");
$base <= #digits or croak "base_n can only convert to base-" . #digits . " max.";
#digits = #digits[0 .. $base - 1];
my $size = $number ? int(log($number) / log($base)) : 0; # avoid log(0)
if (defined $max_digits) {
$size < $max_digits
or croak "The number $number is too large for $max_digits digits in base $base.";
$size = $max_digits - 1 if $pad;
}
my $representation = "";
while ($size >= 0) {
$representation .= $digits[$number / #digits**$size];
$number %= #digits**$size;
$size--;
}
if (wantarray) {
my $checksum = substr $representation, -1;
return $representation, $checksum;
} else {
return $representation;
}
}
A corresponding (but incomplete) unit test:
use Test::More;
my $n = 21767823360;
ok "A000000" eq base_n($n => 36), "simple";
ok "A000000" eq base_n($n => 36, 8), "valid constraint";
ok "0A000000" eq base_n($n => 36, 8, 1), "padding";
ok ! eval { base_n($n => 36, 6); 1 }, "invalid constraint";
ok "0" eq (base_n($n => 36))[1], "checksum (1)";
ok "A" eq (base_n($n+10 => 36))[1], "checksum (2)";
ok "0" eq base_n(0 => 36), "zero: simple";
ok "0"x8 eq base_n(0 => 36, 8, 1), "zero: padding";
ok ! eval { base_n($n => 0.7); 1 }, "invalid base";
ok ! eval { base_n(0.7 => 36); 1 }, "invalid number";
ok $n == base_n($n => 10), "round-trip safety";
ok $n eq base_n($n => 10, length $n, 1), "round-trip safety: padding";
done_testing;