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   103374 use strictures 2;
  4         33  
  4         162  
4              
5 4     4   3159 use String::CamelCase 'decamelize';
  4         2687  
  4         328  
6 4     4   1812 use Throwable::SugarFactory::Utils '_getglob';
  4         12  
  4         1470  
7              
8             our $VERSION = '0.213360'; # 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   71 my ( $pkg, $func, $code ) = @_;
28 23         62 *{ _getglob $pkg, $func } = $code;
  23         66  
29 22         79 return $func;
30             }
31              
32             sub import {
33 13     13   2831 my ( undef, @specs ) = @_;
34 13         38 my $target = caller;
35 13         28 my ( @constructors, @iders );
36              
37 13         36 for my $spec ( @specs ) {
38 13         54 my ( $class, $method ) = split /->/, $spec;
39 13   100     70 $method ||= "new";
40 13         44 my $id = ( reverse split /::/, $class )[0];
41 13         48 my $ct = decamelize $id;
42 13 100       509 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   75 push @constructors, _export $target, $ct, sub { $class->$method( @_ ) };
  10         31252  
47 11     21   49 push @iders, _export $target, $id, sub { $class };
  21         18369  
48             }
49              
50 11         2048 return ( \@constructors, \@iders );
51             }
52              
53             1;
54              
55             __END__