lib/CPAN/Queue.pm

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