Commit | Line | Data |
---|---|---|
f9916dde A |
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; |