1package Data::Object::Code;
2
3use 5.014;
4
5use strict;
6use warnings;
7use routines;
8
9use Carp ();
10use Scalar::Util ();
11
12use Role::Tiny::With;
13
14use parent 'Data::Object::Kind';
15
16with 'Data::Object::Role::Dumpable';
17with 'Data::Object::Role::Proxyable';
18with 'Data::Object::Role::Throwable';
19
20use overload (
21  '""'     => 'detract',
22  '~~'     => 'detract',
23  '&{}'    => 'self',
24  fallback => 1
25);
26
27our $VERSION = '2.05'; # VERSION
28
29# BUILD
30
31method new($data = sub{}) {
32  if (Scalar::Util::blessed($data)) {
33    $data = $data->detract if $data->can('detract');
34  }
35
36  unless (ref($data) eq 'CODE') {
37    Carp::confess('Instantiation Error: Not a CodeRef');
38  }
39
40  return bless $data, $self;
41}
42
43# PROXY
44
45method build_proxy($package, $method, @args) {
46  my $plugin = $self->plugin($method) or return undef;
47
48  return sub {
49    use Try::Tiny;
50
51    my $is_func = $plugin->package->can('mapping');
52
53    try {
54      my $instance = $plugin->build($is_func ? ($self, @args) : [$self, @args]);
55
56      return $instance->execute;
57    }
58    catch {
59      my $error = $_;
60      my $class = $self->class;
61      my $arity = $is_func ? 'mapping' : 'argslist';
62      my $message = ref($error) ? $error->{message} : "$error";
63      my $signature = "${class}::${method}(@{[join(', ', $plugin->package->$arity)]})";
64
65      Carp::confess("$signature: $error");
66    };
67  };
68}
69
70# PLUGIN
71
72method plugin($name, @args) {
73  my $plugin;
74
75  my $space = $self->space;
76
77  return undef if !$name;
78
79  if ($plugin = eval { $space->child('plugin')->child($name)->load }) {
80
81    return undef unless $plugin->can('argslist');
82
83    return $space->child('plugin')->child($name);
84  }
85
86  if ($plugin = $space->child('func')->child($name)->load) {
87
88    return undef unless $plugin->can('mapping');
89
90    return $space->child('func')->child($name);
91  }
92
93  return undef;
94}
95
96# METHODS
97
98method self() {
99
100  return $self;
101}
102
1031;
104
105=encoding utf8
106
107=head1 NAME
108
109Data::Object::Code
110
111=cut
112
113=head1 ABSTRACT
114
115Code Class for Perl 5
116
117=cut
118
119=head1 SYNOPSIS
120
121  package main;
122
123  use Data::Object::Code;
124
125  my $code = Data::Object::Code->new(sub { $_[0] + 1 });
126
127=cut
128
129=head1 DESCRIPTION
130
131This package provides methods for manipulating code data.
132
133=cut
134
135=head1 INHERITS
136
137This package inherits behaviors from:
138
139L<Data::Object::Kind>
140
141=cut
142
143=head1 INTEGRATES
144
145This package integrates behaviors from:
146
147L<Data::Object::Role::Dumpable>
148
149L<Data::Object::Role::Proxyable>
150
151L<Data::Object::Role::Throwable>
152
153=cut
154
155=head1 LIBRARIES
156
157This package uses type constraints from:
158
159L<Data::Object::Types>
160
161=cut
162
163=head1 METHODS
164
165This package implements the following methods:
166
167=cut
168
169=head2 call
170
171  call(Any $arg1) : Any
172
173The call method executes and returns the result of the code.
174
175=over 4
176
177=item call example #1
178
179  my $code = Data::Object::Code->new(sub { ($_[0] // 0) + 1 });
180
181  $code->call; # 1
182
183=back
184
185=over 4
186
187=item call example #2
188
189  my $code = Data::Object::Code->new(sub { ($_[0] // 0) + 1 });
190
191  $code->call(0); # 1
192
193=back
194
195=over 4
196
197=item call example #3
198
199  my $code = Data::Object::Code->new(sub { ($_[0] // 0) + 1 });
200
201  $code->call(1); # 2
202
203=back
204
205=over 4
206
207=item call example #4
208
209  my $code = Data::Object::Code->new(sub { ($_[0] // 0) + 1 });
210
211  $code->call(2); # 3
212
213=back
214
215=cut
216
217=head2 compose
218
219  compose(CodeRef $arg1, Any $arg2) : CodeLike
220
221The compose method creates a code reference which executes the first argument
222(another code reference) using the result from executing the code as it's
223argument, and returns a code reference which executes the created code
224reference passing it the remaining arguments when executed.
225
226=over 4
227
228=item compose example #1
229
230  my $code = Data::Object::Code->new(sub { [@_] });
231
232  $code->compose($code, 1,2,3);
233
234  # $code->(4,5,6); # [[1,2,3,4,5,6]]
235
236=back
237
238=cut
239
240=head2 conjoin
241
242  conjoin(CodeRef $arg1) : CodeLike
243
244The conjoin method creates a code reference which execute the code and the
245argument in a logical AND operation having the code as the lvalue and the
246argument as the rvalue.
247
248=over 4
249
250=item conjoin example #1
251
252  my $code = Data::Object::Code->new(sub { $_[0] % 2 });
253
254  $code = $code->conjoin(sub { 1 });
255
256  # $code->(0); # 0
257  # $code->(1); # 1
258  # $code->(2); # 0
259  # $code->(3); # 1
260  # $code->(4); # 0
261
262=back
263
264=cut
265
266=head2 curry
267
268  curry(CodeRef $arg1) : CodeLike
269
270The curry method returns a code reference which executes the code passing it
271the arguments and any additional parameters when executed.
272
273=over 4
274
275=item curry example #1
276
277  my $code = Data::Object::Code->new(sub { [@_] });
278
279  $code = $code->curry(1,2,3);
280
281  # $code->(4,5,6); # [1,2,3,4,5,6]
282
283=back
284
285=cut
286
287=head2 defined
288
289  defined() : Num
290
291The defined method returns true if the object represents a value that meets the
292criteria for being defined, otherwise it returns false.
293
294=over 4
295
296=item defined example #1
297
298  my $code = Data::Object::Code->new;
299
300  $code->defined; # 1
301
302=back
303
304=cut
305
306=head2 disjoin
307
308  disjoin(CodeRef $arg1) : CodeRef
309
310The disjoin method creates a code reference which execute the code and the
311argument in a logical OR operation having the code as the lvalue and the
312argument as the rvalue.
313
314=over 4
315
316=item disjoin example #1
317
318  my $code = Data::Object::Code->new(sub { $_[0] % 2 });
319
320  $code = $code->disjoin(sub { -1 });
321
322  # $code->(0); # -1
323  # $code->(1); #  1
324  # $code->(2); # -1
325  # $code->(3); #  1
326  # $code->(4); # -1
327
328=back
329
330=cut
331
332=head2 next
333
334  next(Any $arg1) : Any
335
336The next method is an alias to the call method. The naming is especially useful
337(i.e. helps with readability) when used with closure-based iterators.
338
339=over 4
340
341=item next example #1
342
343  my $code = Data::Object::Code->new(sub { $_[0] * 2 });
344
345  $code->next(72); # 144
346
347=back
348
349=cut
350
351=head2 rcurry
352
353  rcurry(Any $arg1) : CodeLike
354
355The rcurry method returns a code reference which executes the code passing it
356the any additional parameters and any arguments when executed.
357
358=over 4
359
360=item rcurry example #1
361
362  my $code = Data::Object::Code->new(sub { [@_] });
363
364  $code = $code->rcurry(1,2,3);
365
366  # $code->(4,5,6); # [4,5,6,1,2,3]
367
368=back
369
370=cut
371
372=head1 AUTHOR
373
374Al Newkirk, C<awncorp@cpan.org>
375
376=head1 LICENSE
377
378Copyright (C) 2011-2019, Al Newkirk, et al.
379
380This is free software; you can redistribute it and/or modify it under the terms
381of the The Apache License, Version 2.0, as elucidated in the L<"license
382file"|https://github.com/iamalnewkirk/data-object/blob/master/LICENSE>.
383
384=head1 PROJECT
385
386L<Wiki|https://github.com/iamalnewkirk/data-object/wiki>
387
388L<Project|https://github.com/iamalnewkirk/data-object>
389
390L<Initiatives|https://github.com/iamalnewkirk/data-object/projects>
391
392L<Milestones|https://github.com/iamalnewkirk/data-object/milestones>
393
394L<Contributing|https://github.com/iamalnewkirk/data-object/blob/master/CONTRIBUTE.md>
395
396L<Issues|https://github.com/iamalnewkirk/data-object/issues>
397
398=cut
399