| 18 | | my $pkg = shift; |
| 19 | | my $caller = (caller)[0]; |
| 20 | | |
| 21 | | return $pkg->_base_import($caller, @_) if @_ and $_[0] =~/^-\w+$/; |
| 22 | | |
| | 20 | my ($pkg, $caller) = (shift, (caller)[0]); |
| | 21 | return $pkg->_base_import($caller, @_) if @_ and $_[0] =~/^-[A-Z]\w+$/; |
| | 22 | |
| | 23 | my %opt = (prefix => 0, module_prefix => 0, debug => 0); |
| | 24 | if (@_ > 1 and ref $_[-1] eq 'HASH') { |
| | 25 | @opt{qw/prefix module_prefix debug/} = (delete @{$_[-1]}{qw/prefix module_prefix debug/}); |
| | 26 | pop @_ unless %{$_[-1]}; |
| | 27 | } |
| | 28 | |
| | 29 | my $config = do { no strict 'refs'; ${$pkg . '::Utils'} }; |
| | 30 | my ($arg, $want) = $pkg->_arrange_args(\@_, $config, $caller); |
| | 31 | foreach my $kind (keys %$want) { |
| | 32 | my ($prefix, $module_prefix, $options) = ('', '', []); |
| | 33 | Carp::croak "$pkg doesn't have such kind of functions : $kind" unless exists $config->{$kind}; |
| | 34 | my ($funcs, $local_definition, $kind_prefix) = $pkg->_func_definitions($kind, $want->{$kind}); |
| | 35 | |
| | 36 | foreach my $class (@{$config->{$kind}}) { # $class is class name or array ref |
| | 37 | my @funcs = @{$funcs->{$kind} || []}; |
| | 38 | ($class, $module_prefix, $options) = ref $class ? @$class : ($class, '', []); |
| | 39 | $prefix = $kind_prefix ? $kind_prefix : |
| | 40 | ($opt{module_prefix} and $module_prefix) ? $module_prefix : |
| | 41 | $opt{prefix} ? lc($kind) . '_': ''; |
| | 42 | |
| | 43 | my $evalerror = ''; |
| | 44 | if ($evalerror = do { local $@; eval "require $class"; $evalerror = $@ }) { |
| | 45 | $opt{debug} == 2 ? Carp::croak $evalerror : Carp::carp $evalerror; |
| | 46 | } |
| | 47 | my %rename; |
| | 48 | if (ref $options eq 'HASH') { |
| | 49 | push @funcs, @{$options->{-select}} if exists $options->{-select}; |
| | 50 | if (exists $options->{-except}) { |
| | 51 | Carp::croak "cannot use -select & -except in same time." if exists $options->{select}; |
| | 52 | my %except; |
| | 53 | @except{@{$options->{-except}}} = (); |
| | 54 | push @funcs, grep !exists $except{$_}, @{_all_funcs_in_class($class)}; |
| | 55 | } elsif (! @funcs) { |
| | 56 | @funcs = @{_all_funcs_in_class($class)}; |
| | 57 | } |
| | 58 | foreach my $o (grep !/^-/, keys %$options) { |
| | 59 | if (defined &{$class . '::' . $o}) { |
| | 60 | push @funcs , $o; |
| | 61 | $rename{$o} = $options->{$o}; |
| | 62 | } |
| | 63 | } |
| | 64 | } elsif(ref $options eq 'ARRAY') { |
| | 65 | push @funcs, @$options; |
| | 66 | } |
| | 67 | $pkg->_do_export($caller, $class, \@funcs, $local_definition, \%rename, $prefix); |
| | 68 | } |
| | 69 | } |
| | 70 | |
| | 71 | sub _all_funcs_in_class { |
| | 72 | my ($class) = @_; |
| | 73 | my %f; |
| 24 | | |
| 25 | | my $config = ${$pkg . '::Utils'}; |
| 26 | | my %want; |
| 27 | | my %opt = (prefix => 0, module_prefix => 0, debug => 0); |
| 28 | | |
| 29 | | if (@_ > 1 and ref $_[-1] eq 'HASH') { |
| 30 | | %opt = (%opt, %{pop()}); |
| 31 | | } |
| 32 | | |
| 33 | | if (@_) { |
| 34 | | if (ref $_[0] eq 'HASH') { |
| 35 | | my %_want = %{shift()}; |
| 36 | | %want = map {lc($_) => $_want{$_}} keys %_want; |
| 37 | | } elsif (lc($_[0]) eq 'all') { |
| 38 | | @want{keys %$config} = (); |
| 39 | | } else { |
| 40 | | @want{map lc $_, @_} = (); |
| 41 | | } |
| 42 | | } |
| 43 | | |
| 44 | | foreach my $kind (keys %$config) { |
| 45 | | my ($prefix, $module_prefix, $options) = ('', '', []); |
| 46 | | |
| 47 | | if (exists $want{$kind}) { |
| 48 | | foreach my $class (@{$config->{$kind}}) { |
| 49 | | ($class, $module_prefix, $options) = ref $class ? @$class : ($class, '', []); |
| 50 | | if ($opt{module_prefix} and $module_prefix) { |
| 51 | | $prefix = $module_prefix; |
| 52 | | } elsif ($opt{prefix}) { |
| 53 | | $prefix = lc($kind) . '_'; |
| 54 | | } |
| 55 | | my $evalerror; |
| 56 | | { |
| 57 | | local $@; |
| 58 | | eval "require $class"; |
| 59 | | $evalerror = $@; |
| 60 | | }; |
| 61 | | unless ($evalerror) { |
| 62 | | my $export_funcs = ref $options eq 'ARRAY' ? $options : $options->{-select}; |
| 63 | | my (%funcs, %rename); |
| 64 | | no strict 'refs'; |
| 65 | | @funcs{@{$class . '::EXPORT_OK'}, @{$class . '::EXPORT'}} = (); |
| 66 | | my @funcs = grep defined &{$class . '::' . $_}, keys %funcs; |
| 67 | | if (my $want_func = $want{$kind}) { |
| 68 | | my %w; |
| 69 | | @w{@$want_func} = (); |
| 70 | | @funcs = grep exists $w{$_}, @funcs; |
| 71 | | } elsif (@{$export_funcs || []}) { |
| 72 | | @funcs = grep defined &{$class . '::' . $_}, @$export_funcs; |
| 73 | | } |
| 74 | | if (ref $options eq 'HASH') { |
| 75 | | if (exists $options->{-except}) { |
| 76 | | Carp::croak "cannot use -select & -except in same time." if @{$export_funcs || []}; |
| 77 | | my %except; |
| 78 | | @except{@{$options->{-except}}} = (); |
| 79 | | @funcs = grep !exists $except{$_}, @funcs; |
| 80 | | } |
| 81 | | foreach my $o (grep !/^-/, keys %$options) { |
| 82 | | if (defined &{$class . '::' . $o}) { |
| 83 | | push @funcs , $o; |
| 84 | | $rename{$o} = $options->{$o}; |
| 85 | | } |
| 86 | | } |
| 87 | | } |
| 88 | | ExportTo::export_to($caller => ($prefix or %rename) |
| 89 | | ? {map {$prefix . ($rename{$_} || $_) => $class . '::' . $_} uniq @funcs} |
| 90 | | : [map $class . '::' . $_, uniq @funcs]); |
| 91 | | } elsif(defined $opt{debug}) { |
| 92 | | $opt{debug} == 2 ? Carp::croak $evalerror : Carp::carp $evalerror; |
| | 75 | @f{@{$class . '::EXPORT_OK'}, @{$class . '::EXPORT'}} = (); |
| | 76 | return [grep defined &{$class . '::' . $_}, keys %f]; |
| | 77 | } |
| | 78 | |
| | 79 | sub _do_export { |
| | 80 | my ($pkg, $caller, $class, $funcs, $local_definition, $rename, $prefix) = @_; |
| | 81 | my @export_funcs = @$funcs ? @$funcs : @{_all_funcs_in_class($class)}; |
| | 82 | if (%$local_definition) { |
| | 83 | foreach my $func (keys %$local_definition) { |
| | 84 | foreach my $def (@{$local_definition->{$func}}) { |
| | 85 | my $local_rename = delete $def->{-as} || ''; |
| | 86 | ExportTo::export_to |
| | 87 | ($caller => |
| | 88 | { |
| | 89 | ($local_rename ? $local_rename : $prefix ? $prefix . $func : $func) |
| | 90 | => %$def ? sub { no strict 'refs'; &{$class . '::' . $func}(%$def, @_) } |
| | 91 | : $class . '::' . $func |
| | 92 | }); |
| 96 | | } |
| 97 | | my $import_module = $pkg->_use_import_module; |
| 98 | | if ($import_module) { |
| | 97 | ExportTo::export_to($caller => ($prefix or %$rename) |
| | 98 | ? {map {($prefix . ($rename->{$_} || $_)) => $class . '::' . $_} @export_funcs} |
| | 99 | : [map $class . '::' . $_, uniq @export_funcs]); |
| | 100 | } |
| | 101 | } |
| | 102 | |
| | 103 | sub _insert_want_arg { |
| | 104 | my ($config, $f, $setting, $want, $arg) = @_; |
| | 105 | my $lf = lc $f; |
| | 106 | exists $config->{$lf} ? |
| | 107 | $want->{$lf} = $setting : |
| | 108 | push @$arg, $f, defined $setting ? $setting : (); |
| | 109 | } |
| | 110 | |
| | 111 | sub _arrange_args { |
| | 112 | my ($pkg, $org_args, $config, $caller) = @_; |
| | 113 | my (@arg, %want); |
| | 114 | my $import_module = $pkg->_use_import_module || ''; |
| | 115 | if (@$org_args) { |
| | 116 | @$org_args = %{$org_args->[0]} if ref $org_args->[0] eq 'HASH'; |
| | 117 | |
| | 118 | if (lc($org_args->[0]) eq 'all') { |
| | 119 | # import all functions which Util::Any proxy |
| | 120 | @want{keys %$config} = (); |
| | 121 | } elsif (lc($org_args->[0]) =~ /^[:-]all$/) { |
| | 122 | # import ALL functions |
| | 123 | @want{keys %$config} = (); |
| | 124 | if ($import_module) { |
| | 125 | if ($import_module eq 'Expoter' or |
| | 126 | $import_module eq 'Exporter::Simple' |
| | 127 | ) { |
| | 128 | no strict 'refs'; |
| | 129 | no warnings; |
| | 130 | push @arg, ':all' if ${$pkg . '::EXPORT_TAGS'}{":all"}; |
| | 131 | } elsif ($import_module eq 'Sub::Exporter') { |
| | 132 | push @arg, '-all'; |
| | 133 | } elsif ($import_module eq 'Perl6::Exporter::Attrs') { |
| | 134 | push @arg, ':ALL'; |
| | 135 | } |
| | 136 | } |
| | 137 | } elsif (any {ref $_} @$org_args) { |
| | 138 | for (my $i = 0; $i < @$org_args; $i++) { |
| | 139 | my $f = $org_args->[$i]; |
| | 140 | my $setting = $org_args->[$i + 1] ? $org_args->[++$i] : undef; |
| | 141 | _insert_want_arg($config, $f, $setting, \%want, \@arg); |
| | 142 | } |
| | 143 | } else { |
| | 144 | # export specified kinds |
| | 145 | foreach my $f (@$org_args) { |
| | 146 | _insert_want_arg($config, $f, undef, \%want, \@arg); |
| | 147 | } |
| | 148 | } |
| | 149 | } |
| | 150 | $pkg->_do_base_import($import_module, $caller, \@arg) if (@arg or !@$org_args) and $import_module; |
| | 151 | return \@arg, \%want; |
| | 152 | } |
| | 153 | |
| | 154 | sub _func_definitions { |
| | 155 | my ($pkg, $kind, $want_func_definition, $kind_prefix) = @_; |
| | 156 | my (%funcs, %local_definition); |
| | 157 | if (ref $want_func_definition eq 'HASH') { |
| | 158 | # list => {func => {-as => 'rename'}}; list => {-prefix => 'hoge_' } |
| | 159 | $kind_prefix = $want_func_definition->{-prefix} |
| | 160 | if exists $want_func_definition->{-prefix}; |
| | 161 | foreach my $f (grep !/^-/, keys %$want_func_definition) { |
| | 162 | push @{$funcs{$kind} ||= []}, $f; |
| | 163 | $local_definition{$f} = [$want_func_definition->{$f}]; |
| | 164 | } |
| | 165 | } elsif (ref $want_func_definition eq 'ARRAY') { |
| | 166 | foreach (my $i = 0; $i < @$want_func_definition; $i++) { |
| | 167 | my ($k, $v) = @{$want_func_definition}[$i, $i + 1]; |
| | 168 | if (ref $v) { |
| | 169 | $i++; |
| | 170 | if ($k eq '-prefix') { |
| | 171 | $kind_prefix = $v; |
| | 172 | } else { |
| | 173 | push @{$funcs{$kind} ||= []}, $k; |
| | 174 | push @{$local_definition{$k} ||= []}, $v; |
| | 175 | } |
| | 176 | } else { |
| | 177 | push @{$funcs{$kind} ||= []}, $k; |
| | 178 | } |
| | 179 | } |
| | 180 | @{$funcs{$kind} ||= []} = uniq @{$funcs{$kind} ||= []}; |
| | 181 | } |
| | 182 | return \%funcs, \%local_definition, $kind_prefix || ''; |
| | 183 | } |
| | 184 | |
| | 185 | sub _do_base_import { |
| | 186 | # working with other modules like Expoter |
| | 187 | my ($pkg, $import_module, $caller, $arg) = @_; |
| | 188 | my $pkg_utils; |
| | 189 | { |
| 101 | | my $pkg_utils = ${$pkg . '::Utils'}; |
| 102 | | my @arg = defined $pkg_utils ? (grep !exists $pkg_utils->{$_}, @_) |
| 103 | | : (grep !exists $Utils->{$_}, @_); |
| 104 | | if ((@_ and @arg) or !@_) { |
| 105 | | if ($import_module eq 'Perl6::Export::Attrs') { |
| 106 | | eval "package $caller; $pkg" . '->Perl6::Export::Attrs::_generic_import(@arg);'; |
| 107 | | } elsif ($import_module eq 'Exporter::Simple') { |
| 108 | | eval "package $caller; $pkg" . '->Exporter::Simple::import(@arg);'; |
| 109 | | } elsif ($import_module eq 'Exporter') { |
| 110 | | eval "package $caller; $pkg" . '->Exporter::import(@arg);'; |
| 111 | | } |
| 112 | | } |
| 113 | | } |
| | 192 | $pkg_utils = ${$pkg . '::Utils'}; |
| | 193 | } |
| | 194 | if ($import_module eq 'Perl6::Export::Attrs') { |
| | 195 | eval "package $caller; $pkg" . '->Perl6::Export::Attrs::_generic_import(@$arg);'; |
| | 196 | } elsif ($import_module eq 'Exporter::Simple') { |
| | 197 | eval "package $caller; $pkg" . '->Exporter::Simple::import(@$arg);'; |
| | 198 | } elsif ($import_module eq 'Exporter') { |
| | 199 | eval "package $caller; $pkg" . '->Exporter::import(@$arg);'; |
| | 200 | } elsif ($import_module eq 'Sub::Exporter') { |
| | 201 | no strict 'refs'; |
| | 202 | no warnings; |
| | 203 | my $import_name = ${"${pkg}::SubExporterImport"} || $Util::Any::SubExporterImport; |
| | 204 | eval "package $caller; $pkg" . '->$import_name(@$arg);'; |
| | 205 | } |
| | 206 | die $@ if $@; |
![(please configure the [header_logo] section in trac.ini)](/share/chrome/site/your_project_logo.png){kind=logo}
