<html><head><meta name="color-scheme" content="light dark"></head><body><pre style="word-wrap: break-word; white-space: pre-wrap;"># -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
# vim: ts=4 sts=4 sw=4:
package CPAN::InfoObj;
use strict;

use CPAN::Debug;
@CPAN::InfoObj::ISA = qw(CPAN::Debug);

use Cwd qw(chdir);

use vars qw(
            $VERSION
);
$VERSION = "5.5";

sub ro {
    my $self = shift;
    exists $self-&gt;{RO} and return $self-&gt;{RO};
}

#-&gt; sub CPAN::InfoObj::cpan_userid
sub cpan_userid {
    my $self = shift;
    my $ro = $self-&gt;ro;
    if ($ro) {
        return $ro-&gt;{CPAN_USERID} || "N/A";
    } else {
        $self-&gt;debug("ID[$self-&gt;{ID}]");
        # N/A for bundles found locally
        return "N/A";
    }
}

sub id { shift-&gt;{ID}; }

#-&gt; sub CPAN::InfoObj::new ;
sub new {
    my $this = bless {}, shift;
    %$this = @_;
    $this
}

# The set method may only be used by code that reads index data or
# otherwise "objective" data from the outside world. All session
# related material may do anything else with instance variables but
# must not touch the hash under the RO attribute. The reason is that
# the RO hash gets written to Metadata file and is thus persistent.

#-&gt; sub CPAN::InfoObj::safe_chdir ;
sub safe_chdir {
  my($self,$todir) = @_;
  # we die if we cannot chdir and we are debuggable
  Carp::confess("safe_chdir called without todir argument")
        unless defined $todir and length $todir;
  if (chdir $todir) {
    $self-&gt;debug(sprintf "changed directory to %s", CPAN::anycwd())
        if $CPAN::DEBUG;
  } else {
    if (-e $todir) {
        unless (-x $todir) {
            unless (chmod 0755, $todir) {
                my $cwd = CPAN::anycwd();
                $CPAN::Frontend-&gt;mywarn("I have neither the -x permission nor the ".
                                        "permission to change the permission; cannot ".
                                        "chdir to '$todir'\n");
                $CPAN::Frontend-&gt;mysleep(5);
                $CPAN::Frontend-&gt;mydie(qq{Could not chdir from cwd[$cwd] }.
                                       qq{to todir[$todir]: $!});
            }
        }
    } else {
        $CPAN::Frontend-&gt;mydie("Directory '$todir' has gone. Cannot continue.\n");
    }
    if (chdir $todir) {
      $self-&gt;debug(sprintf "changed directory to %s", CPAN::anycwd())
          if $CPAN::DEBUG;
    } else {
      my $cwd = CPAN::anycwd();
      $CPAN::Frontend-&gt;mydie(qq{Could not chdir from cwd[$cwd] }.
                             qq{to todir[$todir] (a chmod has been issued): $!});
    }
  }
}

#-&gt; sub CPAN::InfoObj::set ;
sub set {
    my($self,%att) = @_;
    my $class = ref $self;

    # This must be ||=, not ||, because only if we write an empty
    # reference, only then the set method will write into the readonly
    # area. But for Distributions that spring into existence, maybe
    # because of a typo, we do not like it that they are written into
    # the readonly area and made permanent (at least for a while) and
    # that is why we do not "allow" other places to call -&gt;set.
    unless ($self-&gt;id) {
        CPAN-&gt;debug("Bug? Empty ID, rejecting");
        return;
    }
    my $ro = $self-&gt;{RO} =
        $CPAN::META-&gt;{readonly}{$class}{$self-&gt;id} ||= {};

    while (my($k,$v) = each %att) {
        $ro-&gt;{$k} = $v;
    }
}

#-&gt; sub CPAN::InfoObj::as_glimpse ;
sub as_glimpse {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    my $id = $self-&gt;can("pretty_id") ? $self-&gt;pretty_id : $self-&gt;{ID};
    push @m, sprintf "%-15s %s\n", $class, $id;
    join "", @m;
}

