1 # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 # vim: ts=4 sts=4 sw=4:
7 @CPAN::InfoObj::ISA = qw(CPAN::Debug);
18 exists $self->{RO} and return $self->{RO};
21 #-> sub CPAN::InfoObj::cpan_userid
26 return $ro->{CPAN_USERID} || "N/A";
28 $self->debug("ID[$self->{ID}]");
29 # N/A for bundles found locally
34 sub id { shift->{ID}; }
36 #-> sub CPAN::InfoObj::new ;
38 my $this = bless {}, shift;
43 # The set method may only be used by code that reads index data or
44 # otherwise "objective" data from the outside world. All session
45 # related material may do anything else with instance variables but
46 # must not touch the hash under the RO attribute. The reason is that
47 # the RO hash gets written to Metadata file and is thus persistent.
49 #-> sub CPAN::InfoObj::safe_chdir ;
51 my($self,$todir) = @_;
52 # we die if we cannot chdir and we are debuggable
53 Carp::confess("safe_chdir called without todir argument")
54 unless defined $todir and length $todir;
56 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
61 unless (chmod 0755, $todir) {
62 my $cwd = CPAN::anycwd();
63 $CPAN::Frontend->mywarn("I have neither the -x permission nor the ".
64 "permission to change the permission; cannot ".
65 "chdir to '$todir'\n");
66 $CPAN::Frontend->mysleep(5);
67 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
68 qq{to todir[$todir]: $!});
72 $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n");
75 $self->debug(sprintf "changed directory to %s", CPAN::anycwd())
78 my $cwd = CPAN::anycwd();
79 $CPAN::Frontend->mydie(qq{Could not chdir from cwd[$cwd] }.
80 qq{to todir[$todir] (a chmod has been issued): $!});
85 #-> sub CPAN::InfoObj::set ;
88 my $class = ref $self;
90 # This must be ||=, not ||, because only if we write an empty
91 # reference, only then the set method will write into the readonly
92 # area. But for Distributions that spring into existence, maybe
93 # because of a typo, we do not like it that they are written into
94 # the readonly area and made permanent (at least for a while) and
95 # that is why we do not "allow" other places to call ->set.
97 CPAN->debug("Bug? Empty ID, rejecting");
100 my $ro = $self->{RO} =
101 $CPAN::META->{readonly}{$class}{$self->id} ||= {};
103 while (my($k,$v) = each %att) {
108 #-> sub CPAN::InfoObj::as_glimpse ;
112 my $class = ref($self);
113 $class =~ s/^CPAN:://;
114 my $id = $self->can("pretty_id") ? $self->pretty_id : $self->{ID};
115 push @m, sprintf "%-15s %s\n", $class, $id;
119 #-> sub CPAN::InfoObj::as_string ;
123 my $class = ref($self);
124 $class =~ s/^CPAN:://;
125 push @m, $class, " id = $self->{ID}\n";
127 unless ($ro = $self->ro) {
128 if (substr($self->{ID},-1,1) eq ".") { # directory
131 $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n");
132 $CPAN::Frontend->mysleep(5);
136 for (sort keys %$ro) {
137 # next if m/^(ID|RO)$/;
139 if ($_ eq "CPAN_USERID") {
141 $extra .= $self->fullname;
142 my $email; # old perls!
143 if ($email = $CPAN::META->instance("CPAN::Author",
146 $extra .= " <$email>";
148 $extra .= " <no email>";
151 } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion
152 push @m, sprintf " %-12s %s\n", $_, $self->fullname;
155 next unless defined $ro->{$_};
156 push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra;
158 KEY: for (sort keys %$self) {
159 next if m/^(ID|RO)$/;
160 unless (defined $self->{$_}) {
164 if (ref($self->{$_}) eq "ARRAY") {
165 push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}";
166 } elsif (ref($self->{$_}) eq "HASH") {
168 if (/^CONTAINSMODS$/) {
169 $value = join(" ",sort keys %{$self->{$_}});
170 } elsif (/^prereq_pm$/) {
173 for my $x (sort keys %$v) {
175 for my $y (sort keys %{$v->{$x}}) {
176 push @svalue, "$y=>$v->{$x}{$y}";
178 push @value, "$x\:" . join ",", @svalue if @svalue;
180 $value = join ";", @value;
182 $value = $self->{$_};
190 push @m, sprintf " %-12s %s\n", $_, $self->{$_};
196 #-> sub CPAN::InfoObj::fullname ;
199 $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
202 #-> sub CPAN::InfoObj::dump ;
204 my($self, $what) = @_;
205 unless ($CPAN::META->has_inst("Data::Dumper")) {
206 $CPAN::Frontend->mydie("dump command requires Data::Dumper installed");
208 local $Data::Dumper::Sortkeys;
209 $Data::Dumper::Sortkeys = 1;
210 my $out = Data::Dumper::Dumper($what ? eval $what : $self);
211 if (length $out > 100000) {
212 my $fh_pager = FileHandle->new;
213 local($SIG{PIPE}) = "IGNORE";
214 my $pager = $CPAN::Config->{'pager'} || "cat";
215 $fh_pager->open("|$pager")
216 or die "Could not open pager $pager\: $!";
217 $fh_pager->print($out);
220 $CPAN::Frontend->myprint($out);