bitstrings calculator

[chunlou]

After reading bitwise string operator question and Detecting transpositions, and since I'm not Abigail-II, thought I could use a primitive bitstrings calculator.

Do this

print bitstrings('rkt', '^', '%$#');

and get this

__________________

  'rkt' ^ '%$#'
__________________


'r' ^ '%' = 'W'
114 ^ 37 = 87
1110010 ^ 100101 = 1010111

'k' ^ '$' = 'O'
107 ^ 36 = 79
1101011 ^ 100100 = 1001111

't' ^ '#' = 'W'
116 ^ 35 = 87
1110100 ^ 100011 = 1010111


'rkt' ^ '%$#' = 'WOW'

Doesn't handle escape characters very well though.

use strict ;
use warnings;
use Carp;

print bitstrings('*&TG', '^', 'bI##y');
print bitstrings('*&TG', '&', 'bI##y');
print bitstrings('*&TG', '|', 'bI##y');

sub bitstrings {
    my($lft,$op,$rgt) = @_;
    my $opn = "'$lft' $op '$rgt'";
    my $str = "_" x (length($opn)+5) . "\n\n";
    $str .= "  $opn\n";
    $str .= "_" x (length($opn)+5) . "\n\n\n";
    $str .= iterbit($lft,$op,$rgt);
    $str .= "\n$opn = ";
    $str .= $str =~ / = 0$/m ? "0 bits returned!" : "'" . eval($opn) .
+ "'";
    $str .= "\n\n"."- "x 20 ."\n\n\n";
    return $str;
}

sub iterbit {
    my($lft,$op,$rgt) = @_;
    my @lft = split('',$lft);
    my @rgt = split('',$rgt);
    my $str = "";
    my $idx = idx(\@lft,$op,\@rgt); 
    for my $i (0..$idx) {
        $str .= chrop($lft[$i], $op, $rgt[$i])."\n";
        $str .= decop($lft[$i], $op, $rgt[$i])."\n";
        $str .= binop($lft[$i], $op, $rgt[$i])."\n\n";
    }
    return $str;
}

sub idx {
    my($lft,$op,$rgt) = @_;
    if($op eq '&'){return $#{$lft} < $#{$rgt} ? $#{$lft} : $#{$rgt}}
    elsif($op eq '^' || $op eq '|'){return $#{$lft} > $#{$rgt} ? $#{$l
+ft} : $#{$rgt}}
    else{croak "Invalid operator: $op $! "}
}

sub chrop {
    my $lft = shift || '';
    my $op = shift;
    my $rgt = shift || '';
    my $str = "'".$lft."' $op '".$rgt."' = ";
    $lft =~ s/\\/\\\\/;
    $rgt =~ s/\\/\\\\/;
    my $opn = "'".$lft."' $op '".$rgt."'";
    my $rs = eval($opn);
    $str .= "'".($rs && ord($rs) ? $rs : '')."'";
    return $str;
}

sub decop {
    my $lft = shift || 0;
    my $op = shift;
    my $rgt = shift || 0;
    my $str = ord($lft) . " $op " . ord($rgt) . " = ";
    $str .= eval eval'"'.ord($lft).$op.ord($rgt).'"';
    return $str;
}

sub binop {
    my $str = decop(@_);
    $str =~ s/(\d+)/dec2bin($1)/mge;
    return $str;
}

sub dec2bin {
    my $bin = unpack("B32", pack("N", shift));
    $bin =~ s/^0+(?=\d)//;
    return $bin;
}

# sub bin2dec {unpack("N", pack("B32", substr("0" x 32 . shift, -32)))
+}