File Coverage

blib/lib/Constructor/Sugar.pm
Criterion Covered Total %
statement 27 27 100.0
branch 2 2 100.0
condition 2 2 100.0
subroutine 7 7 100.0
pod n/a
total 38 38 100.0


line stmt bran cond sub pod time code
1             package Constructor::Sugar;
2              
3 4     4   45215 use strictures 2;
  4         28  
  4         181  
4              
5 4     4   3682 use String::CamelCase 'decamelize';
  4         2644  
  4         284  
6 4     4   2206 use Throwable::SugarFactory::Utils '_getglob';
  4         11  
  4         1475  
7              
8             our $VERSION = '0.152700'; # VERSION
9              
10             # ABSTRACT: export constructor syntax sugar
11              
12             #
13             # This file is part of Throwable-SugarFactory
14             #
15             #
16             # Christian Walde has dedicated the work to the Commons by waiving all of his
17             # or her rights to the work worldwide under copyright law and all related or
18             # neighboring legal rights he or she had in the work, to the extent allowable by
19             # law.
20             #
21             # Works under CC0 do not require attribution. When citing the work, you should
22             # not imply endorsement by the author.
23             #
24              
25              
26             sub _export {
27 23     23   47 my ( $pkg, $func, $code ) = @_;
28 23         26 *{ _getglob $pkg, $func } = $code;
  23         64  
29 22         73 return $func;
30             }
31              
32             sub import {
33 13     13   2310 my ( undef, @specs ) = @_;
34 13         28 my $target = caller;
35 13         20 my ( @constructors, @iders );
36              
37 13         28 for my $spec ( @specs ) {
38 13         51 my ( $class, $method ) = split /->/, $spec;
39 13   100     64 $method ||= "new";
40 13         44 my $id = ( reverse split /::/, $class )[0];
41 13         47 my $ct = decamelize $id;
42 13 100       389 die "Converting '$id' into a snake_case constructor did not result in"
43             . " a different string."
44             if $ct eq $id;
45              
46 12     10   58 push @constructors, _export $target, $ct, sub { $class->$method( @_ ) };
  10         22909  
47 11     21   41 push @iders, _export $target, $id, sub { $class };
  21         14323  
48             }
49              
50 11         1949 return ( \@constructors, \@iders );
51             }
52              
53             1;
54              
55             __END__