File Coverage

blib/lib/CPAN/Queue.pm
Criterion Covered Total %
statement 6 80 7.5
branch 0 30 0.0
condition 0 3 0.0
subroutine 2 16 12.5
pod 0 10 0.0
total 8 139 5.7


line stmt bran cond sub pod time code
1             # -*- Mode: cperl; coding: utf-8; cperl-indent-level: 4 -*-
2 13     13   93 use strict;
  13         37  
  13         2268  
3             package CPAN::Queue::Item;
4              
5             # CPAN::Queue::Item::new ;
6             sub new {
7 0     0     my($class,@attr) = @_;
8 0           my $self = bless { @attr }, $class;
9 0           return $self;
10             }
11              
12             sub as_string {
13 0     0     my($self) = @_;
14 0           $self->{qmod};
15             }
16              
17             # r => requires, b => build_requires, c => commandline
18             sub reqtype {
19 0     0     my($self) = @_;
20 0           $self->{reqtype};
21             }
22              
23             sub optional {
24 0     0     my($self) = @_;
25 0           $self->{optional};
26             }
27              
28             package CPAN::Queue;
29              
30             # One use of the queue is to determine if we should or shouldn't
31             # announce the availability of a new CPAN module
32              
33             # Now we try to use it for dependency tracking. For that to happen
34             # we need to draw a dependency tree and do the leaves first. This can
35             # easily be reached by running CPAN.pm recursively, but we don't want
36             # to waste memory and run into deep recursion. So what we can do is
37             # this:
38              
39             # CPAN::Queue is the package where the queue is maintained. Dependencies
40             # often have high priority and must be brought to the head of the queue,
41             # possibly by jumping the queue if they are already there. My first code
42             # attempt tried to be extremely correct. Whenever a module needed
43             # immediate treatment, I either unshifted it to the front of the queue,
44             # or, if it was already in the queue, I spliced and let it bypass the
45             # others. This became a too correct model that made it impossible to put
46             # an item more than once into the queue. Why would you need that? Well,
47             # you need temporary duplicates as the manager of the queue is a loop
48             # that
49             #
50             # (1) looks at the first item in the queue without shifting it off
51             #
52             # (2) cares for the item
53             #
54             # (3) removes the item from the queue, *even if its agenda failed and
55             # even if the item isn't the first in the queue anymore* (that way
56             # protecting against never ending queues)
57             #
58             # So if an item has prerequisites, the installation fails now, but we
59             # want to retry later. That's easy if we have it twice in the queue.
60             #
61             # I also expect insane dependency situations where an item gets more
62             # than two lives in the queue. Simplest example is triggered by 'install
63             # Foo Foo Foo'. People make this kind of mistakes and I don't want to
64             # get in the way. I wanted the queue manager to be a dumb servant, not
65             # one that knows everything.
66             #
67             # Who would I tell in this model that the user wants to be asked before
68             # processing? I can't attach that information to the module object,
69             # because not modules are installed but distributions. So I'd have to
70             # tell the distribution object that it should ask the user before
71             # processing. Where would the question be triggered then? Most probably
72             # in CPAN::Distribution::rematein.
73              
74 13     13   104 use vars qw{ @All $VERSION };
  13         34  
  13         14577  
