lib/CPAN/Queue.pm

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