Commit | Line | Data |
f9916dde |
1 | # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*- |
2 | # vim: ts=4 sts=4 sw=4: |
3 | package CPAN::InfoObj; |
4 | use strict; |
5 | |
6 | use CPAN::Debug; |
7 | @CPAN::InfoObj::ISA = qw(CPAN::Debug); |
8 | |
9 | use Cwd qw(chdir); |
10 | |
11 | use vars qw( |
12 | $VERSION |
13 | ); |
14 | $VERSION = "5.5"; |
15 | |
16 | sub ro { |
17 | my $self = shift; |
18 | exists $self->{RO} and return $self->{RO}; |
19 | } |
20 | |
21 | #-> sub CPAN::InfoObj::cpan_userid |
22 | sub cpan_userid { |
23 | my $self = shift; |
24 | my $ro = $self->ro; |
25 | if ($ro) { |
26 | return $ro->{CPAN_USERID} || "N/A"; |
27 | } else { |
28 | $self->debug("ID[$self->{ID}]"); |
29 | # N/A for bundles found locally |
30 | return "N/A"; |
31 | } |
32 | } |
33 | |
34 | sub id { shift->{ID}; } |
35 | |
36 | #-> sub CPAN::InfoObj::new ; |
37 | sub new { |
38 | my $this = bless {}, shift; |
39 | %$this = @_; |
40 | $this |
41 | } |
42 | |
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. |
48 | |
49 | #-> sub CPAN::InfoObj::safe_chdir ; |
50 | sub 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; |
55 | if (chdir $todir) { |
56 | $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) |
57 | if $CPAN::DEBUG; |
58 | } else { |
59 | if (-e $todir) { |
60 | unless (-x $todir) { |
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]: $!}); |
69 | } |
70 | } |
71 | } else { |
72 | $CPAN::Frontend->mydie("Directory '$todir' has gone. Cannot continue.\n"); |
73 | } |
74 | if (chdir $todir) { |
75 | $self->debug(sprintf "changed directory to %s", CPAN::anycwd()) |
76 | if $CPAN::DEBUG; |
77 | } else { |
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): $!}); |
81 | } |
82 | } |
83 | } |
84 | |
85 | #-> sub CPAN::InfoObj::set ; |
86 | sub set { |
87 | my($self,%att) = @_; |
88 | my $class = ref $self; |
89 | |
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. |
96 | unless ($self->id) { |
97 | CPAN->debug("Bug? Empty ID, rejecting"); |
98 | return; |
99 | } |
100 | my $ro = $self->{RO} = |
101 | $CPAN::META->{readonly}{$class}{$self->id} ||= {}; |
102 | |
103 | while (my($k,$v) = each %att) { |
104 | $ro->{$k} = $v; |
105 | } |
106 | } |
107 | |
108 | #-> sub CPAN::InfoObj::as_glimpse ; |
109 | sub as_glimpse { |
110 | my($self) = @_; |
111 | my(@m); |
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; |
116 | join "", @m; |
117 | } |
118 | |
119 | #-> sub CPAN::InfoObj::as_string ; |
120 | sub as_string { |
121 | my($self) = @_; |
122 | my(@m); |
123 | my $class = ref($self); |
124 | $class =~ s/^CPAN:://; |
125 | push @m, $class, " id = $self->{ID}\n"; |
126 | my $ro; |
127 | unless ($ro = $self->ro) { |
128 | if (substr($self->{ID},-1,1) eq ".") { # directory |
129 | $ro = +{}; |
130 | } else { |
131 | $CPAN::Frontend->mywarn("Unknown object $self->{ID}\n"); |
132 | $CPAN::Frontend->mysleep(5); |
133 | return; |
134 | } |
135 | } |
136 | for (sort keys %$ro) { |
137 | # next if m/^(ID|RO)$/; |
138 | my $extra = ""; |
139 | if ($_ eq "CPAN_USERID") { |
140 | $extra .= " ("; |
141 | $extra .= $self->fullname; |
142 | my $email; # old perls! |
143 | if ($email = $CPAN::META->instance("CPAN::Author", |
144 | $self->cpan_userid |
145 | )->email) { |
146 | $extra .= " <$email>"; |
147 | } else { |
148 | $extra .= " <no email>"; |
149 | } |
150 | $extra .= ")"; |
151 | } elsif ($_ eq "FULLNAME") { # potential UTF-8 conversion |
152 | push @m, sprintf " %-12s %s\n", $_, $self->fullname; |
153 | next; |
154 | } |
155 | next unless defined $ro->{$_}; |
156 | push @m, sprintf " %-12s %s%s\n", $_, $ro->{$_}, $extra; |
157 | } |
158 | KEY: for (sort keys %$self) { |
159 | next if m/^(ID|RO)$/; |
160 | unless (defined $self->{$_}) { |
161 | delete $self->{$_}; |
162 | next KEY; |
163 | } |
164 | if (ref($self->{$_}) eq "ARRAY") { |
165 | push @m, sprintf " %-12s %s\n", $_, "@{$self->{$_}}"; |
166 | } elsif (ref($self->{$_}) eq "HASH") { |
167 | my $value; |
168 | if (/^CONTAINSMODS$/) { |
169 | $value = join(" ",sort keys %{$self->{$_}}); |
170 | } elsif (/^prereq_pm$/) { |
171 | my @value; |
172 | my $v = $self->{$_}; |
173 | for my $x (sort keys %$v) { |
174 | my @svalue; |
175 | for my $y (sort keys %{$v->{$x}}) { |
176 | push @svalue, "$y=>$v->{$x}{$y}"; |
177 | } |
178 | push @value, "$x\:" . join ",", @svalue if @svalue; |
179 | } |
180 | $value = join ";", @value; |
181 | } else { |
182 | $value = $self->{$_}; |
183 | } |
184 | push @m, sprintf( |
185 | " %-12s %s\n", |
186 | $_, |
187 | $value, |
188 | ); |
189 | } else { |
190 | push @m, sprintf " %-12s %s\n", $_, $self->{$_}; |
191 | } |
192 | } |
193 | join "", @m, "\n"; |
194 | } |
195 | |
196 | #-> sub CPAN::InfoObj::fullname ; |
197 | sub fullname { |
198 | my($self) = @_; |
199 | $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname; |
200 | } |
201 | |
202 | #-> sub CPAN::InfoObj::dump ; |
203 | sub dump { |
204 | my($self, $what) = @_; |
205 | unless ($CPAN::META->has_inst("Data::Dumper")) { |
206 | $CPAN::Frontend->mydie("dump command requires Data::Dumper installed"); |
207 | } |
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); |
218 | close $fh_pager; |
219 | } else { |
220 | $CPAN::Frontend->myprint($out); |
221 | } |
222 | } |
223 | |
224 | 1; |