Solution to task 2

1 files changed, 158 insertions, 0 deletions

diff --git a/challenge-095/jo-37/perl/ch-2.pl b/challenge-095/jo-37/perl/ch-2.pl
new file mode 100755
index 0000000000..693759a17d
--- /dev/null
+++ b/challenge-095/jo-37/perl/ch-2.pl
@@ -0,0 +1,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;
+}