1# -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2# vim: ts=4 sts=4 sw=4:
3package CPAN::InfoObj;
4use strict;
5
6use CPAN::Debug;
7@CPAN::InfoObj::ISA = qw(CPAN::Debug);
8
9use Cwd qw(chdir);
10
11use vars qw(
12            $VERSION
13);
14$VERSION = "5.5";
15
16sub ro {
17    my $self = shift;
18    exists $self->{RO} and return $self->{RO};
19}
20
21#-> sub CPAN::InfoObj::cpan_userid
22sub 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
34sub id { shift->{ID}; }
35
36#-> sub CPAN::InfoObj::new ;
37sub 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 ;
50sub 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 ;
86sub 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 ;
109sub 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 ;
120sub 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 ;
197sub fullname {
198    my($self) = @_;
199    $CPAN::META->instance("CPAN::Author",$self->cpan_userid)->fullname;
200}
201
202#-> sub CPAN::InfoObj::dump ;
203sub 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
2241;
225