1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
|
#!/usr/bin/perl -s
use v5.16;
use Test2::V0;
use warnings FATAL => 'all';
use experimental 'signatures';
our ($tests, $examples, $verbose);
$Stack::verbose = 1 if $verbose;
run_tests() if $tests; # does not return
# prepare example run
unshift @ARGV, 'ch-2-ex.pl' if $examples;
say(<<EOS), exit unless @ARGV;
usage: $0 [-tests] [-examples] [-verbose] [--] [file]
-tests
run some tests
-examples
run example
-verbose
show stack operations
file
run commands from file
(use 'ch-2-ex.pl' to run the example)
EOS
### Process input script
do "$ARGV[0]";
die $@ if $@;
die "$ARGV[0]: ", $! if $!;
### Implementation
# Taking this task as an opportunity to practice AUTOLOADing methods and
# overriding "can". Though this is highly flexible and extensible it
# comes with some overhead.
# Using a blessed array ref as Stack object.
package Stack;
use Carp 'croak';
use List::Util;
our ($verbose, @stack, $arg);
BEGIN {
# The %method hash maps the name of a method to a subref providing
# its "base" functionality. The subs will be called with the
# variables @stack and $arg set to the current stack and the
# optional method argument respective.
my %method = (
push => sub {push @stack, $arg}, # returns new stack size
pop => sub {pop @stack}, # returns removed element
top => sub {$stack[$#stack]},
min => sub {List::Util::min @stack},
max => sub {List::Util::max @stack},
size => sub {@stack}, # returns current stack size
clear => sub {splice @stack}, # returns top element
);
# Wrapping the "base" functionality in an object. For this purpose
# override "can" to return an existing or generated $method. Must
# be available at compile time.
sub can ($self, $method) {
# Retrieve parent methods as well as the defined methods
# of this class.
my $can = $self->SUPER::can($method);
return $can if $can;
my $call = $method{$method};
return unless $call;
# Generate a method to perform the configured call.
sub ($self, $val=undef) {
# Provide variables and call method sub.
local $arg = $val;
local *stack = $self; # make @$self available as @stack
my $result = &$call();
# Benefit from method generation: single code for every
# method.
no warnings 'uninitialized';
say "$method($val): $result" if $verbose;
$result;
}
}
}
# Autoload dynamic methods
our $AUTOLOAD;
sub AUTOLOAD ($self, @args) {
my $called = $AUTOLOAD =~ s/.*:://r;
my $method = $self->can($called);
croak qq{Can't locate object method "$called" via package "}
. __PACKAGE__ . '"' unless $method;
$self->$method(@args);
}
# Creates an empty Stack.
sub new ($class) {
bless [], $class;
}
### Tests
package main;
sub run_tests {
my $stack = Stack->new;
is $stack->size, 0, 'empty';
is $stack->min, U(), 'no min from empty stack';
is $stack->max, U(), 'no max from empty stack';
is $stack->top, U(), 'no top from empty stack';
is $stack->pop, U(), 'no pop from empty stack';
is $stack->push(2), 1, '1 element on stack';
is $stack->size, 1, 'after first push';
is $stack->push(-1), 2, '2 elements on stack';
is $stack->size, 2, 'after second push';
is $stack->push(0), 3, '3 elements on stack';
is $stack->size, 3, 'after third push';
is $stack->pop, 0, 'pop';
is $stack->size, 2, 'after pop';
is $stack->top, -1, 'top';
is $stack->push(0), 3, '3 elements on stack';
is $stack->size, 3, 'after fourth push';
is $stack->min, -1, 'minimum';
is $stack->max, 2, 'maximum';
is $stack->clear, 0, 'clear stack';
is $stack->size, 0, 'empty stack';
SKIP: {
$stack->push(-1);
ok my $can = $stack->can('can'), 'inquires parent for "can"'
or skip 'cannot can';
ok my $pop = $stack->$can('pop'), 'retrieve "pop" ref'
or skip 'cannot pop';
is $stack->$pop, -1, 'invoke "pop" ref';
}
like dies {$stack->foo}, qr/Can't locate object method/, 'method missing';
done_testing;
exit;
}
|
