3 # DCT - desktop calculator thingy
5 # simple modular reverse polish notition calculator
14 our $VERSION = "1.12.1";
16 use vars qw(@stack %val %set %alias %action %hook);
19 base => 10, # decimal; set using commands bin/oct/dec/hex/base
20 # numb => 0, # fixed scientific engineering
22 height => 4, # stack depth (lines of stack plus one)
23 width => 42, # limit value precision, stetch menu
26 %alias = (' '=>"enter", "\004"=>"quit"); # rudimentary default key bindings
30 local $_ = defined $val{i} ? $val{i} : $stack[0];
32 return defined $_ ? $_ : ();
35 "chs" => [ 1, sub { -$_[0] }], # negative
37 "drop" => [ 1, sub { defined $val{i} ? '' : () }], # drop
38 "back" => [ 1, sub { () }], # drop essentially
39 "clear" => [ 0, sub { @stack = (); undef %val; () }], # clear all
41 "swap" => [ 2, sub { reverse @_ }], # swap x<->y
44 $stackpos = 0 unless $stackpos; # initialize
45 $stackpos %= @stack; # cycle
46 $val{i} = $stack[$stackpos++];
49 "version" => [-2, sub {
50 error("Desktop Calculator Thingy $VERSION by Shiar"); ()
55 my $redraw = 2; # set flag to refresh whole screen
58 # queue a redraw of level $_[0]
59 $redraw = $_[0] if $_[0]>$redraw;
63 $_->($_[0]) for @{$hook{showerror}};
69 my ($val, $base, $baseexp) = @_;
70 return '' unless defined $val;
71 return $val if $base==10;
75 my $sign = $val<0 and $val = abs $val;
78 my $exp = $val{ex} || 0;
79 while ($int>$base**10) {
86 my $char = $int%$base;
87 $txt = ($char<10 ? $char : chr($char+55)) . $txt;
90 $txt .= '.' if $frac>0;
91 for (my $i = 0; length $txt<$set{width}-2 && $frac>0; $i++) {
95 $txt .= $char<10 ? $char : chr($char+55);
98 $txt = "-".$txt if $sign;
99 $txt .= 'e'.showval($exp, $base) if $exp;
108 $_->() for @{$hook{refresh}};
110 $_->() for @{$hook{showstack}};
112 } # do necessary redrawing
115 my $entry = showval($val{i}, $set{base}, $val{ex});
116 $entry .= $_->() for @{$hook{postentry}};
117 $entry .= $val{alpha} if exists $val{alpha};
118 $_->($entry) for @{$hook{showentry}};
124 $_ = exists $alias{$key} ? $alias{$key} : $key; # command (alias maps keys to commands)
125 $_ eq "enter" and exists $val{alpha} and $_ = delete $val{alpha}; # use manual command
127 for my $cmd (@{$hook{precmd}}) {
128 $cmd->() and return; # command was handled by function if returns true
131 exit if $_ eq "quit"; # break out of loop
133 if ($_ eq "refresh") {
137 elsif (/^\033?[A-Z]$/ or exists $val{alpha}) {
138 if (defined $val{i}) {
139 unshift @stack, $val{i};
142 } # enter present value
145 $val{alpha} = substr $val{alpha}, 0, -1 or delete $val{alpha};
147 elsif ($_ eq "drop") {
151 $val{alpha} .= $key =~ /^\033(.)/ ? uc $1 : lc $key;
153 } # manual command entry
155 elsif (/^[\da-f]$/) {
156 m/^[a-z]$/ and $_ = ord($_)-87; # digit>9
157 $val{i} = 0 unless defined $val{i};
158 $_ = -$_ if $val{i}<0; # substract from negative value
159 $val{i} = ($val{frac} and $val{frac} *= 10)
160 ? $val{i}+$_/$val{frac} # add digit to fraction
161 : defined $val{ex} ? $val{ex} = $val{ex}*$set{base}+$_ # digit to exponent
162 : $val{i}*$set{base}+$_; # add digit to integer part
165 $val{i} = 0 unless defined $val{i};
168 elsif ($_ eq "eex") {
169 $val{i} = 1 unless defined $val{i};
172 elsif ($_ eq "chs" and defined $val{i}) {
175 elsif ($_ eq "back" and defined $val{i}) {
176 $val{i} = ($val{frac} and $val{frac} = int $val{frac}/10)
177 ? int($val{i}*$val{frac})/$val{frac} # backspace fraction digit
178 : int $val{i}/$set{base} # backspace digit in integer part
181 elsif (exists $action{$_}) {
182 my ($action, $type, $cmd) = ($_, @{$action{$_}});
183 unshift @stack, $action{enter}[1]->() if $type>0 and defined $val{i}; # auto enter
185 if ($type>0 and $type>@stack) {
186 error("insufficient stack arguments for operation");
188 } # insufficient arguments
190 $_->($type, $action) for @{$hook{preaction}};
191 # put return value(s) of stack-modifying operations (type>=0) at stack
192 $type<0 ? $cmd->() : unshift @stack, $cmd->(splice @stack, 0, $type);
193 $_->($type, $action) for @{$hook{postaction}};
195 redraw(1) if $type>=-1; # redraw stack
200 "unrecognised command: " # show string or character codes
201 . (m/^\w*$/ ? qq{"$_"} : join ' ', map ord, split //, $_)
210 $modskip{substr $_, 1}++ for grep /^-/, @ARGV;
211 opendir my $moddir, ".";
212 for my $module (sort readdir $moddir) { # glob "*.pm"
213 $module =~ /^\d{2}_([a-z0-9-]+)(?:_(\w+))?\.pm$/ or next;
214 # files named 00_class_name.pm; ($1, $2) = (class, name)
215 next if exists $modskip{$1} or $2 && exists $modskip{$2};
216 next if defined $modules{$1}; # no such module already loaded
217 defined ($_ = do $module) # return value means no errors
218 ? (ref $_ and $modules{$1} = $_, $modules{$1}{name} = $2 || "")
219 : print STDERR $@, "error loading $module\n\n";
222 } # find external modules
224 printf STDERR "DCT %s by Shiar (%s)\n", $VERSION, join "; ",
225 map join(" ", grep $_, $_, $modules{$_}{name}, $modules{$_}{version}),
229 $_->() for @{$hook{init}};