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