75             $VERSION = "5.5002";
76              
77             # CPAN::Queue::queue_item ;
78             sub queue_item {
79 0     0 0   my($class,@attr) = @_;
80 0           my $item = "$class\::Item"->new(@attr);
81 0           $class->qpush($item);
82 0           return 1;
83             }
84              
85             # CPAN::Queue::qpush ;
86             sub qpush {
87 0     0 0   my($class,$obj) = @_;
88 0           push @All, $obj;
89             CPAN->debug(sprintf("in new All[%s]",
90 0 0         join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
  0            
91             )) if $CPAN::DEBUG;
92             }
93              
94             # CPAN::Queue::first ;
95             sub first {
96 0     0 0   my $obj = $All[0];
97 0           $obj;
98             }
99              
100             # CPAN::Queue::delete_first ;
101             sub delete_first {
102 0     0 0   my($class,$what) = @_;
103 0           my $i;
104 0           for my $i (0..$#All) {
105 0 0         if ( $All[$i]->{qmod} eq $what ) {
106 0           splice @All, $i, 1;
107 0           last;
108             }
109             }
110             CPAN->debug(sprintf("after delete_first mod[%s] All[%s]",
111             $what,
112 0 0         join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
  0            
113             )) if $CPAN::DEBUG;
114             }
115              
116             # CPAN::Queue::jumpqueue ;
117             sub jumpqueue {
118 0     0 0   my $class = shift;
119 0           my @what = @_;
120             CPAN->debug(sprintf("before jumpqueue All[%s] what[%s]",
121 0           join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All),
122 0 0         join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @what),
  0            
123             )) if $CPAN::DEBUG;
124 0 0         unless (defined $what[0]{reqtype}) {
125             # apparently it was not the Shell that sent us this enquiry,
126             # treat it as commandline
127 0           $what[0]{reqtype} = "c";
128             }
129 0 0         my $inherit_reqtype = $what[0]{reqtype} =~ /^(c|r)$/ ? "r" : "b";
130 0           WHAT: for my $what_tuple (@what) {
131 0           my($qmod,$reqtype,$optional) = @$what_tuple{qw(qmod reqtype optional)};
132 0 0 0       if ($reqtype eq "r"
133             &&
134             $inherit_reqtype eq "b"
135             ) {
136 0           $reqtype = "b";
137             }
138 0           my $jumped = 0;
139 0           for (my $i=0; $i<$#All;$i++) { #prevent deep recursion
140 0 0         if ($All[$i]{qmod} eq $qmod) {
141 0           $jumped++;
142             }
143             }
144             # high jumped values are normal for popular modules when
145             # dealing with large bundles: XML::Simple,
146             # namespace::autoclean, UNIVERSAL::require
147 0 0         CPAN->debug("qmod[$qmod]jumped[$jumped]") if $CPAN::DEBUG;
148 0           my $obj = "$class\::Item"->new(
149             qmod => $qmod,
150             reqtype => $reqtype,
151             optional => !! $optional,
152             );
153 0           unshift @All, $obj;
154             }
155             CPAN->debug(sprintf("after jumpqueue All[%s]",
156 0 0         join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
  0            
157             )) if $CPAN::DEBUG;
158             }
159              
160             # CPAN::Queue::exists ;
161             sub exists {
162 0     0 0   my($self,$what) = @_;
163 0           my @all = map { $_->{qmod} } @All;
  0            
164 0           my $exists = grep { $_->{qmod} eq $what } @All;
  0            
165             # warn "in exists what[$what] all[@all] exists[$exists]";
166 0           $exists;
167             }
168              
169             # CPAN::Queue::delete ;
170             sub delete {
171 0     0 0   my($self,$mod) = @_;
172 0           @All = grep { $_->{qmod} ne $mod } @All;
  0            
173             CPAN->debug(sprintf("after delete mod[%s] All[%s]",
174             $mod,
175 0 0         join("",map {sprintf " %s\[%s][%s]\n",$_->{qmod},$_->{reqtype},$_->{optional}} @All)
  0            
176             )) if $CPAN::DEBUG;
177             }
178              
179             # CPAN::Queue::nullify_queue ;
180             sub nullify_queue {
181 0     0 0   @All = ();
182             }
183              
184             # CPAN::Queue::size ;
185             sub size {
186 0     0 0   return scalar @All;
187             }
188              
189             sub reqtype_of {
190 0     0 0   my($self,$mod) = @_;
191 0           my $best = "";
192 0           for my $item (grep { $_->{qmod} eq $mod } @All) {
  0            
193 0           my $c = $item->{reqtype};
194 0 0         if ($c eq "c") {
    0          
    0          
195 0           $best = $c;
196 0           last;
197             } elsif ($c eq "r") {
198 0           $best = $c;
199             } elsif ($c eq "b") {
200 0 0         if ($best eq "") {
201 0           $best = $c;
202             }
203             } else {
204 0           die "Panic: in reqtype_of: reqtype[$c] seen, should never happen";
205             }
206             }
207 0           return $best;
208             }
209              
210             1;
211              
212             __END__