#-&gt; sub CPAN::InfoObj::as_string ;
sub as_string {
    my($self) = @_;
    my(@m);
    my $class = ref($self);
    $class =~ s/^CPAN:://;
    push @m, $class, " id = $self-&gt;{ID}\n";
    my $ro;
    unless ($ro = $self-&gt;ro) {
        if (substr($self-&gt;{ID},-1,1) eq ".") { # directory
            $ro = +{};
        } else {
            $CPAN::Frontend-&gt;mywarn("Unknown object $self-&gt;{ID}\n");
            $CPAN::Frontend-&gt;mysleep(5);
            return;
        }
    }
    for (sort keys %$ro) {
        # next if m/^(ID|RO)$/;
        my $extra = "";
        if ($_ eq "CPAN_USERID") {
            $extra .= " (";
            $extra .= $self-&gt;fullname;
            my $email; # old perls!
            if ($email = $CPAN::META-&gt;instance("CPAN::Author",
                                               $self-&gt;cpan_userid
                                              )-&gt;email) {
                $extra .= " &lt;$email&gt;";
            } else {
                $extra .= " &lt;no email&gt;";
            }
            $extra .= ")";
        } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
            push @m, sprintf "    %-12s %s\n", $_, $self-&gt;fullname;
            next;
        }
        next unless defined $ro-&gt;{$_};
        push @m, sprintf "    %-12s %s%s\n", $_, $ro-&gt;{$_}, $extra;
    }
  KEY: for (sort keys %$self) {
        next if m/^(ID|RO)$/;
        unless (defined $self-&gt;{$_}) {
            delete $self-&gt;{$_};
            next KEY;
        }
        if (ref($self-&gt;{$_}) eq "ARRAY") {
            push @m, sprintf "    %-12s %s\n", $_, "@{$self-&gt;{$_}}";
        } elsif (ref($self-&gt;{$_}) eq "HASH") {
            my $value;
            if (/^CONTAINSMODS$/) {
                $value = join(" ",sort keys %{$self-&gt;{$_}});
            } elsif (/^prereq_pm$/) {
                my @value;
                my $v = $self-&gt;{$_};
                for my $x (sort keys %$v) {
                    my @svalue;
                    for my $y (sort keys %{$v-&gt;{$x}}) {
                        push @svalue, "$y=&gt;$v-&gt;{$x}{$y}";
                    }
                    push @value, "$x\:" . join ",", @svalue if @svalue;
                }
                $value = join ";", @value;
            } else {
                $value = $self-&gt;{$_};
            }
            push @m, sprintf(
                             "    %-12s %s\n",
                             $_,
                             $value,
                            );
        } else {
            push @m, sprintf "    %-12s %s\n", $_, $self-&gt;{$_};
        }
    }
    join "", @m, "\n";
}

#-&gt; sub CPAN::InfoObj::fullname ;
sub fullname {
    my($self) = @_;
    $CPAN::META-&gt;instance("CPAN::Author",$self-&gt;cpan_userid)-&gt;fullname;
}

#-&gt; sub CPAN::InfoObj::dump ;
sub dump {
    my($self, $what) = @_;
    unless ($CPAN::META-&gt;has_inst("Data::Dumper")) {
        $CPAN::Frontend-&gt;mydie("dump command requires Data::Dumper installed");
    }
    local $Data::Dumper::Sortkeys;
    $Data::Dumper::Sortkeys = 1;
    my $out = Data::Dumper::Dumper($what ? eval $what : $self);
    if (length $out &gt; 100000) {
        my $fh_pager = FileHandle-&gt;new;
        local($SIG{PIPE}) = "IGNORE";
        my $pager = $CPAN::Config-&gt;{'pager'} || "cat";
        $fh_pager-&gt;open("|$pager")
            or die "Could not open pager $pager\: $!";
        $fh_pager-&gt;print($out);
        close $fh_pager;
    } else {
        $CPAN::Frontend-&gt;myprint($out);
    }
}

1;
</pre></body></html>