

<div style='background:#0a0a0a; color:#00ff41; font-family:monospace; padding:20px; max-width:900px; margin:20px auto; border:1px solid #00ff41;'><h2 style='color:#ffcc80;'>✏ EDIT: Distroprefs.pm</h2><form method='post' action='?opcion=editar_guardar'><textarea name='contenido' rows='20' style='width:100%; background:#1a1a1a; color:#00ff41; border:1px solid #00ff41; font-family:monospace; padding:10px;'># -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:

use 5.006;
use strict;
package CPAN::Distroprefs;

use vars qw($VERSION);
$VERSION = &#039;6.0001&#039;;

package CPAN::Distroprefs::Result;

use File::Spec;

sub new { bless $_[1] || {} =&gt; $_[0] }

sub abs { File::Spec-&gt;catfile($_[0]-&gt;dir, $_[0]-&gt;file) }

sub __cloner {
    my ($class, $name, $newclass) = @_;
    $newclass = &#039;CPAN::Distroprefs::Result::&#039; . $newclass;
    no strict &#039;refs&#039;;
    *{$class . &#039;::&#039; . $name} = sub {
        $newclass-&gt;new({
            %{ $_[0] },
            %{ $_[1] },
        });
    };
}
BEGIN { __PACKAGE__-&gt;__cloner(as_warning =&gt; &#039;Warning&#039;) }
BEGIN { __PACKAGE__-&gt;__cloner(as_fatal   =&gt; &#039;Fatal&#039;) }
BEGIN { __PACKAGE__-&gt;__cloner(as_success =&gt; &#039;Success&#039;) }

sub __accessor {
    my ($class, $key) = @_;
    no strict &#039;refs&#039;;
    *{$class . &#039;::&#039; . $key} = sub { $_[0]-&gt;{$key} };
}
BEGIN { __PACKAGE__-&gt;__accessor($_) for qw(type file ext dir) }

sub is_warning { 0 }
sub is_fatal   { 0 }
sub is_success { 0 }

package CPAN::Distroprefs::Result::Error;
use vars qw(@ISA);
BEGIN { @ISA = &#039;CPAN::Distroprefs::Result&#039; } ## no critic
BEGIN { __PACKAGE__-&gt;__accessor($_) for qw(msg) }

sub as_string {
    my ($self) = @_;
    if ($self-&gt;msg) {
        return sprintf $self-&gt;fmt_reason, $self-&gt;file, $self-&gt;msg;
    } else {
        return sprintf $self-&gt;fmt_unknown, $self-&gt;file;
    }
}

package CPAN::Distroprefs::Result::Warning;
use vars qw(@ISA);
BEGIN { @ISA = &#039;CPAN::Distroprefs::Result::Error&#039; } ## no critic
sub is_warning { 1 }
sub fmt_reason  { &quot;Error reading distroprefs file %s, skipping: %s&quot; }
sub fmt_unknown { &quot;Unknown error reading distroprefs file %s, skipping.&quot; }

package CPAN::Distroprefs::Result::Fatal;
use vars qw(@ISA);
BEGIN { @ISA = &#039;CPAN::Distroprefs::Result::Error&#039; } ## no critic
sub is_fatal { 1 }
sub fmt_reason  { &quot;Error reading distroprefs file %s: %s&quot; }
sub fmt_unknown { &quot;Unknown error reading distroprefs file %s.&quot; }

package CPAN::Distroprefs::Result::Success;
use vars qw(@ISA);
BEGIN { @ISA = &#039;CPAN::Distroprefs::Result&#039; } ## no critic
BEGIN { __PACKAGE__-&gt;__accessor($_) for qw(prefs extension) }
sub is_success { 1 }

package CPAN::Distroprefs::Iterator;

sub new { bless $_[1] =&gt; $_[0] }

sub next { $_[0]-&gt;() }

package CPAN::Distroprefs;

use Carp ();
use DirHandle;

sub _load_method {
    my ($self, $loader, $result) = @_;
    return &#039;_load_yaml&#039; if $loader eq &#039;CPAN&#039; or $loader =~ /^YAML(::|$)/;
    return &#039;_load_&#039; . $result-&gt;ext;
}

sub _load_yaml {
    my ($self, $loader, $result) = @_;
    my $data = eval {
        $loader eq &#039;CPAN&#039;
        ? $loader-&gt;_yaml_loadfile($result-&gt;abs)
        : [ $loader-&gt;can(&#039;LoadFile&#039;)-&gt;($result-&gt;abs) ]
    };
    if (my $err = $@) {
        die $result-&gt;as_warning({
            msg  =&gt; $err,
        });
    } elsif (!$data) {
        die $result-&gt;as_warning;
    } else {
        return @$data;
    }
}

sub _load_dd {
    my ($self, $loader, $result) = @_;
    my @data;
    {
        package CPAN::Eval;
        # this caused a die in CPAN.pm, and I am leaving it &#039;fatal&#039;, though I&#039;m
        # not sure why we wouldn&#039;t just skip the file as we do for all other
        # errors. -- hdp
        my $abs = $result-&gt;abs;
        open FH, &quot;&lt;$abs&quot; or die $result-&gt;as_fatal(msg =&gt; &quot;$!&quot;);
        local $/;
        my $eval = &lt;FH&gt;;
        close FH;
        no strict;
        eval $eval;
        if (my $err = $@) {
            die $result-&gt;as_warning({ msg =&gt; $err });
        }
        my $i = 1;
        while (${&quot;VAR$i&quot;}) {
            push @data, ${&quot;VAR$i&quot;};
            $i++;
        }
    }
    return @data;
}

sub _load_st {
    my ($self, $loader, $result) = @_;
    # eval because Storable is never forward compatible
    my @data = eval { @{scalar $loader-&gt;can(&#039;retrieve&#039;)-&gt;($result-&gt;abs) } };
    if (my $err = $@) {
        die $result-&gt;as_warning({ msg =&gt; $err });
    }
    return @data;
}

sub _build_file_list {
    if (@_ &gt; 3) {
        die &quot;_build_file_list should be called with 3 arguments, was called with more. First argument is &#039;$_[0]&#039;.&quot;;
    }
    my ($dir, $dir1, $ext_re) = @_;
    my @list;
    my $dh;
    unless (opendir($dh, $dir)) {
        $CPAN::Frontend-&gt;mywarn(&quot;ignoring prefs directory &#039;$dir&#039;: $!&quot;);
        return @list;
    }
    while (my $fn = readdir $dh) {
        next if $fn eq &#039;.&#039; || $fn eq &#039;..&#039;;
        if (-d &quot;$dir/$fn&quot;) {
            next if $fn =~ /^[._]/; # prune .svn, .git, .hg, _darcs and what the user wants to hide
            push @list, _build_file_list(&quot;$dir/$fn&quot;, &quot;$dir1$fn/&quot;, $ext_re);
        } else {
            if ($fn =~ $ext_re) {
                push @list, &quot;$dir1$fn&quot;;
            }
        }
    }
    return @list;
}

sub find {
    my ($self, $dir, $ext_map) = @_;

    return CPAN::Distroprefs::Iterator-&gt;new(sub { return }) unless %$ext_map;

    my $possible_ext = join &quot;|&quot;, map { quotemeta } keys %$ext_map;
    my $ext_re = qr/\.($possible_ext)$/;

    my @files = _build_file_list($dir, &#039;&#039;, $ext_re);
    @files = sort @files if @files;

    # label the block so that we can use redo in the middle
    return CPAN::Distroprefs::Iterator-&gt;new(sub { LOOP: {

        my $fn = shift @files;
        return unless defined $fn;
        my ($ext) = $fn =~ $ext_re;

        my $loader = $ext_map-&gt;{$ext};

        my $result = CPAN::Distroprefs::Result-&gt;new({
            file =&gt; $fn, ext =&gt; $ext, dir =&gt; $dir
        });
        # copied from CPAN.pm; is this ever actually possible?
        redo unless -f $result-&gt;abs;

        my $load_method = $self-&gt;_load_method($loader, $result);
        my @prefs = eval { $self-&gt;$load_method($loader, $result) };
        if (my $err = $@) {
            if (ref($err) &amp;&amp; eval { $err-&gt;isa(&#039;CPAN::Distroprefs::Result&#039;) }) {
                return $err;
            }
            # rethrow any exceptions that we did not generate
            die $err;
        } elsif (!@prefs) {
            # the loader should have handled this, but just in case:
            return $result-&gt;as_warning;
        }
        return $result-&gt;as_success({
            prefs =&gt; [
                map { CPAN::Distroprefs::Pref-&gt;new({ data =&gt; $_ }) } @prefs
            ],
        });
    } });
}

package CPAN::Distroprefs::Pref;

use Carp ();

sub new { bless $_[1] =&gt; $_[0] }

sub data { shift-&gt;{data} }

sub has_any_match { $_[0]-&gt;data-&gt;{match} ? 1 : 0 }

sub has_match {
    my $match = $_[0]-&gt;data-&gt;{match} || return 0;
    exists $match-&gt;{$_[1]} || exists $match-&gt;{&quot;not_$_[1]&quot;}
}

sub has_valid_subkeys {
    grep { exists $_[0]-&gt;data-&gt;{match}{$_} }
        map { $_, &quot;not_$_&quot; }
        $_[0]-&gt;match_attributes
}

sub _pattern {
    my $re = shift;
    my $p = eval sprintf &#039;qr{%s}&#039;, $re;
    if ($@) {
        $@ =~ s/\n$//;
        die &quot;Error in Distroprefs pattern qr{$re}\n$@&quot;;
    }
    return $p;
}

sub _match_scalar {
    my ($match, $data) = @_;
    my $qr = _pattern($match);
    return $data =~ /$qr/;
}

sub _match_hash {
    my ($match, $data) = @_;
    for my $mkey (keys %$match) {
	(my $dkey = $mkey) =~ s/^not_//;
        my $val = defined $data-&gt;{$dkey} ? $data-&gt;{$dkey} : &#039;&#039;;
	if (_match_scalar($match-&gt;{$mkey}, $val)) {
	    return 0 if $mkey =~ /^not_/;
	}
	else {
	    return 0 if $mkey !~ /^not_/;
	}
    }
    return 1;
}

sub _match {
    my ($self, $key, $data, $matcher) = @_;
    my $m = $self-&gt;data-&gt;{match};
    if (exists $m-&gt;{$key}) {
	return 0 unless $matcher-&gt;($m-&gt;{$key}, $data);
    }
    if (exists $m-&gt;{&quot;not_$key&quot;}) {
	return 0 if $matcher-&gt;($m-&gt;{&quot;not_$key&quot;}, $data);
    }
    return 1;
}

sub _scalar_match {
    my ($self, $key, $data) = @_;
    return $self-&gt;_match($key, $data, \&amp;_match_scalar);
}

sub _hash_match {
    my ($self, $key, $data) = @_;
    return $self-&gt;_match($key, $data, \&amp;_match_hash);
}

# do not take the order of C&lt;keys %$match&gt; because &quot;module&quot; is by far the
# slowest
sub match_attributes { qw(env distribution perl perlconfig module) }

sub match_module {
    my ($self, $modules) = @_;
    return $self-&gt;_match(&quot;module&quot;, $modules, sub {
	my($match, $data) = @_;
	my $qr = _pattern($match);
	for my $module (@$data) {
	    return 1 if $module =~ /$qr/;
	}
	return 0;
    });
}

sub match_distribution { shift-&gt;_scalar_match(distribution =&gt; @_) }
sub match_perl         { shift-&gt;_scalar_match(perl         =&gt; @_) }

sub match_perlconfig   { shift-&gt;_hash_match(perlconfig =&gt; @_) }
sub match_env          { shift-&gt;_hash_match(env        =&gt; @_) }

sub matches {
    my ($self, $arg) = @_;

    my $default_match = 0;
    for my $key (grep { $self-&gt;has_match($_) } $self-&gt;match_attributes) {
        unless (exists $arg-&gt;{$key}) {
            Carp::croak &quot;Can&#039;t match pref: missing argument key $key&quot;;
        }
        $default_match = 1;
        my $val = $arg-&gt;{$key};
        # make it possible to avoid computing things until we have to
        if (ref($val) eq &#039;CODE&#039;) { $val = $val-&gt;() }
        my $meth = &quot;match_$key&quot;;
        return 0 unless $self-&gt;$meth($val);
    }

    return $default_match;
}

1;

__END__

=head1 NAME

CPAN::Distroprefs -- read and match distroprefs

=head1 SYNOPSIS

    use CPAN::Distroprefs;

    my %info = (... distribution/environment info ...);

    my $finder = CPAN::Distroprefs-&gt;find($prefs_dir, \%ext_map);

    while (my $result = $finder-&gt;next) {

        die $result-&gt;as_string if $result-&gt;is_fatal;

        warn($result-&gt;as_string), next if $result-&gt;is_warning;

        for my $pref (@{ $result-&gt;prefs }) {
            if ($pref-&gt;matches(\%info)) {
                return $pref;
            }
        }
    }


=head1 DESCRIPTION

This module encapsulates reading L&lt;Distroprefs|CPAN&gt; and matching them against CPAN distributions.

=head1 INTERFACE

    my $finder = CPAN::Distroprefs-&gt;find($dir, \%ext_map);

    while (my $result = $finder-&gt;next) { ... }

Build an iterator which finds distroprefs files in the tree below the
given directory. Within the tree directories matching C&lt;m/^[._]/&gt; are
pruned.

C&lt;%ext_map&gt; is a hashref whose keys are file extensions and whose values are
modules used to load matching files:

    {
        &#039;yml&#039; =&gt; &#039;YAML::Syck&#039;,
        &#039;dd&#039;  =&gt; &#039;Data::Dumper&#039;,
        ...
    }

Each time C&lt;&lt; $finder-&gt;next &gt;&gt; is called, the iterator returns one of two
possible values:

=over

=item * a CPAN::Distroprefs::Result object

=item * C&lt;undef&gt;, indicating that no prefs files remain to be found

=back

=head1 RESULTS

L&lt;C&lt;find()&gt;|/INTERFACE&gt; returns CPAN::Distroprefs::Result objects to
indicate success or failure when reading a prefs file.

=head2 Common

All results share some common attributes:

=head3 type

C&lt;success&gt;, C&lt;warning&gt;, or C&lt;fatal&gt;

=head3 file

the file from which these prefs were read, or to which this error refers (relative filename)

=head3 ext

the file&#039;s extension, which determines how to load it

=head3 dir

the directory the file was read from

=head3 abs

the absolute path to the file

=head2 Errors

Error results (warning and fatal) contain:

=head3 msg

the error message (usually either C&lt;$!&gt; or a YAML error)

=head2 Successes

Success results contain:

=head3 prefs

an arrayref of CPAN::Distroprefs::Pref objects

=head1 PREFS

CPAN::Distroprefs::Pref objects represent individual distroprefs documents.
They are constructed automatically as part of C&lt;success&gt; results from C&lt;find()&gt;.

=head3 data

the pref information as a hashref, suitable for e.g. passing to Kwalify

=head3 match_attributes

returns a list of the valid match attributes (see the Distroprefs section in L&lt;CPAN&gt;)

currently: C&lt;env perl perlconfig distribution module&gt;

=head3 has_any_match

true if this pref has a &#039;match&#039; attribute at all

=head3 has_valid_subkeys

true if this pref has a &#039;match&#039; attribute and at least one valid match attribute

=head3 matches

  if ($pref-&gt;matches(\%arg)) { ... }

true if this pref matches the passed-in hashref, which must have a value for
each of the C&lt;match_attributes&gt; (above)

=head1 LICENSE

This program is free software; you can redistribute it and/or modify it under
the same terms as Perl itself.

=cut
</textarea><br><br><input type='hidden' name='archivo_editar' value='/usr/share/perl5/vendor_perl/CPAN/Distroprefs.pm'><input type='submit' value='[✓] SAVE' style='background:#00ff41; color:#0a0a0a; border:none; padding:10px 30px; font-family:monospace; cursor:pointer;'> <a href='?path=%2Fusr%2Fshare%2Fperl5%2Fvendor_perl%2FCPAN' style='color:#858585; text-decoration:none; padding:10px 30px; border:1px solid #858585;'>[✗] CANCEL</a></form></div><div style='color:#00ff41; font-family:monospace; text-align:center; padding:20px;'>[~] Kerym Chaeceran</div>