1package MooX::Attribute::ENV; 2 3our $VERSION = '0.04'; 4 5# this bit would be MooX::Utils but without initial _ on func name 6use strict; 7use warnings; 8use Moo (); 9use Moo::Role (); 10use Carp qw(croak); 11#use base qw(Exporter); 12#our @EXPORT = qw(override_function); 13sub _override_function { 14 my ($target, $name, $func) = @_; 15 my $orig = $target->can($name) or croak "Override '$target\::$name': not found"; 16 my $install_tracked = Moo::Role->is_role($target) ? \&Moo::Role::_install_tracked : \&Moo::_install_tracked; 17 $install_tracked->($target, $name, sub { $func->($orig, @_) }); 18} 19# end MooX::Utils; 20 21my %target2attr2envkey; 22sub import { 23 my $target = scalar caller; 24 _override_function($target, 'has', sub { 25 my ($orig, $namespec, %opts) = @_; 26 my ($other_opts, $env_opts) = _partition_opts(\%opts); 27 $orig->($namespec, %$other_opts); 28 return if !keys %$env_opts; # non env 29 for my $name (ref $namespec ? @$namespec : $namespec) { 30 my $envkey = _generate_key($name, \%opts, $target); 31 $target2attr2envkey{$target}{$name} = $envkey; 32 } 33 }); 34 _override_function($target, 'BUILDARGS', sub { 35 my ($orig, $class, @args) = @_; 36 my %args = @args == 1 && ref($args[0]) eq 'HASH' ? %{$args[0]} : @args; 37 for my $attr (keys %{ $target2attr2envkey{$target} }) { 38 next if exists $args{$attr}; 39 my $value = _lookup_env($target2attr2envkey{$target}{$attr}); 40 $args{$attr} = $value if defined $value; 41 } 42 return $class->$orig(\%args); 43 }); 44} 45 46sub _lookup_env { 47 my @env_keys = ref $_[0] eq 'ARRAY' ? @{ $_[0] } : $_[0]; 48 foreach my $envkey ( @env_keys ) { 49 return $ENV{$envkey} if exists $ENV{$envkey}; 50 return $ENV{uc $envkey} if exists $ENV{uc $envkey}; 51 } 52 undef; 53} 54 55my @KEYS = qw(env env_key env_prefix env_package_prefix); 56sub _partition_opts { 57 my ($opts) = @_; 58 my (%opts, %env_opts) = %$opts; 59 $env_opts{$_} = delete $opts{$_} for grep defined $opts{$_}, @KEYS; 60 (\%opts, \%env_opts); 61} 62 63sub _generate_key { 64 my ($attr, $opts, $target) = @_; 65 return $attr if $opts->{env}; 66 return $opts->{env_key} if $opts->{env_key}; 67 return "$opts->{env_prefix}_$attr" if $opts->{env_prefix}; 68 if ($opts->{env_package_prefix}) { 69 $target =~ s/:+/_/g; 70 return "${target}_$attr"; 71 } 72 undef; # uncoverable statement 73} 74 75=head1 NAME 76 77MooX::Attribute::ENV - Allow Moo attributes to get their values from %ENV 78 79=begin markdown 80 81# PROJECT STATUS 82 83| OS | Build status | 84|:-------:|--------------:| 85| Linux | [![Build Status](https://travis-ci.org/mohawk2/moox-attribute-env.svg?branch=master)](https://travis-ci.org/mohawk2/moox-attribute-env) | 86 87[![CPAN version](https://badge.fury.io/pl/moox-attribute-env.svg)](https://metacpan.org/pod/MooX::Attribute::ENV) [![Coverage Status](https://coveralls.io/repos/github/mohawk2/moox-attribute-env/badge.svg?branch=master)](https://coveralls.io/github/mohawk2/moox-attribute-env?branch=master) 88 89=end markdown 90 91=head1 SYNOPSIS 92 93 package MyMod; 94 use Moo; 95 use MooX::Attribute::ENV; 96 # look for $ENV{attr_val} and $ENV{ATTR_VAL} 97 has attr => ( 98 is => 'ro', 99 env_key => 'attr_val', 100 ); 101 # look for $ENV{attr_val} and $ENV{next_val}, in that order 102 has some => ( 103 is => 'ro', 104 env_key => [ 'attr_val', 'next_val' ], 105 ); 106 # looks for $ENV{otherattr} and $ENV{OTHERATTR}, then any default 107 has otherattr => ( 108 is => 'ro', 109 env => 1, 110 default => 7, 111 ); 112 # looks for $ENV{xxx_prefixattr} and $ENV{XXX_PREFIXATTR} 113 has prefixattr => ( 114 is => 'ro', 115 env_prefix => 'xxx', 116 ); 117 # looks for $ENV{MyMod_packageattr} and $ENV{MYMOD_PACKAGEATTR} 118 has packageattr => ( 119 is => 'ro', 120 env_package_prefix => 1, 121 ); 122 123 $ perl -MMyMod -E 'say MyMod->new(attr => 2)->attr' 124 # 2 125 $ ATTR_VAL=3 perl -MMyMod -E 'say MyMod->new->attr' 126 # 3 127 $ OTHERATTR=4 perl -MMyMod -E 'say MyMod->new->otherattr' 128 # 4 129 130=head1 DESCRIPTION 131 132This is a L<Moo> extension. It allows other attributes for L<Moo/has>. If 133any of these are given, then L<Moo/BUILDARGS> is wrapped so that values 134for object attributes can, if not supplied in the normal construction 135process, come from the environment. 136 137The environment will be searched for either the given case, or upper case, 138version of the names discussed below. 139 140When a prefix is mentioned, it will be prepended to the mentioned name, 141with a C<_> in between. 142 143=head1 ADDITIONAL ATTRIBUTES 144 145=head2 env 146 147Boolean. If true, the name is the attribute, no prefix. 148 149=head2 env_key 150 151String. If true, the name is the given value, no prefix. 152 153or 154 155ArrayRef. A list of names that will be checked in given order. 156 157=head2 env_prefix 158 159String. The prefix is the given value. 160 161=head2 env_package_prefix 162 163Boolean. If true, use as the prefix the current package-name, with C<::> 164replaced with C<_>. 165 166=head1 AUTHOR 167 168Ed J, porting John Napiorkowski's excellent L<MooseX::Attribute::ENV>. 169 170=head1 LICENCE 171 172The same terms as Perl itself. 173 174=cut 175 1761; 177