};
- PAUSE::HeavyCGI::Layout->new(@l);
-}
-
-sub last_modified {
- my PAUSE::HeavyCGI $self = shift;
- my($set) = @_;
- $set = PAUSE::HeavyCGI::Date->new(unix => $set)
- if defined($set) and not ref($set); # allow setting to a number
- $self->{LAST_MODIFIED} = $set if defined $set;
- return $self->{LAST_MODIFIED} if defined $self->{LAST_MODIFIED};
- $self->{LAST_MODIFIED} =
- PAUSE::HeavyCGI::Date->new(unix => $self->time);
-}
-
-sub myurl {
- my PAUSE::HeavyCGI $self = shift;
- return $self->{MYURL} if defined $self->{MYURL};
- require URI::URL;
- my $req = $self->{REQ} or
- return URI::URL->new("http://localhost");
- $self->{MYURL} = URI::URL->new($req->base);
-}
-
-sub new {
- my($class,%opt) = @_;
- no strict "refs";
- my $self = bless {}, $class;
- while (my($k,$v) = each %opt) {
- $self->{$k} = $v;
- }
- $self;
-}
-
-sub prepare {
- my PAUSE::HeavyCGI $self = shift;
- if (my $ep = $self->{EXECUTION_PLAN}) {
- $ep->walk($self);
- } else {
- die "No execution plan!";
- }
-}
-
-sub serverroot_url {
- my PAUSE::HeavyCGI $self = shift;
- return $self->{SERVERROOT_URL} if $self->{SERVERROOT_URL};
- require URI::URL;
- my $req = $self->{REQ} or
- return URI::URL->new("http://localhost");
- my $host = $req->env->{SERVER_NAME}; # XXX: $r->server->server_hostname;
- my $port = $req->port || 80;
- my $protocol = $port == 443 ? "https" : "http";
- my $explicit_port = ($port == 80 || $port == 443) ? "" : ":$port";
- $self->{SERVERROOT_URL} = URI::URL->new(
- "$protocol\://" .
- $host .
- $explicit_port .
- "/"
- );
-}
-
-sub time {
- my PAUSE::HeavyCGI $self = shift;
- $self->{TIME} ||= time;
-}
-
-sub today {
- my PAUSE::HeavyCGI $self = shift;
- return $self->{TODAY} if defined $self->{TODAY};
- my(@time) = localtime($self->time);
- $time[4]++;
- $time[5] += 1900;
- $self->{TODAY} = sprintf "%04d-%02d-%02d", @time[5,4,3];
-}
-
-# CGI form handling
-
-sub checkbox {
- my($self,%arg) = @_;
-
- my $name = $arg{name};
- my $value;
- defined($value = $arg{value}) or ($value = "on");
- my $checked;
- my @sel = $self->{REQ}->param($name);
- if (@sel) {
- for my $s (@sel) {
- if ($s eq $value) {
- $checked = 1;
- last;
- }
- }
- } else {
- $checked = $arg{checked};
- }
- sprintf(qq{},
- $self->escapeHTML($name),
- $self->escapeHTML($value),
- $checked ? qq{ checked="checked"} : ""
- );
-}
-
-# pause_1999::main
-sub checkbox_group {
- my($self,%arg) = @_;
-
- my $name = $arg{name};
- my @sel = $self->{REQ}->param($name);
- unless (@sel) {
- if (exists $arg{default}) {
- my $default = $arg{default};
- @sel = ref $default ? @$default : $default;
- }
- }
-
- my %sel;
- @sel{@sel} = ();
- my @m;
-
- $name = $self->escapeHTML($name);
-
- my $haslabels = exists $arg{labels};
- my $linebreak = $arg{linebreak} ? " " : "";
-
- for my $v (@{$arg{values} || []}) {
- push(@m,
- sprintf(
- qq{%s%s},
- $name,
- $self->escapeHTML($v),
- exists $sel{$v} ? qq{ checked="checked"} : "",
- $haslabels ? $arg{labels}{$v} : $self->escapeHTML($v),
- $linebreak,
- )
- );
- }
- join "", @m;
-}
-
-sub escapeHTML {
- my($self, $what) = @_;
- return unless defined $what;
- my %escapes = qw(& & " " > > < <);
- $what =~ s[ ([&"<>]) ][$escapes{$1}]xg; # ]] cperl-mode comment
- $what;
-}
-
-sub file_field {
- my($self) = shift;
- $self->text_pw_field(FIELDTYPE=>"file", @_);
-}
-
-sub hidden_field {
- my($self) = shift;
- $self->text_pw_field(FIELDTYPE=>"hidden", @_);
-}
-
-sub password_field {
- my($self) = shift;
- $self->text_pw_field(FIELDTYPE=>"password", @_);
-}
-
-# pause_1999::main
-sub radio_group {
- my($self,%arg) = @_;
- my $name = $arg{name};
- my $value;
- my $checked;
- my $sel = $self->{REQ}->param($name);
- my $haslabels = exists $arg{labels};
- my $values = $arg{values} or Carp::croak "radio_group called without values";
- defined($checked = $arg{checked})
- or defined($checked = $sel)
- or defined($checked = $arg{default})
- or $checked = "";
- # some people like to check the first item anyway:
- # or ($checked = $values->[0]);
- my $escname=$self->escapeHTML($name);
- my $linebreak = $arg{linebreak} ? " " : "";
- my @m;
- for my $v (@$values) {
- my $escv = $self->escapeHTML($v);
- if ($DEBUG) {
- warn "escname undef" unless defined $escname;
- warn "escv undef" unless defined $escv;
- warn "v undef" unless defined $v;
- warn "\$arg{labels}{\$v} undef" unless defined $arg{labels}{$v};
- warn "checked undef" unless defined $checked;
- warn "haslabels undef" unless defined $haslabels;
- warn "linebreak undef" unless defined $linebreak;
- }
- push(@m,
- sprintf(
- qq{%s%s},
- $escname,
- $escv,
- $v eq $checked ? qq{ checked="checked"} : "",
- $haslabels ? $arg{labels}{$v} : $escv,
- $linebreak,
- ));
- }
- join "", @m;
-}
-
-# pause_1999::main
-sub scrolling_list {
- my($self, %arg) = @_;
- # name values size labels
- my $size = $arg{size} ? qq{ size="$arg{size}"} : "";
- my $multiple = $arg{multiple} ? q{ multiple="multiple"} : "";
- my $haslabels = exists $arg{labels};
- my $name = $arg{name};
- my @sel = $self->{REQ}->param($name);
- if (!@sel && exists $arg{default} && defined $arg{default}) {
- my $d = $arg{default};
- @sel = ref $d ? @$d : $d;
- }
- my %sel;
- @sel{@sel} = ();
- my @m;
- push @m, sprintf qq{";
- join "", @m;
-}
-
-# pause_1999::main
-sub submit {
- my($self,%arg) = @_;
- my $name = $arg{name} || "";
- my $val = $arg{value} || $name;
- sprintf qq{},
- $self->escapeHTML($name),
- $self->escapeHTML($val);
-}
-
-# pause_1999::main
-sub textarea {
- my($self,%arg) = @_;
- my $req = $self->{REQ};
- my $name = $arg{name} || "";
- my $val = $req->param($name) || $arg{default} || $arg{value} || "";
- my($r) = exists $arg{rows} ? qq{ rows="$arg{rows}"} : '';
- my($c) = exists $arg{cols} ? qq{ cols="$arg{cols}"} : '';
- my($wrap)= exists $arg{wrap} ? qq{ wrap="$arg{wrap}"} : '';
- sprintf qq{},
- $self->escapeHTML($name),
- $r, $c, $wrap, $self->escapeHTML($val);
-}
-
-# pause_1999::main
-sub textfield {
- my($self) = shift;
- $self->text_pw_field(FIELDTYPE=>"text", @_);
-}
-
-sub text_pw_field {
- my($self, %arg) = @_;
- my $name = $arg{name} || "";
- my $fieldtype = $arg{FIELDTYPE};
-
- my $req = $self->{REQ};
- my $val;
- if ($fieldtype eq "FILE") {
- if ($req->can("upload")) {
- if ($req->upload($name)) {
- $val = $req->upload($name);
- } else {
- $val = $req->param($name);
- }
- } else {
- $val = $req->param($name);
- }
- } else {
- $val = $req->param($name);
- }
- defined $val or
- defined($val = $arg{value}) or
- defined($val = $arg{default}) or
- ($val = "");
-
- sprintf qq{},
- $self->escapeHTML($name),
- $self->escapeHTML($val),
- exists $arg{size} ? " size=\"$arg{size}\"" : "",
- exists $arg{maxlength} ? " maxlength=\"$arg{maxlength}\"" : "";
-}
-
-sub uri_escape {
- my PAUSE::HeavyCGI $self = shift;
- my $string = shift;
- return "" unless defined $string;
- require URI::Escape;
- my $s = URI::Escape::uri_escape($string, '^\w ');
- $s =~ s/ /+/g;
- $s;
-}
-
-sub uri_escape_light {
- my PAUSE::HeavyCGI $self = shift;
- require URI::Escape;
- URI::Escape::uri_escape(shift,q{<>#%"; \/\?:&=+,\$}); #"
-}
-
-1;
-
-=head1 NAME
-
-PAUSE::HeavyCGI - Framework to run complex CGI tasks on an Apache server
-
-=head1 SYNOPSIS
-
- use PAUSE::HeavyCGI;
-
-=head1 WARNING UNSUPPORTED ALPHA CODE RELEASED FOR DEMO ONLY
-
-The release of this software was only for evaluation purposes to
-people who are actively writing code that deals with Web Application
-Frameworks. This package is probably just another Web Application
-Framework and may be worth using or may not be worth using. As of this
-writing (July 1999) it is by no means clear if this software will be
-developed further in the future. The author has written it over many
-years and is deploying it in several places. B
-
-There is no official support for this software. If you find it useful
-or even if you find it useless, please mail the author directly.
-
-But please make sure you remember: THE RELEASE IS FOR DEMONSTRATION
-PURPOSES ONLY.
-
-=head1 DESCRIPTION
-
-The PAUSE::HeavyCGI framework is intended to provide a couple of
-simple tricks that make it easier to write complex CGI solutions. It
-has been developed on a site that runs all requests through a single
-mod_perl handler that in turn uses CGI.pm or Apache::Request as the
-query interface. So PAUSE::HeavyCGI is -- as the name implies -- not
-merely for multi-page CGI scripts (for which there are other
-solutions), but it is for the integration of many different pages into
-a single solution. The many different pages can then conveniently
-share common tasks.
-
-The approach taken by PAUSE::HeavyCGI is a components-driven one with
-all components being pure perl. So if you're not looking for yet
-another embedded perl solution, and aren't intimidated by perl, please
-read on.
-
-=head2 Stacked handlers suck
-
-If you have had a look at stacked handlers, you might have noticed
-that the model for stacking handlers often is too primitive. The model
-supposes that the final form of a document can be found by running
-several passes over a single entity, each pass refining the entity,
-manipulating some headers, maybe even passing some notes to the next
-handler, and in the most advanced form passing pnotes between
-handlers. A lot of Web pages may fit into that model, even complex
-ones, but it doesn't scale well for pages that result out of a
-structure that's more complicated than adjacent items. The more
-complexity you add to a page, the more overhead is generated by the
-model, because for every handler you push onto the stack, the whole
-document has to be parsed and recomposed again and headers have to be
-re-examined and possibly changed.
-
-=head2 Why not subclass Apache
-
-Inheritance provokes namespace conflicts. Besides this, I see little
-reason why one should favor inheritance over a B relationship.
-The current implementation of PAUSE::HeavyCGI is very closely coupled
-with the Apache class anyway, so we could do inheritance too. No big
-deal I suppose. The downside of the current way of doing it is that we
-have to write
-
- my $r = $obj->{R};
-
-very often, but that's about it. The upside is, that we know which
-manpage to read for the different methods provided by C<$obj->{R}>,
-C<$obj->{CGI}>, and C<$obj> itself.
-
-=head2 Composing applications
-
-PAUSE::HeavyCGI takes an approach that is more ambitious for handling
-complex tasks. The underlying model for the production of a document
-is that of a puzzle. An HTML (or XML or SGML or whatever) page is
-regarded as a sequence of static and dynamic parts, each of which has
-some influence on the final output. Typically, in today's Webpages,
-the dynamic parts are filled into table cells, i.e. contents between
-some C<<
>> tokens. But this is not necessarily so. The
-static parts in between typically are some HTML markup, but this also
-isn't forced by the model. The model simply expects a sequence of
-static and dynamic parts. Static and dynamic parts can appear in
-random order. In the extreme case of a picture you would only have one
-part, either static or dynamic. HeavyCGI could handle this, but I
-don't see a particular advantage of HeavyCGI over a simple single
-handler.
-
-In addition to the task of generating the contents of the page, there
-is the other task of producing correct headers. Header composition is
-an often neglected task in the CGI world. Because pages are generated
-dynamically, people believe that pages without a Last-Modified header
-are fine, and that an If-Modified-Since header in the browser's
-request can go by unnoticed. This laissez-faire principle gets in the
-way when you try to establish a server that is entirely driven by
-dynamic components and the number of hits is significant.
-
-=head2 Header Composition, Parameter Processing, and Content Creation
-
-The three big tasks a CGI script has to master are Headers, Parameters
-and the Content. In general one can say, content creation SHOULD not
-start before all parameters are processed. In complex scenarios you
-MUST expect that the whole layout may depend on one parameter.
-Additionally we can say that some header related data SHOULD be
-processed very early because they might result in a shortcut that
-saves us a lot of processing.
-
-Consequently, PAUSE::HeavyCGI divides the tasks to be done for a
-request into four phases and distributes the four phases among an
-arbitrary number of modules. Which modules are participating in the
-creation of a page is the design decision of the programmer.
-
-The perl model that maps (at least IMHO) ideally to this task
-description is an object oriented approach that identifies a couple of
-phases by method names and a couple of components by class names. To
-create an application with PAUSE::HeavyCGI, the programmer specifies
-the names of all classes that are involved. All classes are singleton
-classes, i.e. they have no identity of their own but can be used to do
-something useful by working on an object that is passed to them.
-Singletons have an @ISA relation to L which can be
-found on CPAN. As such, the classes can only have a single instance
-which can be found by calling the C<< CLASS->instance >> method. We'll
-call these objects after the mod_perl convention I.
-
-Every request maps to exactly one PAUSE::HeavyCGI object. The
-programmer uses the methods of this object by subclassing. The
-HeavyCGI constructor creates objects of the AVHV type (pseudo-hashes).
-
-*** Note: after 0.0133 this was changed to an ordinary hash. ***
-
-If the inheriting class needs its own constructor, this needs to be an
-AVHV compatible constructor. A description of AVHV can be found in
-L.
-
-*** Note: after 0.0133 this was changed to be an ordinary hash. ***
-
-An PAUSE::HeavyCGI object usually is constructed with the
-C method and after that the programmer calls the C
-method on this object. HeavyCGI will then perform various
-initializations and then ask all nominated handlers in turn to perform
-the I method and in a second round to perform the I
-method. In most cases it will be the case that the availability of a
-method can be determined at compile time of the handler. If this is
-true, it is possible to create an execution plan at compile time that
-determines the sequence of calls such that no runtime is lost to check
-method availability. Such an execution plan can be created with the
-L module. All of the called methods will
-get the HeavyCGI request object passed as the second parameter.
-
-There are no fixed rules as to what has to happen within the C
-and C method. As a rule of thumb it is recommended to
-determine and set the object attributes LAST_MODIFIED and EXPIRES (see
-below) within the header() method. It is also recommended to inject
-the L module as the last header handler,
-so that the application can abort early with an Not Modified header. I
-would recommend that in the header phase you do as little as possible
-parameter processing except for those parameters that are related to
-the last modification date of the generated page.
-
-=head2 Terminating the handler calls or triggering errors.
-
-Sometimes you want to stop calling the handlers, because you think
-that processing the request is already done. In that case you can do a
-
- die PAUSE::HeavyCGI::Exception->new(HTTP_STATUS => status);
-
-at any point within prepare() and the specified status will be
-returned to the Apache handler. This is useful for example for the
-PAUSE::HeavyCGI::IfModified module which sends the response headers
-and then dies with HTTP_STATUS set to Apache::Constants::DONE.
-Redirectors presumably would set up their headers and set it to
-Apache::Constants::HTTP_MOVED_TEMPORARILY.
-
-Another task for Perl exceptions are errors: In case of an error
-within the prepare loop, all you need to do is
-
- die PAUSE::HeavyCGI::Exception->new(ERROR=>[array_of_error_messages]);
-
-The error is caught at the end of the prepare loop and the anonymous
-array that is being passed to $@ will then be appended to
-C<@{$self-E{ERROR}}>. You should check for $self->{ERROR} within
-your layout method to return an appropriate response to the client.
-
-=head2 Layout and Text Composition
-
-After the header and the parameter phase, the application should have
-set up the object that is able to characterize the complete
-application and its status. No changes to the object should happen
-from now on.
-
-In the next phase PAUSE::HeavyCGI will ask this object to perform the
-C method that has the duty to generate an
-PAUSE::HeavyCGI::Layout (or compatible) object. Please read more
-about this object in L. For our HeavyCGI
-object it is only relevant that this Layout object can compose itself
-as a string in the as_string() method. As a layout object can be
-composed as an abstraction of a layout and independent of
-request-specific contents, it is recommended to cache the most
-important layouts. This is part of the reponsibility of the
-programmer.
-
-In the next step HeavyCGI stores a string representation of current
-request by calling the as_string() method on the layout object and
-passing itself to it as the first argument. By passing itself to the
-Layout object all the request-specific data get married to the
-layout-specific data and we reach the stage where stacked handlers
-usually start, we get at a composed content that is ready for
-shipping.
-
-The last phase deals with setting up the yet unfinished headers,
-eventually compressing, recoding and measuring the content, and
-delivering the request to the browser. The two methods finish() and
-deliver() are responsible for that phase. The default deliver() method
-is pretty generic, it calls finish(), then sends the headers, and
-sends the content only if the request method wasn't a HEAD. It then
-returns Apache's constant DONE to the caller, so that Apache won't do
-anything except logging on this request. The method finish is more apt
-to being overridden. The default finish() method sets the content type
-to text/html, compresses the content if the browser understands
-compressed data and Compress::Zlib is available, it also sets the
-headers Vary, Expires, Last-Modified, and Content-Length. You most
-probably will want to override the finish method.
-
-head2 Summing up
- +-------------------+
- | sub handler {...} |
- +--------------------+ | (sub init {...}) |
- |Your::Class |---defines------>| |
- |ISA PAUSE::HeavyCGI| | sub layout {...} |
- +--------------------+ | sub finish {...} |
- +-------------------+
-
- +-------------------+
- | sub new {...} |
- +--------------------+ | sub dispatch {...}|
- |PAUSE::HeavyCGI |---defines------>| sub prepare {...} |
- +--------------------+ | sub deliver {...} |
- +-------------------+
-
- +----------------------+ +--------------------+
- |Handler_1 .. Handler_N| | sub header {...} |
- |ISA Class::Singleton |---define----->| sub parameter {...}|
- +----------------------+ +--------------------+
-
- +----+
- |Your|
- |Duty|
- +----------------------------+----------------------------------------+----+
- |Apache | calls Your::Class::handler() | |
- +----------------------------+----------------------------------------+----+
- | | nominates the handlers, | |
- |Your::Class::handler() | constructs $self, | ** |
- | | and calls $self->dispatch | |
- +----------------------------+----------------------------------------+----+
- | | $self->init (does nothing) | ?? |
- | | $self->prepare (see below) | |
- |PAUSE::HeavyCGI::dispatch()| calls $self->layout (sets up layout)| ** |
- | | $self->finish (headers and | ** |
- | | gross content) | |
- | | $self->deliver (delivers) | ?? |
- +----------------------------+----------------------------------------+----+
- |PAUSE::HeavyCGI::prepare() | calls HANDLER->instance->header($self) | ** |
- | | and HANDLER->instance->parameter($self)| ** |
- | | on all of your nominated handlers | |
- +----------------------------+----------------------------------------+----+
-
-
-=head1 Object Attributes
-
-As already mentioned, the HeavyCGI object is a pseudo-hash, i.e. can
-be treated like a HASH, but all attributes that are being used must be
-predeclared at compile time with a C
.*$||si;
- push @m, $html;
- }
-
- last;
- }
- unless (@m) {
- push @m, "document '$doc' not found on the server";
- }
- join "", @m;
-}
-
-sub tail_logfile {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
- my $tail = $req->param("pause99_tail_logfile_1") || 5000;
- my($file) = $PAUSE::Config->{PAUSE_LOG};
- if ($PAUSE::Config->{TESTHOST}) {
- $file = "/usr/local/apache/logs/error_log"; # for testing
- }
- open my $fh, $file or die "Could not open $file: $!";
- seek $fh, -$tail, 2;
- local($/);
- $/ = "\n";
- <$fh>;
- $/ = undef;
- my @m;
- push @m, $mgr->scrolling_list(
- name => "pause99_tail_logfile_1",
- size => 1,
- values => [qw( 2000 5000 10000 20000 40000) ],
- );
- push @m, qq{};
- push @m, "
", $mgr->escapeHTML(<$fh>), "
";
- join "", @m;
-}
-
-sub change_passwd {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- $mgr->prefer_post(1);
- my $req = $mgr->{REQ};
- my @m;
- my $u = $self->active_user_record($mgr);
- push @m, qq{};
- push @m, qq{
Changing Password of $u->{userid}
}; # };
- if (my $param = $req->param("ABRA")) {
- push @m, qq{};
- }
-
- if ($req->param("pause99_change_passwd_sub")) {
- if (my $pw1 = $req->param("pause99_change_passwd_pw1")) {
- if (my $pw2 = $req->param("pause99_change_passwd_pw2")) {
- if ($pw1 eq $pw2) {
- # create a new crypted password, store it, report
- my $pwenc = PAUSE::Crypt::hash_password($pw1);
- my $dbh = $mgr->authen_connect;
- my $sql = qq{UPDATE $PAUSE::Config->{AUTHEN_USER_TABLE}
- SET $PAUSE::Config->{AUTHEN_PASSWORD_FLD} = ?,
- forcechange = ?,
- changed = ?,
- changedby = ?
- WHERE $PAUSE::Config->{AUTHEN_USER_FLD} = ?};
- # warn "sql[$sql]";
- my $rc = $dbh->do($sql,undef,
- $pwenc,0,time,$mgr->{User}{userid},$u->{userid});
- warn "rc[$rc]";
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR =>
- sprintf qq[Could not set password: '%s'], $dbh->errstr
- ) unless $rc;
- if ($rc == 0) {
- $sql = qq{INSERT INTO $PAUSE::Config->{AUTHEN_USER_TABLE}
- ($PAUSE::Config->{AUTHEN_USER_FLD},
- $PAUSE::Config->{AUTHEN_PASSWORD_FLD},
- forcechange,
- changed,
- changedby ) VALUES
- (?, ?, ?, ?, ?)
-}; # };
- $rc = $dbh->do($sql,undef,
- $u->{userid},
- $pwenc,
- 0,
- time,
- $mgr->{User}{userid},
- $u->{userid}
- );
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR =>
- sprintf qq[Could not insert user record: '%s'], $dbh->errstr
- ) unless $rc;
- }
- for my $anon ($mgr->{User}, $u) {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => "Panic: unknown user") unless $anon->{userid};
- next if $anon->{fullname};
- $req->logger({level => 'error', message => "Unknown fullname for $anon->{userid}!" });
- }
-
- push @m, "New password stored and enabled. Be prepared that
- you will be asked for a new authentication on the next request. If
- this doesn't work out, it may be that you have to restart the
- browser.";
-
- my $mailblurb = sprintf(
- qq{Password update on PAUSE:
-
-%s (%s) visited the
-password changer on PAUSE at %s UTC
-and changed the password for %s (%s).
-
-No action is required, but it would be a good idea if somebody
-would check the correctness of the new password.
-
-Thanks,
-The PAUSE Team
-},
- $mgr->{User}->{userid},
- $mgr->{User}{fullname}||"fullname N/A",
- scalar gmtime,
- $u->{userid},
- $u->{fullname}||"fullname N/A");
- my %umailset;
- my $name = $u->{asciiname} || $u->{fullname} || "";
- my $Uname = $mgr->{User}{asciiname} || $mgr->{User}{fullname} || "";
- if ($u->{secretemail}) {
- $umailset{qq{"$name" <$u->{secretemail}>}} = 1;
- } elsif ($u->{email}) {
- $umailset{qq{"$name" <$u->{email}>}} = 1;
- }
- if ($u->{userid} ne $mgr->{User}{userid}) {
- if ($mgr->{User}{secretemail}) {
- $umailset{qq{"$Uname" <$mgr->{User}{secretemail}>}} = 1;
- }elsif ($mgr->{User}{email}) {
- $umailset{qq{"$Uname" <$mgr->{User}{email}>}} = 1;
- }
- }
- my @to = keys %umailset;
- my $header = {Subject => "Password Update"};
- $mgr->send_mail_multi(\@to, $header, $mailblurb);
- } else {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => "The two passwords didn't match.");
- }
- } else {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => "You need to fill in the same password in both fields.");
- }
- } else {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => "Please fill in the form with passwords.");
- }
- } else {
- if ( $mgr->{UserSecrets}{forcechange} ) {
- push @m, qq{
Your password in the database is tainted which
- means you have to renew it. If you believe this is wrong, please
- complain, it's always possible that you are seeing a bug.
};
- }
-
- push @m, qq{
Please fill in your new password in both textboxes.
- Only if both fields contain the same password, we will be able to
- proceed.
};
-
- push @m, $mgr->password_field(name=>"pause99_change_passwd_pw1",
- maxlength=>72,
- size=>16);
- push @m, qq{\n};
- push @m, $mgr->password_field(name=>"pause99_change_passwd_pw2",
- maxlength=>72,
- size=>16);
- push @m, qq{\n};
- push @m, qq{};
- }
- @m;
-}
-
-sub add_uri {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
- my $debug_table = $req->parameters; # XXX: $r->parms
- warn sprintf "DEBUG: req[%s]", join(":",%$debug_table);
- $PAUSE::Config->{INCOMING_LOC} =~ s|/$||;
- my @m;
- my $u = $self->active_user_record($mgr);
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR =>
- "Unidentified error happened, please write to the PAUSE admins
- at $PAUSE::Config->{ADMIN} and help them identifying what's going on. Thanks!")
- unless $u->{userid};
- push @m, qq{};
- my $can_multipart = $mgr->can_multipart;
- push @m, qq{};
- push @m, qq{
Add a file for $u->{userid}
};
- my($tryupload) = $mgr->can_multipart;
- my($uri);
- my $userhome = PAUSE::user2dir($u->{userid});
-
- if ($req->param("SUBMIT_pause99_add_uri_HTTPUPLOAD")
- || $req->param("SUBMIT_pause99_add_uri_httpupload")) {
- my $upl = $req->upload('pause99_add_uri_httpupload');
- unless ($upl->size) {
- warn "Warning: maybe they hit RETURN, no upload size, not doing HTTPUPLOAD";
- $req->parameters->set("SUBMIT_pause99_add_uri_HTTPUPLOAD","");
- $req->parameters->set("SUBMIT_pause99_add_uri_httpupload","");
- }
- }
- if (! $req->param("SUBMIT_pause99_add_uri_HTTPUPLOAD")
- &&! $req->param("SUBMIT_pause99_add_uri_httpupload")
- &&! $req->param("SUBMIT_pause99_add_uri_uri")
- &&! $req->param("SUBMIT_pause99_add_uri_upload")
- ) {
- # no submit button
- if ($req->param("pause99_add_uri_uri")) {
- $req->parameters->set("SUBMIT_pause99_add_uri_uri", "2ndguess");
- } elsif ($req->param("pause99_add_uri_upload")) {
- $req->parameters->set("SUBMIT_pause99_add_uri_upload", "2ndguess");
- }
- }
-
- my $didit = 0;
- my $mailblurb = "";
- my $success = "";
- my $now = time;
- if (
- $req->param("SUBMIT_pause99_add_uri_httpupload") || # from 990806
- $req->param("SUBMIT_pause99_add_uri_HTTPUPLOAD")
- ) {
- if ($mgr->{UseModuleSet} eq "ApReq") {
- my $upl;
- if (
- $upl = $req->upload("pause99_add_uri_httpupload") or # from 990806
- $upl = $req->upload("HTTPUPLOAD")
- ) {
- if ($upl->size) {
- my $filename = $upl->filename;
- $filename =~ s(.*/)()gs; # no slash
- $filename =~ s(.*\\)()gs; # no backslash
- $filename =~ s(.*:)()gs; # no colon
- $filename =~ s/[^A-Za-z0-9_\-\.\@\+]//g; # only ASCII-\w and - . @ + allowed
- my $to = "$PAUSE::Config->{INCOMING_LOC}/$filename";
- # my $fhi = $upl->fh;
- require File::Copy;
- if (-f $to && -s _ == 0) { # zero sized files are a common problem
- unlink $to;
- }
- if (File::Copy::copy($upl->path, $to)){
- $uri = $filename;
- # Got an empty $to in the HTML page, so for debugging..
- my $h1 = qq{
Your filename has been altered as it contained characters besides
-the class [A-Za-z0-9_\\-\\.\\@\\+]. DEBUG: your filename[%s] corrected
-filename[%s].
-
-),
- $dv->stringify($upl->filename),
- $dv->stringify($filename)
- );
- $req->parameters->set("pause99_add_uri_httpupload",$filename);
- }
- } else {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR =>
- "uploaded file was zero sized");
- }
- } else {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR =>
- "Could not create an upload object. DEBUG: upl[$upl]");
- }
- } elsif ($mgr->{UseModuleSet} eq "patchedCGI") {
- warn "patchedCGI not supported anymore";
-
- my $handle;
- if (
- $handle = $req->param('pause99_add_uri_httpupload') or
- $handle = $req->param('HTTPUPLOAD')
- ) {
- no strict;
- use File::Copy;
- $filename = "$handle";
- $filename =~ s(.*/)()s; # no slash
- $filename =~ s(.*\\)()s; # no backslash
- $filename =~ s(.*:)()s; # no colon
- $filename =~ s/[^A-Za-z0-9_\-\.\@\+]//g; # only ASCII-\w and - . @ + allowed
- my $to = "$PAUSE::Config->{INCOMING_LOC}/$filename";
- if (File::Copy::copy(\*$handle, $to)){
- $uri = $filename;
- push @m, qq{
File successfully copied to '$to'
};
- } else {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR =>
- "Couldn't copy file '$filename' to '$to': $!");
- }
- }
- } else {
- die "Illegal UseModuleSet: $mgr->{UseModuleSet}";
- }
- } elsif ( $req->param("SUBMIT_pause99_add_uri_uri") ) {
- $uri = $req->param("pause99_add_uri_uri");
- $req->parameters->set("pause99_add_uri_httpupload",""); # I saw spurious
- # nonsense in the
- # field that broke
- # XHTML
- } elsif ( $req->param("SUBMIT_pause99_add_uri_upload") ) {
- $uri = $req->param("pause99_add_uri_upload");
- $req->parameters->set("pause99_add_uri_httpupload",""); # I saw spurious
- # nonsense in the
- # field that broke
- # XHTML
- }
- # my $myurl = $mgr->myurl;
- my $server = $PAUSE::Config->{SERVER_NAME}; # XXX: $r->server->server_hostname
- my $dbh = $mgr->connect;
-
-
-
- if (! $uri ) {
- push @m, "\n\n\n\n";
- } else {
- push @m, $self->add_uri_continue_with_uri($mgr,$uri,\$success,\$didit);
- }
-
- push @m, qq{\n
-
-
This form enables you to enter one file at a time
- into CPAN in one of these ways:
};
-
- if ($tryupload) {
-
- push @m, qq{\n
HTTP Upload: As an
- HTTP upload: enter the filename in the lower text field.
- Hint: If you encounter problems processing this form,
- it may be due to the fact that your browser can\'t handle
- multipart/form-data forms that support file
- upload. In such a case, please retry to access this file-upload-disabled
- form.
\n};
-
- } else {
-
- push @m, qq{\n
HTTP Upload:As
- you do not seem to want HTTP upload enabled, we do
- not offer it. If this is not what you want, try to
- explicitly
- enable HTTP upload.
\n};
-
- }
-
- push @m, qq{
GET URL: PAUSE fetches
- any http or ftp URL that can be handled by LWP: use the text
- field (please specify the complete URL). How to use this
- for direct publishing from your github repository has been
- described by Mike Schilli in the historical posting
- http://blog.usarundbrief.com/?p=36 but it is not available on
- the net anymore. If you find a copy, please let us
- know.
\n};
-
- push @m, qq{
\n
Please, make sure your filename
- contains a version number. For security reasons you will never
- be able to upload a file with the same name again (not even
- after deleting it). Thank you.
-
-
There is no need to upload README files separately. The
- upload server will unwrap your files (.tar.gz or .zip files
- only) within a few hours after uploading and will put the
- topmost README file as, say, Foo-Bar-3.14.readme into your
- directory. Hint: if you're looking for an even more
- convenient way to upload files than this form, you can try the
- cpan-upload script.
-
If you want to load the
- file into a directory below your CPAN directory,
- please specify the directory name here. Any number of
- subdirectory levels is allowed, they all will be
- created on the fly if they don't exist yet. Only sane
- directory names are allowed and the number of
- characters for the whole path is limited.
- NOTE: To upload a Perl6 distribution a target
- directory whose top level subdirectory is "Perl6" must
- be specified. In addition, a Perl6 distribution must
- contain a META6.json. Pause will only consider it a
- Perl6 dist if these two conditions are satisfied.
-
If your browser can handle
- file upload, enter the filename here and I'll transfer it
- to your homedirectory: };
-
- push @m, $mgr->file_field(name => 'pause99_add_uri_httpupload',
- size => 50);
- push @m, "\n ";
- push @m, qq{
\n};
- }
-
- # via FTP GET
-
- warn "DEBUG: UPLOAD[$PAUSE::Config->{UPLOAD}]";
- push @m, qq{
If you want me to fetch a
- file from an URL, enter the full URL here. };
-
- push @m, $mgr->textfield(
- name => "pause99_add_uri_uri",
- size => 64,
- maxlength => 128
- );
- push @m, "\n ";
- push @m, qq{
\n};
-
- # END OF UPLOAD OPTIONS
-
- push @m, "\n
\n";
-
- my $want_to_send_email_on_upload_submission = 0;
- if ($want_to_send_email_on_upload_submission && $didit) {
- my $her = $mgr->{User}{userid} eq $u->{userid} ? "his/her" :
- "$u->{userid}'s";
-
- my $mailblurb = $self->wrap(qq{$mgr->{User}{userid}
-($mgr->{User}{fullname}) visited the PAUSE and requested an upload
-into $her directory. The request used the following parameters:});
- $mailblurb .= "\n";
-
- my @mb;
- my $longest = 0;
- for my $param ($req->param) {
- next if $param eq "HIDDENNAME";
- next if $param eq "CAN_MULTIPART";
- next if $param eq "pause99_add_uri_sub"; # we're not interested
- my $v = $req->param($param);
- next unless defined $v;
- next unless length $v;
- $longest = length($param) if length($param) > $longest;
- push @mb, [$param,$v];
- }
- for my $mb (@mb) {
- my($param, $v) = @$mb;
- $mailblurb .= sprintf qq{ %-*s [%s]\n}, $longest, $param, $v;
- }
- $mailblurb .= "\n";
- $mailblurb .= $self->wrappar($success);
- $mailblurb .= "\n\nThanks for your contribution,\n-- \nThe PAUSE Team\n";
-# my $header = {
-# To => qq{$PAUSE::Config->{ADMIN}, $u->{email}, $mgr->{User}{email}},
-# Subject => qq{Notification from PAUSE},
-# };
- my %umailset;
- my $name = $u->{asciiname} || $u->{fullname} || "";
- if ($u->{secretemail}) {
- $umailset{qq{"$name" <$u->{secretemail}>}} = 1;
- } elsif ($u->{email}) {
- $umailset{qq{"$name" <$u->{email}>}} = 1;
- }
- if ($u->{userid} ne $mgr->{User}{userid}) {
- my $Uname = $mgr->{User}{asciiname} || $mgr->{User}{fullname} || "";
- if ($mgr->{User}{secretemail}) {
- $umailset{qq{"$Uname" <$mgr->{User}{secretemail}>}} = 1;
- }elsif ($mgr->{User}{email}) {
- $umailset{qq{"$Uname" <$mgr->{User}{email}>}} = 1;
- }
- }
- $umailset{$PAUSE::Config->{ADMIN}} = 1;
- my @to = keys %umailset;
- my $header = {
- Subject => "Notification from PAUSE",
- };
- $mgr->send_mail_multi(\@to, $header, $mailblurb);
- }
-
- @m;
-}
-
-sub add_uri_continue_with_uri {
- my($self,$mgr,$uri,$success,$didit) = @_;
- my $req = $mgr->{REQ};
- my $u = $self->active_user_record($mgr);
- my $userhome = PAUSE::user2dir($u->{userid});
- my $dbh = $mgr->connect;
- my $now = time;
- my $server = $PAUSE::Config->{SERVER_NAME}; # XXX: $r->server->server_hostname
- my @m;
- push @m, "\n\n
\n",
- "\n\n",
- ;
-
- require URI::URL;
- eval { URI::URL->new("$uri", $PAUSE::Config->{INCOMING}); };
-
-
- if ($@) {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => [qq{
-Sorry, $uri could not be recognized as an uri (},
- $@,
- qq{\)
\n";
- }
- }
- warn join "", @debug;
- push @m, "Resulting SQL: ", $cp;
- }
- local($dbh->{RaiseError}) = 0;
- if ($dbh->do($query, undef, @query_params)) {
- $$success .= qq{
-
-The request is now entered into the database where the PAUSE daemon
-will pick it up as soon as possible (usually 1-2 minutes).
-
-};
- $$didit = 1;
- push @m, (qq{
-
-
Query succeeded. Thank you for your contribution
-
-
As it is done by a separate process, it may take a few minutes to
-complete the upload. The processing of your file is going on while you
-read this. There\'s no need for you to retry. The form below is only
-here in case you want to upload further files.
-
-
Please tidy up your homedir: CPAN is getting larger every day which
-is nice but usually there is no need to keep old an outdated version
-of a module on several hundred mirrors. Please consider removing old versions of
-your module from PAUSE and CPAN. If you are worried that someone might
-need an old version, it can always be found on the backpan
-
-
-});
-
- my $usrdir = "https://$server/pub/PAUSE/authors/id/$userhome";
- my $tailurl = "https://$server/pause/authenquery?ACTION=tail_logfile" .
- "&pause99_tail_logfile_1=5000";
- my $etailurl = $mgr->escapeHTML($tailurl);
- push @m, (qq{
-
-
Debugging: your submission should show up soon at $usrdir. If something's wrong, please
-check the logfile of the daemon: see the tail of it with $etailurl. If you already know what's going wrong, you
-may wish to visit the repair
-tool for pending uploads.
-
-}
- );
-
- $$success .= qq{
-
-During upload you can watch the logfile in $tailurl.
-
-You'll be notified as soon as the upload has succeeded, and if the
-uploaded package contains modules, you'll get another notification
-from the indexer a little later (usually within 1 hour).
-
-};
-
- } else {
- my $errmsg = $dbh->errstr;
- $mgr->{RES}->status(406);
- push @m, (qq{
-
-
Could not enter the URL into the database.
-Reason:
$errmsg
-
-});
- if ($errmsg =~ /non\s+unique\s+key|Duplicate/i) {
- $mgr->{RES}->status(409);
- my $sth = $dbh->prepare("SELECT * FROM uris WHERE uriid=?");
- $sth->execute($uriid);
- my $rec = $mgr->fetchrow($sth, "fetchrow_hashref");
- for my $k (qw(changed dgot dverified)) {
- if ($rec->{$k}) {
- $rec->{$k} .= sprintf " [%s UTC]", scalar gmtime $rec->{$k};
- }
- }
- my $as_table = $self->hash_as_table($rec);
- push @m, qq{
-
-
This indicates that you probably tried to upload a file that is
-already in the database. You will most probably have to rename your
-file and try again, because PAUSE doesn\'t let you upload a file
-twice.
-
-
This seems to be the record causing the conflict: $as_table
-
-};
- }
- }
- }
-
- push @m, "\n\n
\n";
-
- push @m, (qq{\n});
- return @m;
-}
-
-sub manifind {
- my($self) = @_;
- my $cwd = Cwd::cwd();
- warn "cwd[$cwd]";
- my %files = %{ExtUtils::Manifest::manifind()};
- if (keys %files == 1 && exists $files{""} && $files{""} eq "") {
- warn "ALERT: BUG in MANIFIND, falling back to zsh !!!";
-
- # This bug was caused by libc upgrade: perl and apache were
- # compiled with 2.1.3; upgrading to 2.2.5 and/or later
- # recompilation of apache has caused readdir() to return a list of
- # empty strings.
-
- open my $ls, "zsh -c 'ls **/*(.)' |" or die;
- %files = map { chomp; $_ => "" } <$ls>;
- close $ls;
- }
-
- %files;
-}
-
-sub scroll_subdirs {
- my $self = shift;
- my $mgr = shift;
- my $u = shift;
- my $userhome = PAUSE::user2dir($u->{userid});
- require ExtUtils::Manifest;
- if (chdir "$PAUSE::Config->{MLROOT}/$userhome"){
- warn "DEBUG: MLROOT[$PAUSE::Config->{MLROOT}] userhome[$userhome] E:M:V[$ExtUtils::Manifest::VERSION]";
- } else {
- return "";
- }
- my %files = $self->manifind;
- my %seen;
- my @dirs = sort grep !$seen{$_}++, grep s|(.+)/[^/]+|$1|, keys %files;
- return "" unless @dirs;
- unshift @dirs, ".";
- my $size = @dirs > 18 ? 15 : scalar(@dirs);
- my @m;
- push @m, $mgr->scrolling_list(
- 'name' => "pause99_add_uri_subdirscrl",
- 'values' => \@dirs,
- 'size' => $size,
- );
- push @m, qq{ };
- @m;
-}
-
-sub wrap {
- my $self = shift;
- my $p = shift;
- my($wrapped);
- $wrapped = Text::Format->new("firstIndent"=>0)->format($p);
- $wrapped;
-}
-
-sub wrappar {
- my $self = shift;
- my @p = split /\n\n/, shift;
- my($wrapped);
- $wrapped = Text::Format->new("firstIndent"=>0)->paragraphs(@p);
- $wrapped;
-}
-
-sub delete_files {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
- my @m;
- my $u = $self->active_user_record($mgr);
- $mgr->prefer_post(1);
- push @m, qq{};
- require ExtUtils::Manifest;
- require HTTP::Date;
- my $dbh = $mgr->connect;
- local($dbh->{RaiseError}) = 0;
- my $userhome = PAUSE::user2dir($u->{userid});
- push @m, qq{
Files in directory authors/id/$userhome
}; #};
- require Cwd;
- my $cwd = Cwd::cwd();
-
- if (chdir "$PAUSE::Config->{MLROOT}/$userhome"){
- warn "DEBUG: MLROOT[$PAUSE::Config->{MLROOT}] userhome[$userhome] ExtUtils:Manifest:VERSION[$ExtUtils::Manifest::VERSION]";
- } else {
- # QUICK DEPARTURE
- push @m, qq{No files found in authors/id/$userhome};
- return @m;
- }
-
- # NONO, this is nothing we should die from:
- # die PAUSE::HeavyCGI::Exception
- # ->new(ERROR => [qq{No files found in authors/id/$userhome}]);
-
-
- my $time = time;
- my $blurb = "";
- # my $myurl = $mgr->myurl;
- my $server = $PAUSE::Config->{SERVER_NAME}; # XXX: $r->server->server_hostname
- if ($req->param('SUBMIT_pause99_delete_files_delete')) {
-
- foreach my $f ($req->param('pause99_delete_files_FILE')) {
- if ($f =~ m,^/, || $f =~ m,/\.\./,) {
- $blurb .= "WARNING: illegal filename: $userhome/$f\n";
- next;
- }
- unless (-f $f){
- $blurb .= "WARNING: file not found: $userhome/$f\n";
- next;
- }
- if ($f =~ m{ (^|/) CHECKSUMS }x) {
- $blurb .= "WARNING: CHECKSUMS not erasable: $userhome/$f\n";
- next;
- }
- $dbh->do(
- "INSERT INTO deletes VALUES (?, ?, ?)", undef,
- "$userhome/$f", $time, "$mgr->{User}{userid}"
- ) or next;
-
- $blurb .= "\$CPAN/authors/id/$userhome/$f\n";
-
- # README
- next if $f =~ /\.readme$/;
- my $readme = $f;
- $readme =~ s/(\.tar.gz|\.zip)$/.readme/;
- if ($readme ne $f && -f $readme) {
- $dbh->do(
- q{INSERT INTO deletes VALUES (?,?,?)}, undef,
- "$userhome/$readme", $time, $mgr->{User}{userid},
- ) or next;
- $blurb .= "\$CPAN/authors/id/$userhome/$readme\n";
- }
- }
- } elsif ($req->param('SUBMIT_pause99_delete_files_undelete')) {
- foreach my $f ($req->param('pause99_delete_files_FILE')) {
- my $sql = "DELETE FROM deletes WHERE deleteid = ?";
- $dbh->do(
- $sql, undef,
- "$userhome/$f"
- ) or warn sprintf "FAILED Query: %s/: %s", $sql, "$userhome/$f", $DBI::errstr;
- }
- }
- if ($blurb) {
- my $tf = Text::Format->new("firstIndent"=>0,);
- my @blurb = scalar $tf->format(sprintf(
- qq{According to a request entered by %s the
-following files and the symlinks pointing to them have been scheduled
-for deletion. They will expire after 72 hours and then be deleted by a
-cronjob. Until then you can undelete them via
-https://%s/pause/authenquery?ACTION=delete_files or
-http://%s/pause/authenquery?ACTION=delete_files
-},
- $mgr->{User}{fullname},
- $server,
- $server));
- push @blurb, $blurb;
- push @blurb, scalar $tf->format(qq{Note: to encourage deletions, all of past CPAN
-glory is collected on http://history.perl.org/backpan/});
- push @blurb, qq{The PAUSE Team};
- # $blurb = Text::Format->new("firstIndent"=>0,)->paragraphs(@blurb);
- $blurb = join "\n", @blurb;
-
- my %umailset;
- my $name = $u->{asciiname} || $u->{fullname} || "";
- my $Uname = $mgr->{User}{asciiname} || $mgr->{User}{fullname} || "";
- if ($u->{secretemail}) {
- $umailset{qq{"$name" <$u->{secretemail}>}} = 1;
- } elsif ($u->{email}) {
- $umailset{qq{"$name" <$u->{email}>}} = 1;
- }
- if ($u->{userid} ne $mgr->{User}{userid}) {
- if ($mgr->{User}{secretemail}) {
- $umailset{qq{"$Uname" <$mgr->{User}{secretemail}>}} = 1;
- }elsif ($mgr->{User}{email}) {
- $umailset{qq{"$Uname" <$mgr->{User}{email}>}} = 1;
- }
- }
- $umailset{$PAUSE::Config->{ADMIN}} = 1;
- my @to = keys %umailset;
- my $header = {
- Subject => "Files of $u->{userid} scheduled for deletion"
- };
- $mgr->send_mail_multi(\@to,$header,$blurb);
- }
-
- my $submit_butts = qq{};
- push @m, $submit_butts;
- push @m, "
";
-
- my %files = $self->manifind;
- my(%deletes,%whendele,$sth);
- if (
- $sth = $dbh->prepare(qq{SELECT deleteid, changed
- FROM deletes
- WHERE deleteid
- LIKE ?}) #}
- and
- $sth->execute("$userhome/%")
- and
- $sth->rows
- ) {
- my $dhash;
- while ($dhash = $mgr->fetchrow($sth, "fetchrow_hashref")) {
- $dhash->{deleteid} =~ s/\Q$userhome\E\///;
- $deletes{$dhash->{deleteid}}++;
- $whendele{$dhash->{deleteid}} = $dhash->{changed};
- }
- }
- $sth->finish if ref $sth;
-
- require HTTP::Date;
- foreach my $f (keys %files) {
- unless (stat $f) {
- warn "ALERT: Could not stat f[$f]: $!";
- next;
- }
- my $blurb = $deletes{$f} ?
- $self->scheduled($whendele{$f}) :
- HTTP::Date::time2str((stat _)[9]);
- $files{$f} = sprintf " %-50s %7d %s", $f, -s _, $blurb;
- }
-
- chdir $cwd or die;
-
- my $field = $mgr->checkbox_group(
- name => 'pause99_delete_files_FILE',
- 'values' => [sort keys %files],
- linebreak => 'true',
- labels => \%files
- );
- $field =~ s! \s*!\n!gs;
-
- push @m, $field;
- push @m, "
";
- push @m, $submit_butts;
-
- @m;
-}
-
-sub show_files {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
- my @m;
- my $u = $self->active_user_record($mgr);
- $mgr->prefer_post(1);
- require ExtUtils::Manifest;
- require HTTP::Date;
- my $dbh = $mgr->connect;
- local($dbh->{RaiseError}) = 0;
- my $userhome = PAUSE::user2dir($u->{userid});
- push @m, qq{
}]);
- }
-
- } else {
-
- # Not a mailinglist: Compose Welcome
-
- $subject = qq{Welcome new user $userid};
- $need_onetime = 1;
- # not for mailing lists
- if ($need_onetime) {
-
- my $onetime = sprintf "%08x", rand(0xffffffff);
-
- my $sql = qq{INSERT INTO $PAUSE::Config->{AUTHEN_USER_TABLE} (
- $PAUSE::Config->{AUTHEN_USER_FLD},
- $PAUSE::Config->{AUTHEN_PASSWORD_FLD},
- secretemail,
- forcechange,
- changed,
- changedby
- ) VALUES (
- ?,?,?,?,?,?
- )};
- my $pwenc = PAUSE::Crypt::hash_password($onetime);
- my $dbh = $mgr->authen_connect;
- local($dbh->{RaiseError}) = 0;
- my $rc = $dbh->do($sql,undef,$userid,$pwenc,$email,1,time,$mgr->{User}{userid});
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR =>
- [qq{
Query [$sql] failed. Reason:
$DBI::errstr
}.
- qq{
This is very unfortunate as we have no option to rollback.}.
- qq{The user is now registered in mod.users and could not be regi}.
- qq{stered in authen_pause.$PAUSE::Config->{AUTHEN_USER_TABLE}
}]
- ) unless $rc;
- $dbh->disconnect;
- my $otpwblurb = qq{
-
-(This mail has been generated automatically by the Perl Authors Upload
-Server on behalf of the admin $PAUSE::Config->{ADMIN})
-
-As already described in a separate message, you\'re a registered Perl
-Author with the userid $userid. For the sake of approval I have
-assigned to you a change-password-only-password that enables
-you to pick your own password. This password is \"$onetime\"
-(without the enclosing quotes). Please visit
-
- https://pause.perl.org/pause/authenquery?ACTION=change_passwd
-
-and use this password to initialize your account in the authentication
-database. Once you have entered your password there, your one-time
-password is expired automatically. If you cannot connect to the above
-URL, you can replace 'https' with 'http', but then you are not using
-SSL encryption. Be careful to always use an SSL connection if
-possible, otherwise your password can be intercepted by third parties.
-
-Thanks & Regards,
---
-$PAUSE::Config->{ADMIN}
-};
-
- my $header = {
- Subject => $subject,
- };
- warn "header[$header]otpwblurb[$otpwblurb]";
- $mgr->send_mail_multi([$email,$PAUSE::Config->{ADMIN}],
- $header,
- $otpwblurb);
-
- }
-
- @blurb = qq{
-Welcome $fullname,
-
-PAUSE, the Perl Authors Upload Server, has a userid for you:
-
- $userid
-
-Once you\'ve gone through the procedure of password approval (see the
-separate mail you should receive about right now), this userid will be
-the one that you can use to upload your work or edit your credentials
-in the PAUSE database.
-
-This is what we have stored in the database now:
-
- Name: $fullname
- email: CENSORED
- homepage: $homepage
- enteredby: $mgr->{User}{fullname}
-
-Please note that your email address is exposed in various listings and
-database dumps. You can register with both a public and a secret email
-if you want to protect yourself from SPAM. If you want to do this,
-please visit
- https://pause.perl.org/pause/authenquery?ACTION=edit_cred
-or
- http://pause.perl.org/pause/authenquery?ACTION=edit_cred
-
-If you need any further information, please visit
- \$CPAN/modules/04pause.html.
-If this doesn't answer your questions, contact modules\@perl.org.
-
-Thank you for your prospective contributions,
-The PAUSE Team
-};
-
- my($memo) = $req->param('pause99_add_user_memo');
- push @blurb, "\nNote from $mgr->{User}{fullname}:\n$memo\n\n"
- if length $memo;
- }
-
- # both users and mailing lists run this code
-
- warn "DEBUG: UPLOAD[$PAUSE::Config->{UPLOAD}]";
- my(@to) = @{$PAUSE::Config->{ADMINS}};
- push @m, qq{ Sending separate mails to:
-}, join(" AND ", @to, $email), qq{
-
A PAUSE account is only required to distribute and manage Perl module
- distributions on CPAN. You do not need a PAUSE account to submit
- bug reports to RT or participate
- in many Perl community sites — please register a
- Bitcard account instead.
- };
-
- my $req = $mgr->{REQ};
- $mgr->prefer_post(1);
-
- # first time: form
- # second time with error: error message + form
- # second time without error: OK message
- # bot debunked? => "Thank you!"
-
- my $showform = 0;
- my $regOK = 0;
-
- if ($req->param('url')) { # debunked
- return "Thank you!";
- }
- my $fullname = $req->param( 'pause99_request_id_fullname') || "";
- my $ufullname = $mgr->any2utf8($fullname);
- if ($ufullname ne $fullname) {
- $req->parameters->set("pause99_request_id_fullname", $ufullname);
- $fullname = $ufullname;
- }
- my $email = $req->param( 'pause99_request_id_email') || "";
- my $homepage = $req->param( 'pause99_request_id_homepage') || "";
- my $userid = $req->param( 'pause99_request_id_userid') || "";
- my $rationale = $req->param("pause99_request_id_rationale") || "";
- my $urat = $mgr->any2utf8($rationale);
- if ($urat ne $rationale) {
- $req->parameters->set("pause99_request_id_rationale", $urat);
- $rationale = $urat;
- }
- warn sprintf(
- "userid[%s]Valid_Userid[%s]args[%s]",
- $userid,
- $Valid_Userid,
- scalar($req->uri->query)||"",
- );
-
- if ( $req->param("SUBMIT_pause99_request_id_sub") ) {
- # check for errors
-
- my @errors = ();
- if ( $fullname ) {
- unless ($fullname =~ /[ ]/) {
- push @errors, "Name does not look like a full civil name. Please accept our apologies if you believe we're wrong. In this case please write to @{$PAUSE::Config->{ADMINS}}.";
- }
- } else {
- push @errors, "You must supply a name\n";
- }
- unless( $email ) {
- push @errors, "You must supply an email address\n";
- }
- if ( $rationale ) {
-
- $rationale =~ s/^\s+//;
- $rationale =~ s/\s+$//;
- $rationale =~ s/\s+/ /;
- push @errors, "Thank you for giving us a short description of
- what you're planning to contribute, but frankly, this looks a
- bit too short" if length($rationale)<10;
- push @errors, "Please do not use HTML links in your description of
- what you're planning to contribute" if $rationale =~ /<\s*a\s+href\s*=/ims;
-
- my $url_count =()= $rationale =~ m{https?://}gi;
- push @errors, "Please do not include more than one URL in your description of
- what you're planning to contribute" if $url_count > 1;
-
- } else {
-
- push @errors, "You must supply a short description of what
- you're planning to contribute\n";
-
- }
- if ( $userid ) {
- $userid = uc $userid;
- $req->parameters->set('pause99_request_id_userid', $userid);
- my $db = $mgr->connect;
- my $sth = $db->prepare("SELECT userid FROM users WHERE userid=?");
- $sth->execute($userid);
- warn sprintf("userid[%s]Valid_Userid[%s]matches[%s]",
- $userid,
- $Valid_Userid,
- $userid =~ $Valid_Userid || "",
- );
- if ($sth->rows > 0) {
- my $euserid = $mgr->escapeHTML($userid);
- push @errors, "The userid $euserid is already taken.";
- } elsif ($userid !~ $Valid_Userid) {
- my $euserid = $mgr->escapeHTML($userid);
- push @errors, "The userid $euserid does not match $Valid_Userid.";
- }
- $sth->finish;
- } else {
- push @errors, "You must supply a desired user-ID\n";
- }
-
- if( @errors ) {
- push @m, qq{
\n";
- foreach my $arr (
- {
- topic => 'Your full name (civil name)',
- fname => 'pause99_request_id_fullname',
-
- fcomment => "Unicode Characters OK.",
- footnote => "Note: You can enter fairly free-form text here but it must consist of at least two space-separated words. This is a spam protection measure we discovered accidentally. Back when PAUSE was developed in the nineties, people would generally fill out a field asking for a full name with a first name and a second name, like Ben Cartwright or Tony Nelson. When this trivial expectation was coded into the server as a sanity check, it turned out to block many spam bots because they often did not try to enter a space in the middle of the field. It was only around 2003 that people started complaining that they had tried Peter and it did not work. Apologies for insisting, Peter – but feel free to make something up to satisfy the requirement.",
-
- },
- {
- topic => 'Email',
- fname => 'pause99_request_id_email',
- fcomment => 'required, otherwise we cannot send you the password',
- },
- {
- topic => 'Web site',
- fname => 'pause99_request_id_homepage',
- fcomment => 'optional'
- },
- {
- topic => 'Desired ID',
- fname => 'pause99_request_id_userid',
- fcomment => "3-9 characters matching [A-Z], please",
-
- },
- ) {
- $alt ^= 1;
- my $altname = $alt ? "alternate1" : "alternate2";
- push @m, qq{
-
-}; #};
- $header = {
- Subject => $subject
- };
- warn "To[@to]Subject[$header->{Subject}]";
- $mgr->send_mail_multi(\@to,$header,$blurb);
- }
-
- return @m;
-}
-
-sub mailpw {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m,$param,$email);
- my $req = $mgr->{REQ};
-
- # TUT: We reach this point in the code only if the Querystring
- # specified ACTION=mailpw or something equivalent. The parameter ABRA
- # is used to denote the token that we might have sent them.
- my $abra = $req->param("ABRA") || "";
- push @m, qq{};
-
- # TUT: The parameter pause99_mailpw_1 denotes the userid of the user
- # for whom a password change was requested. Note that anybody has
- # access to that parameter, we do not authentify its origin. Of
- # course not, because that guy says he has lost the password:-) If
- # this parameter is there, we are asked to send a token. Otherwise
- # they only want to see the password-requesting form.
- $param = $req->param("pause99_mailpw_1");
- if ( $param ) {
- $param = uc($param);
- unless ($param =~ /^[A-Z\-]+$/) {
- if ($param =~ /@/) {
- die PAUSE::HeavyCGI::Exception->new(ERROR =>
- qq{Please supply a userid, not an email address.});
- }
- die PAUSE::HeavyCGI::Exception->new(ERROR =>
- sprintf qq{A userid of %s
- is not allowed, please retry with a valid userid. Nothing done.}, $mgr->escapeHTML($param));
- }
-
- # TUT: The object $mgr is our knows/is/can-everything object. Here
- # it connects us to the authenticating database
- my $authen_dbh = $mgr->authen_connect;
- my $sql = qq{SELECT *
- FROM usertable
- WHERE user = ? };
- my $sth = $authen_dbh->prepare($sql);
- $sth->execute($param);
- my $rec = {};
- if ($sth->rows == 1) {
- $rec = $mgr->fetchrow($sth, "fetchrow_hashref");
- } else {
- my $u;
- eval {
- $u = $self->active_user_record($mgr,$param);
- };
- if ($@) {
- die PAUSE::HeavyCGI::Exception->new(ERROR =>
- qq{Cannot find a userid
- of $param, please
- retry with a valid
- userid.});
-
- } elsif ($u->{userid} && $u->{email}) {
- # this is one of the 94 users (counted on 2005-01-05) that has
- # a users record but no usertable record
- $sql = qq{INSERT INTO usertable (user,secretemail,forcechange,changed)
- VALUES (?, ?, 1, ?)};
-
- $authen_dbh->do($sql,{},$u->{userid},$u->{email},time)
- or die PAUSE::HeavyCGI::Exception->new(ERROR =>
- qq{The userid of $param
- is too old for this interface. Please get in touch with administration.});
-
- $rec->{secretemail} = $u->{email};
- } else {
- die PAUSE::HeavyCGI::Exception->new(ERROR =>
- qq{A userid of $param
- is not known, please retry with a valid userid.});
- }
- }
-
- # TUT: all users may have a secret and a public email. We pick what
- # we have.
- unless ($email = $rec->{secretemail}) {
- my $u = $self->active_user_record($mgr,$param,{hidden_user_ok => 1});
- require YAML::Syck; print STDERR "Line " . __LINE__ . ", File: " . __FILE__ . "\n" . YAML::Syck::Dump({u=>$u}); # XXX
-
- $email = $u->{email};
- }
- if ($email) {
-
- # TUT: Before we insert a record from that table, we remove old
- # entries so the primary key of an old record doesn't block us now.
- $sql = sprintf qq{DELETE FROM abrakadabra
- WHERE NOW() > expires};
- $authen_dbh->do($sql);
-
- my $passwd = sprintf "%08x" x 4, rand(0xffffffff), rand(0xffffffff),
- rand(0xffffffff), rand(0xffffffff);
- # warn "pw[$passwd]";
- my $then = time + $PAUSE::Config->{ABRA_EXPIRATION};
- $sql = sprintf qq{INSERT INTO abrakadabra
- ( user, chpasswd, expires )
- VALUES
- ( ?, ?, from_unixtime(?) ) };
- local($authen_dbh->{RaiseError}) = 0;
- if ( $authen_dbh->do($sql,undef,$param,$passwd,$then) ) {
- } elsif ($authen_dbh->errstr =~ /Duplicate entry/) {
- my $duration;
- if ($HAVE_TIME_DURATION) {
- $duration = Time::Duration::duration($PAUSE::Config->{ABRA_EXPIRATION});
- } else {
- $duration = sprintf "%d seconds", $PAUSE::Config->{ABRA_EXPIRATION};
- }
- die PAUSE::HeavyCGI::Exception->new
- (
- ERROR => sprintf(
- qq{A token for $param that allows
- changing of the password has been requested recently
- (less than %s ago) and is still valid. Nothing
- done.},
- $duration,
- ),
- );
- } else {
- die PAUSE::HeavyCGI::Exception->new(ERROR => $authen_dbh->errstr);
- }
-
- # TUT: a bit complicated only because we switched back and forth
- # between Apache::URI and URI::URL
- my $myurl = $mgr->myurl;
- my $me;
- if ($myurl->can("unparse")) {
- $me = $myurl->unparse;
- $me =~ s/\?.*//;
- } else {
- $me = $myurl->as_string;
- }
- $me =~ s/^http:/https:/; # do not blindly inherit the schema
- my $mailblurb = qq{
-
-(this an automatic mail sent by a program because somebody asked for
-it. If you did not intend to get it, please let us know and we will
-take more precautions to prevent abuse.)
-
-Somebody, probably you, has visited the URL
-
- $me?ACTION=mailpw
-
-and asked that you, "$param", should get a token that enables the
-setting of a new password. Here it is (please watch out for line
-wrapping errors of your mail reader and other cut and paste errors,
-this URL must not contain any spaces):
-
- $me?ACTION=change_passwd;ABRA=$param.$passwd
-
-Please visit this URL, it should open you the door to a password
-changer that lets you set a new password for yourself. This token
-will expire within a few hours. If you don't need it, do nothing. By
-the way, your old password is still valid.
-
-$Yours};
- my $header = { Subject => "Your visit at $me" };
- warn "mailto[$email]mailblurb[$mailblurb]";
- $mgr->send_mail_multi([$email], $header, $mailblurb);
-
- push @m, qq{
-
-
A token to change the password for $param is on its way to its
- owner. Should the mail not arrive, please tell us.
-
-};
- return @m; # no need to repeat form
-
- } else {
- push @m, sprintf qq{
-
-
We have not found the email of $param. Please try with a different
- name or mail to the administrator directly.
-
-};
-
- }
- return @m;
- }
-
- # TUT: First time here, send them the password requesting form
- push @m, qq{
-
-
This form lets you request a token that enables you to set a new
-password. It only operates correctly if the database knows you and
-your email adress. Please fill in your userid on the CPAN. The token
-will be mailed to that userid.
-
- From: andreas.koenig@anima.de (Andreas J. Koenig)
- To: kstar@chapin.edu
- Subject: Re: [elagache@ipn.caida.org: No email found for CAIDA? (Re: Missing CAIDA password?)]
- Date: 02 Nov 2000 17:59:28 +0100
-
- A mailing list occupies the same namespace as users because we do
- not want that users and mailing lists get confused. But a mailing
- list does not have a password and does not have a directory of its
- own. Only people can upload and occupy a directory and have a
- password. (It's clear that the user namespace is not related to the
- modules namespace, right?)
-
- The Module List may list a mailinglist as "the contact", so the
- field userid in the table mods identifies either a mailing list or
- a user. This has been useful in the past when several clueful
- people represent several related modules and use a common mailing
- list as the contact.
-
- The table list2user maps mailing lists to their owners so that the
- owners can edit the data associated with the mailing list like
- address and comment. The table list2user does not have a web
- interface because we are not really established as the primary
- source for mailing list information and so it has not been used
- much. But I'm open to offer one if you believe it's useful.
- [...]
-
-};
-
- my $req = $mgr->{REQ};
- my $selectedid = "";
- my $selectedrec = {};
- my $u = $self->active_user_record($mgr);
- push @m, qq{};
- my $param;
- if ($param = $req->param("pause99_edit_ml_3")) { # upper selectbox
- $selectedid = $param;
- } elsif ($param = $req->param("HIDDENNAME")) {
- $selectedid = $param;
- $req->parameters->set("pause99_edit_ml_3",$param);
- }
- warn sprintf(
- "selectedid[%s]IsMR[%s]",
- $selectedid,
- join(":",
- keys(%{$mgr->{IsMailinglistRepresentative}})
- )
- );
- my($sql,@bind);
- if (exists $mgr->{IsMailinglistRepresentative}{$selectedid}) {
- $sql = qq{SELECT users.userid
- FROM users JOIN list2user
- ON users.userid = list2user.maillistid
- WHERE users.isa_list > ''
- AND list2user.userid = ?
- ORDER BY users.userid
-};
- @bind = $mgr->{User}{userid};
- } else {
- $sql = qq{SELECT userid FROM users WHERE isa_list > '' ORDER BY userid};
- @bind = ();
- }
- my $dbh = $mgr->connect;
- my $sth = $dbh->prepare($sql);
- $sth->execute(@bind);
- my @all_mls;
- my %mls_lab;
- if ($sth->rows) {
- my $sth2 = $dbh->prepare(qq{SELECT * FROM maillists WHERE maillistid=?});
- while (my($id) = $mgr->fetchrow($sth, "fetchrow_array")) {
- # register this mailinglist for the selectbox
- push @all_mls, $id;
- # query for more info about it
- $sth2->execute($id);
- my($rec) = $mgr->fetchrow($sth2, "fetchrow_hashref");
- # we will display the name along the ID
- $mls_lab{$id} = "$id ($rec->{maillistname})";
- if ($id eq $selectedid) {
- # if this is the selected one, we just store it immediately
- $selectedrec = $rec;
- }
- }
- }
- my $size = @all_mls > 18 ? 15 : scalar(@all_mls);
- push @m, $mgr->scrolling_list(
- 'name' => "pause99_edit_ml_3",
- 'values' => \@all_mls,
- 'labels' => \%mls_lab,
- 'size' => $size,
- );
- push @m, qq{
};
- if ($selectedid) {
- push @m, qq{
Record for $selectedrec->{maillistid}
\n};
- my @m_mlrec;
- my $force_sel = $req->param('pause99_edit_ml_2');
- my $update_sel = $req->param('pause99_edit_ml_4');
- my %meta = (
- maillistname => {
-
- headline => "The name of the mailing list",
-
- note => "The name appears in the CPAN
- authors list, so it is good if
- the name contains the term
- mailing list or something
- equivalent",
-
- type => "textfield",
- args => {
- size => 50,
- maxsize => 64,
- }
- },
- address => {
-
- headline => "The address of the
- mailing list",
-
- note => "This is the address where
- people post to (where all members
- of the group can be contacted)",
-
- type => "textfield",
- args => {
- size => 50,
- }
- },
- subscribe => {
- headline => "How to subscribe",
-
- note => "This is a text that
- describes how to join the mailing
- list. E.g. the mailing list
- subscribe address or a URL with
- more details.",
-
- type => "textarea",
- args => {
- rows => 5,
- cols => 60,
- }
- },
- );
- my $mailblurb = qq{Record update in the PAUSE mailinglists database:
-
-};
- my($mailsprintf1,$mailsprintf2,$saw_a_change);
- $mailsprintf1 = "%12s: [%s]%s";
- $mailsprintf2 = " was [%s]\n";
- my $now = time;
-
- $mailblurb .= sprintf($mailsprintf1, "userid", $selectedrec->{maillistid}, "\n");
-
- for my $field (qw(maillistname address subscribe)) {
- my $headline = $meta{$field}{headline} || $field;
- my $note = $meta{$field}{note};
- push @m_mlrec, sprintf qq{
";
- $mailblurb .= qq{
-Data entered by $mgr->{User}{fullname}.
-Please check if they are correct.
-
-$Yours};
- my @to = ($u->{secretemail}||$u->{email}, $mgr->{MailtoAdmins});
- warn "sending to[@to]";
- warn "mailblurb[$mailblurb]";
- my $header = {
- Subject => "Mailinglist update for $selectedrec->{maillistid}"
- };
- $mgr->send_mail_multi(\@to, $header, $mailblurb);
- } elsif ($update_sel) { # it should have been updated but wasn't?
-
- push @m, "
It seems to me the record was NOT updated. Maybe
-nothing changed? Please take a closer look and inform an admin if
-things didn't proceed as expected.
";
-
- }
- push @m, @m_mlrec;
- }
- @m;
-}
-
-sub edit_mod {
- my $self = shift;
- my $mgr = shift;
- $mgr->prefer_post(0);
- my(@m);
- my $req = $mgr->{REQ};
- my $selectedid = "";
- my $selectedrec = {};
- my $u = $self->active_user_record($mgr);
- my @to = $mgr->{MailtoAdmins};
- if ($u->{cpan_mail_alias} =~ /^(publ|secr)$/
- &&
- time - ($u->{introduced}||0) > 86400
- ) {
- $to[0] .= sprintf ",%s\@cpan.org", lc $u->{userid};
- # warn qq{Prepared to send mail to: @to};
- } else {
- # we have nothing else, so we must send separate mail
- my $user_email = $u->{secretemail};
- $user_email ||= $u->{email};
- push @to, $user_email if $user_email;
- warn qq{Prepared to send separate mails to: }, join(" AND ",
- map { "[$_]" } @to);
- }
-
- push @m, qq{};
- if (my $param = $req->param("pause99_edit_mod_3")) { # upper selectbox
- $selectedid = $param;
- }
-
- push @m, qq{
-
-
The select box shows all the modules that have been
- registered for user $u->{userid} officially via
- modules\@perl.org, i.e. that are included (or about to be
- included) in the module list.
If you are missing a
- module of yours, maybe you have never registered it?
- Consider registering and visit the Register Namespace page. If
- you are missing certain other pieces, please let
- modules\@perl.org know, see modules/04pause.html
- on CPAN for details.
You can edit the infos
- stored in the database on this page. The changes you make
- will take effect when the next module list will be
- released. Thank you for your help!
-
-};
-
- my $dbh = $mgr->connect;
- if (0) {
- warn sprintf(
- "selectedid[%s]IsMailinglistRepr[%s]",
- $selectedid,
- join(":",
- keys(%{$mgr->{IsMailinglistRepresentative}})
- )
- );
- }
- my($sth);
- if ($selectedid and exists $mgr->{IsMailinglistRepresentative}{$selectedid}) {
- my $sql = qq{SELECT modid
- FROM mods, list2user
- ON mods.userid = list2user.maillistid
- WHERE mods.userid=?
- AND list2user.userid = ?
- ORDER BY modid};
- my @bind = ($selectedid, $mgr->{User}{userid});
- $sth = $dbh->prepare($sql);
- my $ret = $sth->execute(@bind);
- } else {
- my $sql = qq{SELECT modid
- FROM mods
- WHERE userid=?
- ORDER BY modid};
- my @bind = $u->{userid};
- $sth = $dbh->prepare($sql);
- my $ret = $sth->execute(@bind);
- }
- my @all_mods;
- my $is_only_one;
- if (my $rows = $sth->rows) {
- while (my($id) = $mgr->fetchrow($sth, "fetchrow_array")) {
- # register this mailinglist for the selectbox
- push @all_mods, $id;
- if ($rows == 1) {
- # if this is the selected one, we just store it immediately
- $selectedid = $id;
- $is_only_one++;
- }
- if ($id eq $selectedid) {
- my $sth2 = $dbh->prepare(qq{SELECT *
- FROM mods
- WHERE modid=?
- AND userid=?});
- $sth2->execute($id,$u->{userid});
- my($rec) = $mgr->fetchrow($sth2, "fetchrow_hashref");
- $selectedrec = $rec;
- }
- }
- }
- my $all_mods = scalar @all_mods;
- my $size = $all_mods > 18 ? 15 : $all_mods;
- unless ($size) {
-
- push @m, qq{
Sorry, there are no modules registered belonging to
- $u->{userid}. Please note, only modules that are
- already registered in the module list can be edited
- here. If you believe, this is a bug, please contact
- @{$PAUSE::Config->{ADMINS}}.
More
- about the meaning of the DSLIP status in the module
- list. To delete, add or rename an entry, mail to
- modules\@perl.org.
};
-
- my @m_modrec;
- my $force_sel = $req->param('pause99_edit_mod_2');
- # || $is_only_one;
- my $update_sel = $req->param('pause99_edit_mod_4');
-
- my(@stat_meta) = $self->stat_meta;
- my(@chap_meta) = $self->chap_meta($mgr);
- my(@desc_meta) = $self->desc_meta;
-
- my %meta = (
- @stat_meta,
- @desc_meta,
- userid => {
- type => "textfield",
- headline => "CPAN User-ID",
-
- note => "If you change the userid, you will
- lose control over the module and
- the other userid will become the
- owner. That's a one way move, take
- care!",
-
- args => {
- size => 12,
- maxlength => 9,
- },
- },
- mlstatus => {
- type => "scrolling_list",
- headline => "Lifecycle",
-
- note => "Select one of list,
- hide, or delete,
- normal case is of course
- list. Select delete
- only if the module definitely has
- gone for some time. If the module
- has no public relevance and is
- not needed in the module list or
- if it is abandoned but might have
- a revival some day, maybe by
- being claimed by another author,
- please keep it for a while as
- hide.",
-
- args => {
- size => 1,
- values => [qw(list hide delete)],
- labels =>
- {
- list => "List in Module List",
- hide => "Hide from modulelist, but keep in database",
- delete=> "Can be deleted from database",
- },
- }
- },
- @chap_meta,
- );
- my $mailblurb = qq{Record update in the PAUSE modules database:
-
-};
- my($mailsprintf1,$mailsprintf2,$saw_a_change);
- $mailsprintf1 = "%12s: [%s]%s";
- $mailsprintf2 = " was [%s]\n";
- my $now = time;
- $mailblurb .= sprintf($mailsprintf1, "modid", $selectedrec->{modid}, "\n");
-
- my $alter = 0;
- for my $field (qw(
-statd
-stats
-statl
-stati
-statp
-description
-userid
-chapterid
-mlstatus
-)) {
- my $headline = $meta{$field}{headline} || $field;
- my $note = $meta{$field}{note} || "";
- $alter ^= 1;
- my $alterclass = $alter ? "alternate1" : "alternate2";
- push @m_modrec, qq{\n
$headline
};
- push @m_modrec, qq{$note } if $note;
- my $fieldtype = $meta{$field}{type};
- my $fieldname = "pause99_edit_mod_$field";
- if ($field =~ /^stat/) { # there are many blanks instead of
- # question marks, I believe
- if (0) {
- warn sprintf(
- "field[%s]value[%s]mfals[%s]",
- $field,
- $selectedrec->{$field},
- $meta{$field}{args}{labels}{$selectedrec->{$field}},
- );
- }
- $selectedrec->{$field} = "?" unless exists
- $meta{$field}{args}{labels}{$selectedrec->{$field}};
- } elsif ($field eq "chapterid") {
- die "chapterid not integer" if $strict_chapterid &&
- $selectedrec->{$field} !~ /^\d*$/;
- }
- if ($force_sel) {
- $req->parameters->set($fieldname, $selectedrec->{$field}||"");
- } elsif ($update_sel) {
- my $param = $req->param($fieldname);
- my $uparam = $mgr->any2utf8($param);
- if ($uparam ne $param) {
- $req->parameters->set($fieldname,$uparam);
- $param = $uparam;
- }
- if ($param ne $selectedrec->{$field}) {
- if ($field eq "userid") {
- # die if the user doesn't exist
- my $ucparam = uc $param;
- unless ($ucparam eq $param) {
- $param = $ucparam;
- $req->parameters->set($fieldname, $param);
- }
- my $nu = $self->active_user_record($mgr, $param, {checkonly => 1});
-
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => sprintf("Unknown user[%s]",
- $param,
- )) unless
- $nu->{userid} eq $param;
-
- # add the new user to @to
- if ($nu->{cpan_mail_alias} =~ /^(publ|secr)$/
- &&
- time - ($nu->{introduced}||0) > 86400
- ) {
- $to[0] .= sprintf ",%s\@cpan.org", lc $nu->{userid};
- push @m, qq{ Sending mail to: @to};
- } else {
- # we have nothing else, so we must send separate mail
- my $nuser_email = $nu->{secretemail};
- $nuser_email ||= $nu->{email};
- push @to, $nuser_email if $nuser_email;
- push @m, qq{ Sending separate mails to: }, join(" AND ",
- map { "[$_]" } @to);
- }
- # Now also update primeur table. We can do that with an
- # update. If the record does not exist, we don't need it
- # updated anyway
- my $query = "UPDATE primeur SET userid=? WHERE package=? AND userid=?";
- my $ret = $dbh->do($query,{},$nu->{userid},$selectedrec->{modid},$u->{userid});
- $ret ||= 0;
- warn "INFO: Updated primeur with $nu->{userid},$selectedrec->{modid},$u->{userid} and ret[$ret]";
- } elsif ($field eq "description") {
- # Truncate if necessary, the database won't do it anymore
- substr($param,44) = "" if length($param)>44;
- } elsif ($field eq "chapterid") {
- die "param not integer" if $strict_chapterid &&
- ($selectedrec->{$field} !~ /^\d*$/ || $param !~ /^\d*$/);
- }
- $mailblurb .= sprintf($mailsprintf1,
- $field,
- $param,
- sprintf($mailsprintf2,$selectedrec->{$field})
- );
-
- my $sql = qq{UPDATE mods
- SET $field=?,
- changed=?,
- changedby=?
- WHERE modid=?};
-
- my $usth = $dbh->prepare($sql);
- my $ret = $usth->execute($param,
- $now,
- $mgr->{User}{userid},
- $selectedrec->{modid});
-
- $saw_a_change = 1 if $ret > 0;
- $usth->finish;
-
- } else {
-
- if ($field eq "chapterid") {
- die "illegal chapterid. selectedrec/field[$selectedrec->{$field}]".
- "param[$param]"
- if $strict_chapterid &&
- ($selectedrec->{$field} !~ /^\d*$/ || $param !~ /^\d*$/);
- }
- $mailblurb .= sprintf($mailsprintf1,
- $field,
- $selectedrec->{$field},
- "\n"
- );
- }
- } elsif ($is_only_one) {
- # as if they had selected it already
- $req->parameters->set($fieldname, $selectedrec->{$field}||"");
- }
- push @m_modrec, $mgr->$fieldtype(
- 'name' => $fieldname,
- 'value' => $selectedrec->{$field},
- %{$meta{$field}{args} || {}}
- );
- push @m_modrec, qq{
";
- $mailblurb .= qq{
-Data entered by $mgr->{User}{fullname} ($mgr->{User}{userid}).
-Please check if they are correct.
-
-$Yours};
- push @to, $mgr->{User}{secretemail}||$mgr->{User}{email}
- unless $mgr->{User}{userid} eq $u->{userid};
- warn sprintf "sending to[%s]", join(" AND ",@to);
- warn "mailblurb[$mailblurb]";
- my $header = {
- Subject => "Module update for $selectedrec->{modid}"
- };
- $mgr->send_mail_multi(\@to, $header, $mailblurb);
- } elsif ($update_sel) { # it should have been updated but wasn't?
-
- push @m, "It seems to me the record was NOT updated. Maybe
- nothing has changed? Please take a closer look and inform an admin if
- things didn't proceed as expected. ";
-
- }
- push @m, @m_modrec;
- return @m;
-}
-sub edit_uris {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m);
- my $req = $mgr->{REQ};
- my $selectedid = "";
- my $selectedrec = {};
- if (my $param = $req->param("pause99_edit_uris_3")) { # upper selectbox
- $selectedid = $param;
- }
- my $u = $self->active_user_record($mgr);
- push @m, qq{};
-
- push @m, qq{
for user $u->{userid}
};
- my $dbh = $mgr->connect;
- my $sql = qq{SELECT uriid
- FROM uris
- WHERE dgot=''
- AND userid=?
- ORDER BY uriid};
- my $sth = $dbh->prepare($sql);
- $sth->execute($u->{userid});
- my @all_recs;
- my %labels;
- if (my $rows = $sth->rows) {
- my $sth2 = $dbh->prepare(qq{SELECT *
- FROM uris
- WHERE dgot=''
- AND dverified=''
- AND uriid=?
- AND userid=?});
- while (my($id) = $mgr->fetchrow($sth, "fetchrow_array")) {
- # register this mailinglist for the selectbox
- push @all_recs, $id;
- # query for more info about it
- $sth2->execute($id,$u->{userid}); # really needed only for the
- # record we want to edit, but
- # maybe also needed for a
- # label in the selectbox
- my($rec) = $mgr->fetchrow($sth2, "fetchrow_hashref");
- # we will display the name along the ID
- # $labels{$id} = "$id ($rec->{userid})";
- $labels{$id} = $id; # redundant, but flexible
- if ($rows == 1 || $id eq $selectedid) {
- # if this is the selected one, we just store it immediately
- $selectedid = $id;
- $selectedrec = $rec;
- }
- }
- } else {
- return "
-};
- my @m_rec;
- my $force_sel = $req->param('pause99_edit_uris_2');
- my $update_sel = $req->param('pause99_edit_uris_4');
-
- my %meta =
- (
- uri =>
- {
- type => "textfield",
- headline => "URI to download",
- args => {
- size => 60,
- maxlength => 255,
- },
-
- note => qq{If you change this field to a different URI,
- PAUSE will try to fetch this URI instead. Note that the
- filename on PAUSE will remain unaltered. So you can fix a
- typo, but you cannot alter the name of the uploaded file, it
- will be the original filename. So this is only an opportunity
- to fix broken uploads that cannot be completed, not an
- opportunity to turn the time back.
-
-
To re-iterate: If you change the content of this field to
- http://www.slashdot.org/, PAUSE will fetch the current
- Slashdot page and will put it into
- $selectedrec->{uriid}. If you change it to
- FooBar-3.14.tar.gz, PAUSE will try to get
- $PAUSE::Config->{INCOMING}/FooBar-3.14.tar.gz and if it
- finds it, it puts it into $selectedrec->{uriid}.
-
-
An example: if you made a typo and requested to upload
- http://badsite.org/foo instead of
- http://goodsite.org/foo, just correct the thing in the
- textfield below.
-
-
Another example: If your upload was unsuccessful and you now have
- a bad file in the incoming directory, then you have the
- problem that PAUSE tries to fetch your file (say foo)
- but doesn't succeed and then it retries and retries. Your
- solution: transfer the file into the incoming directory with
- a different name (say bar) using ftp. Fill in
- the different name below. PAUSE will fetch bar and
- upload it as foo. So you're done.
}
-
- },
- nosuccesstime => {
-
- headline => "UNIX time of last
- unsuccessful attempt to retrieve
- this item",
-
- },
- nosuccesscount => {
-
- headline=>"Number of unsuccessful
- attempts so far",
-
- },
- changed => {
- headline => "Record was last changed on",
- },
- changedby => {
- headline => "Record was last changed by",
- },
- );
- my $mailblurb = qq{Record update in the PAUSE uploads database:
-
-};
- my($mailsprintf1,$mailsprintf2,$saw_a_change);
- $mailsprintf1 = "%12s: [%s]%s";
- $mailsprintf2 = " was [%s]\n";
- my $now = time;
- $mailblurb .= sprintf($mailsprintf1, "uriid", $selectedrec->{uriid}, "\n");
-
- for my $field (qw(
-uri
-nosuccesstime
-nosuccesscount
-changed
-changedby
-)) {
- my $headline = $meta{$field}{headline} || $field;
- my $note = $meta{$field}{note} || "";
- push @m_rec, qq{
$headline
};
- push @m_rec, qq{$note } if $note;
- my $fieldtype = $meta{$field}{type};
- my $fieldname = "pause99_edit_uris_$field";
- if ($force_sel) {
- $req->parameters->set($fieldname, $selectedrec->{$field}||"");
- } elsif ($update_sel && $fieldtype) {
- my $param = $req->param($fieldname);
- if ($param ne $selectedrec->{$field}) {
- $mailblurb .= sprintf($mailsprintf1,
- $field,
- $param,
- sprintf($mailsprintf2,$selectedrec->{$field})
- );
-
- # no, we do not double check for user here. What if they
- # change the owner? And we do not prepare outside the loop
- # because the is a $fields in there
- my $sql = qq{UPDATE uris
- SET $field=?,
- changed=?,
- changedby=?
- WHERE uriid=?};
-
- my $usth = $dbh->prepare($sql);
- my $ret = $usth->execute($param,
- $now,
- $u->{userid},
- $selectedrec->{uriid});
-
- $saw_a_change = 1 if $ret > 0;
- $usth->finish;
-
- } else {
- $mailblurb .= sprintf($mailsprintf1, $field, $selectedrec->{$field}, "\n");
- }
- }
- if ($fieldtype) {
- warn "fieldtype[$fieldtype]fieldname[$fieldname]field[$field]rec->{field}[$selectedrec->{$field}]";
- push @m_rec, $mgr->$fieldtype(
- 'name' => $fieldname,
- 'value' => $selectedrec->{$field},
- %{$meta{$field}{args} || {}}
- );
- } else {
- # not editable fields
- push @m_rec, sprintf "%s \n", $selectedrec->{$field}||0;
- }
- push @m_rec, qq{ \n};
- }
- push @m_rec, qq{ };
-
- if ($saw_a_change) {
- push @m, "
The record has been updated in the database
";
- $mailblurb .= qq{
-Data entered by $mgr->{User}{fullname} ($mgr->{User}{userid}).
-Please check if they are correct.
-
-$Yours};
- my @to = ($u->{secretemail}||$u->{email}, $mgr->{MailtoAdmins});
- push @to, $mgr->{User}{secretemail}||$mgr->{User}{email};
- warn "sending to[@to]";
- warn "mailblurb[$mailblurb]";
- my $header = {
- Subject => "Uri update for $selectedrec->{uriid}"
- };
- $mgr->send_mail_multi(\@to,$header,$mailblurb);
- } elsif ($update_sel) { # it should have been updated but wasn't?
- push @m, "It seems to me the record was NOT updated. Maybe nothing has changed?
- Please take a closer look and
- inform an admin if things didn't proceed as expected. ";
- }
- push @m, @m_rec;
- }
- @m;
-}
-
-sub show_ml_repr {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m);
- my $dbh = $mgr->connect;
- my $sth = $dbh->prepare("SELECT maillistid, userid
- FROM list2user
- ORDER BY maillistid, userid");
- $sth->execute;
-
- push @m, qq{
These are the contents of the table list2user.
- There\'s currently no way to edit the table except
- direct SQL. The table says who is representative of a
- mailing list.
\n};
- @m;
-}
-
-
-
-sub add_mod {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m);
- my $req = $mgr->{REQ};
-
- my $dbh = $mgr->connect;
- local($dbh->{RaiseError}) = 0;
-
- my %meta = ($self->modid_meta,
- $self->chap_meta($mgr),
- $self->stat_meta,
- $self->desc_meta,
- $self->user_meta($mgr));
-
- $meta{modid}{note} = qq{Modulename or a complete line in module list
- format. The latter is only valid for the
- guess button.};
-
- $meta{comment} = {
- type => "textarea",
- note => "only for the mail, not for the database",
- args => {
- rows => 5,
- cols => 60,
- }
- };
-
- if ($req->param("USERID")) {
- my $session = $mgr->session;
- my $s = $session->{APPLY};
- for my $a (keys %$s) {
- $req->parameters->set("pause99_add_mod_$a", $s->{$a});
- warn "retrieving from session a[$a]s(a)[$s->{$a}]";
- }
- }
-
- my @errors = ();
- my @hints = ();
- my($guessing,$modid);
- if ( $req->param("SUBMIT_pause99_add_mod_hint") ) {
- $guessing++;
- my $wanted = {};
- $self->_add_mod_hint($mgr, $wanted, $dbh, \@hints);
- $modid = $wanted->{modid};
- } elsif ( $req->param("SUBMIT_pause99_add_mod_insertit") ) {
-
- $modid = $req->param('pause99_add_mod_modid')||"";
- if ($modid =~ /([^A-Za-z0-9_\:])/) {
- my $illegal = ord($1);
- push @errors, sprintf(qq{The module name contains the illegal character 0x%x.
- Please correct and retry.}, #},
- $illegal); #
- }
- unless (length($modid)) {
- push @errors, qq{The module name is missing.};
- }
- # $req->parameters->set("pause99_add_mod_modid", $modid) if $modid;
-
- my($chapterid) = $req->param('pause99_add_mod_chapterid');
- warn "chapterid[$chapterid]";
- die "chapterid not integer" if $strict_chapterid && $chapterid !~ /^\d*$/;
- warn "chapterid[$chapterid]";
- unless ($meta{chapterid}{args}{labels}{$chapterid}) {
- push @errors, qq{The chapterid [$chapterid] is not known.};
- }
- die "chapterid not integer" if $strict_chapterid && $chapterid !~ /^\d*$/;
- warn "chapterid[$chapterid]";
-
- my($statd) = $req->param('pause99_add_mod_statd');
- $req->parameters->set('pause99_add_mod_statd',$statd='?') unless $statd;
- unless ($meta{statd}{args}{labels}{$statd}) {
- push @errors, qq{The D status of the DSLIP [$statd] is not known.};
- }
-
- my($stats) = $req->param('pause99_add_mod_stats');
- $req->parameters->set('pause99_add_mod_stats',$stats='?') unless $stats;
- unless ($meta{stats}{args}{labels}{$stats}) {
- push @errors, qq{The S status of the DSLIP [$stats] is not known.};
- }
-
- my($statl) = $req->param('pause99_add_mod_statl');
- $req->parameters->set('pause99_add_mod_statl',$statl='?') unless $statl;
- unless ($meta{statl}{args}{labels}{$statl}) {
- push @errors, qq{The L status of the DSLIP [$statl] is not known.};
- }
-
- my($stati) = $req->param('pause99_add_mod_stati');
- $req->parameters->set('pause99_add_mod_stati',$stati='?') unless $stati;
- unless ($meta{stati}{args}{labels}{$stati}) {
- push @errors, qq{The I status of the DSLIP [$stati] is not known.};
- }
-
- my($statp) = $req->param('pause99_add_mod_statp');
- $req->parameters->set('pause99_add_mod_statp',$statp='?') unless $statp;
- unless ($meta{statp}{args}{labels}{$statp}) {
- # XXX for the first few weeks we allow statp to be empty
- # push @errors, qq{The P status of the DSLIP [$statp] is not known.};
- }
-
- # must be treated as utf8
- my($description) = $req->param('pause99_add_mod_description')||"";
- my $ud = $mgr->any2utf8($description);
- if ($ud ne $description) {
- $req->parameters->set('pause99_add_mod_description',$ud);
- $description = $ud;
- }
- $description =~ s/^\s+//;
- $description =~ s/\s+\z//;
- if (length($description)>44) {
- substr($description,44) = '';
- push @errors, qq{The description was too long and had to be truncated.};
- } elsif (not length($description)) {
- push @errors, qq{The description is missing.};
- }
- $req->parameters->set("pause99_add_mod_description", $description) if $description;
-
- my($userid) = $req->param('pause99_add_mod_userid');
- unless ($meta{userid}{args}{labels}{$userid}) {
- push @errors, qq{The userid [$userid] is not known.};
- }
-
- goto FORMULAR if @errors;
-
- my(@to,$subject,@blurb,$query,$sth,@qvars,@qbind);
- my $time = time;
-
- @qvars = qw( modid statd stats statl stati statp
- description userid
- chapterid introduced changed changedby );
-
- @qbind = ( $modid, $statd, $stats, $statl, $stati, $statp,
- $description, $userid,
- $chapterid, $time, $time, $mgr->{User}{userid} );
-
- $query = qq{INSERT INTO mods \(} .
- join(", ", @qvars) .
- qq{\) VALUES \(} . join(",",map {qq{?}} @qbind) . qq{)};
-
- push @m, qq{Submitting query: };
- if (0) { # too noisy for my taste
- push @m, qq{$query
-
-
param
bindvalue
-};
- for my $i (0..$#qvars) {
- push @m, qq{
}, $mgr->escapeHTML($qvars[$i]),
- qq{
}, $mgr->escapeHTML($qbind[$i]), qq{
\n};
- }
- push @m, qq{
\n};
- }
-
- unless ($dbh->do($query,undef,@qbind)) {
- my $err = $dbh->errstr;
- if ($err =~ /duplicate/i) {
- $sth = $dbh->prepare("SELECT userid
- FROM mods
- WHERE modid=?");
- $sth->execute($modid);
- my $otheruser = $mgr->fetchrow($sth, "fetchrow_array");
- my $url = "authenquery?ACTION=edit_mod;pause99_edit_mod_modid=$modid;HIDDENNAME=$otheruser";
- push @errors, qq{$err --
- Do you want to edit $modid instead?};
- } else {
- push @errors, $err;
- }
- goto FORMULAR;
- }
- push @m, qq{Query succeeded.};
-
- @to = $mgr->{MailtoAdmins};
- my $userobj = $self->active_user_record($mgr,$userid);
- # The logic for sending mail up to version 1.144 made
- # replying difficult. That's why we change that after 1.144
-
- # New logic: public address might be fake. We send to secret or
- # public email separately if we need to, otherwise we send to
- # userid@cpan.org. But there is a time gap between this database
- # and cpan.org's database.
- if ($userobj->{cpan_mail_alias} =~ /^(publ|secr)$/
- &&
- time - ($userobj->{introduced}||0) > 86400
- ) {
- $to[0] .= sprintf ",%s\@cpan.org", lc $userid;
- push @m, qq{ Sending mail to: @to};
- } else {
- # we have nothing else, so we must send separate mail
- my $user_email = $userobj->{secretemail};
- $user_email ||= $userobj->{email};
- push @to, $user_email if $user_email;
- push @m, qq{ Sending separate mails to: }, join(" AND ",
- map { "[$_]" } @to);
- }
-
- my $user_fullname = $userobj->{fullname};
-
- my $chap_shorttitle = "???";
- $sth = $dbh->prepare("SELECT shorttitle
- FROM chapters
- WHERE chapterid=?");
- warn "chapterid[$chapterid]";
- $sth->execute($chapterid);
- warn "chapterid[$chapterid]";
- if ($sth->rows == 1) {
- $chap_shorttitle = $mgr->fetchrow($sth, "fetchrow_array");
- $chap_shorttitle = substr($chap_shorttitle,3) if $chap_shorttitle =~ /^\d/;
- } else {
- warn "ALERT: could not find chaptertitle";
- }
-
- my $gmtime = gmtime($time) . " UTC";
-
- # as string
- # sprintf "%-$Modlist::GLOBAL->{WIDTH_COL1WRITE}s%s%s%s%s %-45s%-${filler}s %s", @{$self}[2..9]; # 15/16
- # as HTML
- # sprintf "%-$Modlist::GLOBAL->{WIDTH_COL1WRITE}s%s%s%s%s %-45s", @{$self}[2..7];
-
- my($mdirname,$mbasename) = $modid =~ /^(.+::)([^:]+)$/;
- $mdirname ||= "";
- $mbasename ||= $modid;
- my $modwidth = $mdirname ? 15 : 17; # for the two colons
- $mdirname .= "\n::" if $mdirname;
- my $ml_entry = sprintf(("%s%-".$modwidth."s %s%s%s%s%s %-44s %s\n"),
- $mdirname, $mbasename, $statd, $stats, $statl, $stati, $statp,
- $description, $userid);
- my $server = $PAUSE::Config->{SERVER_NAME}; # XXX: $r->server->server_hostname
-
- my $comment = $req->param("pause99_add_mod_comment") || "";
- if ($comment) {
- # Don't wrap it, this is written by us.
- # Don't escape it, it's for mail
- $comment = sprintf "\n%s comments:\n%s\n--\n",
- $mgr->{User}{userid}, $comment;
- }
-
- $subject = qq{New module $modid};
- @blurb = qq{
-The next version of the Module List will list the following module:
-
- modid: $modid
- DSLIP: $statd$stats$statl$stati$statp
- description: $description
- userid: $userid ($user_fullname)
- chapterid: $chapterid ($chap_shorttitle)
- enteredby: $mgr->{User}{userid} ($mgr->{User}{fullname})
- enteredon: $gmtime
-
-The resulting entry will be:
-
-$ml_entry$comment
-Please allow a few days until the entry will appear in the published
-module list.
-
-Parts of the data listed above can be edited interactively on the
-PAUSE. See https://$server/pause/authenquery?ACTION=edit_mod
-
-Thanks for registering,
---
-The PAUSE Team
-};
-
- my($blurb) = join "", @blurb;
- require HTML::Entities;
- my($blurbcopy) = HTML::Entities::encode($blurb,"<>&");
- warn "DEBUG: UPLOAD[$PAUSE::Config->{UPLOAD}]";
- push @m, qq{
-};
- warn "blurb[$blurb]";
-
- my $header = {
- Subject => $subject
- };
- warn "To[@to]Subject[$header->{Subject}]";
- $mgr->send_mail_multi(\@to, $header, $blurb);
- } else {
- $modid = $req->param('pause99_add_mod_modid')||"";
- }
- if ($modid) {
-
- # http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?query=LibWeb%3A%3ACore&errors=0&case=on&maxfiles=100&maxlines=30
- # xray does not allow semicolons instead of ampersands, so we have
- # to do some extra escaping
- my $emodid = URI::Escape::uri_escape($modid,'\W');
- my $query = join(
- "&",
- "query=$emodid",
- "error=0",
- "case=on",
- "maxfiles=100",
- "maxlines=30"
- );
- my $uri = "http://www.xray.mpe.mpg.de/cgi-bin/w3glimpse/modules?" . $query;
- push @m, sprintf qq{Search for %s at xray }, $uri, $modid;
- warn "uri[$uri]modid[$modid]";
- } else {
- warn "DEBUG: No modid";
- }
-
- FORMULAR:
- my @formfields = qw( modid chapterid statd stats statl stati statp
- description userid comment );
- if (@errors) {
- push @m, qq{
ERROR:
- The submission was rejected due to the following:
};
- push @m, join("\n", map { "
$_
" } @errors);
-
- push @m, qq{
Nothing done. Please correct the form below
- and retry.
};
-
- } elsif ($guessing) {
- # Nothing to do here, I suppose
- } elsif ($req->param("SUBMIT_pause99_add_mod_preview")) {
- # Currently it is always eq "preview", but we do not check that.
- # Nothing to do here, they said so. Used in CPAN::Admin. Undocumented!
- } else {
- # As we have had so much success, there is no point in leaving the
- # form filled
- # warn "clearing all fields";
- for my $field (@formfields) {
- my $param = "pause99_add_mod_$field";
- # there must be a more elegant way to specify empty list for
- # chapterid. If I knew, which, the setting of 99 would be
- # triggered later on. I would believe.
- if ($req->param($param)){
- if ($param =~ /_chapterid$/) {
- $req->parameters->set($param,"");
- } elsif ($param =~ /_stat.$/) {
- $req->parameters->set($param,"?");
- } else {
- $req->parameters->set($param,"");
- }
- }
- }
- }
-
- my $submit_butts = $mgr->submit(
- name=>"SUBMIT_pause99_add_mod_insertit",
- value=>" Submit to database ",
- );
- my $hint_butt = $mgr->submit(
- name=>"SUBMIT_pause99_add_mod_hint",
- value=>" Guess the rest without submitting ",
- );
- if ($req->param("pause99_add_mod_userid")) {
- # Easier to spot, harder to browse on Netscape
- # $meta{userid}{args}{size} = 1;
-
- # Yet better, much less bandwidth:
- $meta{userid}{type} = "textfield";
- $meta{userid}{headline} = "userid";
- $meta{userid}{args}{size} = 12;
- $meta{userid}{args}{maxlength} = 9;
- }
- push @m, qq{ };
- push @m, $submit_butts;
- push @m, qq{ };
- for my $field (@formfields){
- my $headline = $meta{$field}{headline} || $field;
- my $note = $meta{$field}{note} || "";
- push @m, qq{
$headline
};
- push @m, qq{
$note
} if $note;
- my $fieldtype = $meta{$field}{type} or die "empty fieldtype";
- my $fieldname = "pause99_add_mod_$field";
- # warn sprintf "field[%s]value[%s]", $field, $req->param($fieldname);
- if ($field eq "chapterid") {
- my $val = $req->param($fieldname);
- die "chapterid not integer" if $strict_chapterid && $val !~ /^\d*$/;
- }
- push @m, $mgr->$fieldtype(
- 'name' => $fieldname,
- %{$meta{$field}{args} || {}}
- );
- if ($field eq "modid") {
- push @m, qq{
};
- if (@hints) {
- push @m, qq{
};
- for (@hints) {
- push @m, qq{
$_
\n};
- }
- push @m, qq{
\n
};
- }
- push @m, $hint_butt;
- push @m, qq{
\n};
- }
- }
- push @m, qq{ };
- push @m, $submit_butts;
- return @m;
-}
-
-sub _add_mod_hint {
- my($self, $mgr, $wanted, $dbh, $hints) = @_;
- my($dsli,@desc);
- my $req = $mgr->{REQ};
- ($wanted->{modid},$dsli,@desc) = split /\s+/, $req->param("pause99_add_mod_modid");
-
- my $userid = pop @desc;
- my $sth_mods = $dbh->prepare(qq{SELECT * FROM mods WHERE modid=?});
- $sth_mods->execute($wanted->{modid});
-
- if ($sth_mods->rows > 0) {
- my $rec = $mgr->fetchrow($sth_mods, "fetchrow_hashref");
- my $userid = $rec->{userid};
- push @$hints, "$wanted->{modid} is registered in the module list by $userid. ";
- } else {
- push @$hints, "$wanted->{modid} is not registered in the module list. ";
- }
-
- my $sth = $dbh->prepare(qq{SELECT * FROM packages
- WHERE package=?});
- $sth->execute($wanted->{modid});
-
- if ($userid) {
- warn "userid[$userid]";
- # XXX check if user exists, and if not, suggest alternatives
- } else {
- # XXX check if somebody has already uploaded the module and if
- # so, tell the user. Link to readme.
- my $rows = $sth->rows;
- warn "rows[$rows]";
- if ($rows > 0) {
- my $rec = $mgr->fetchrow($sth, "fetchrow_hashref");
- my $dist = $rec->{dist};
- my $readme = $dist;
- $readme =~ s/(\.tar[._-]gz|\.tar.Z|\.tgz|\.zip)$/.readme/;
- $userid = $mgr->file_to_user($dist);
-
- push @$hints, qq{Dist $dist, current version
- $rec->{version} has been uploaded by $userid.
- Try the readme.}
-
- }
- }
- $sth->finish;
-
- # guess the chapter, code also found in mldistwatch
- my($root) = $wanted->{modid} =~ /^([^:]+)/;
-
- $sth = $dbh->prepare("SELECT chapterid
- FROM mods
- WHERE modid = ?");
- $sth->execute($root);
- my $chapterid;
- if ($sth->rows == 1) {
- $chapterid = $mgr->fetchrow($sth, "fetchrow_array");
- } else {
- $sth = $dbh->prepare(qq{SELECT chapterid
- FROM mods
- WHERE modid LIKE ?});
-
- $sth->execute("$root\::%");
- $chapterid = $mgr->fetchrow($sth, "fetchrow_array");
- }
-
- warn "chapterid[$chapterid]";
- $req->parameters->set("pause99_add_mod_modid",$wanted->{modid});
- my(@dsli) = $dsli =~ /(.?)(.?)(.?)(.?)(.?)/;
- $req->parameters->set("pause99_add_mod_statd",$dsli[0]||"?");
- $req->parameters->set("pause99_add_mod_stats",$dsli[1]||"?");
- $req->parameters->set("pause99_add_mod_statl",$dsli[2]||"?");
- $req->parameters->set("pause99_add_mod_stati",$dsli[3]||"?");
- $req->parameters->set("pause99_add_mod_statp",$dsli[4]||"?");
- my $description = join " ", @desc;
- $description ||= "";
- $req->parameters->set("pause99_add_mod_description",$description);
- $chapterid ||= "";
- warn "chapterid[$chapterid]";
- $req->parameters->set("pause99_add_mod_chapterid",$chapterid);
- $req->parameters->set("pause99_add_mod_userid",$userid);
-}
-
-sub apply_mod {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- $mgr->prefer_post(1);
- my(@m);
- my $req = $mgr->{REQ};
- $mgr->{CAN_GZIP} = 0; # for debugging
- my $u = $self->active_user_record($mgr);
- push @m, qq{};
- if ($mgr->{User}{userid} ne $u->{userid}) {
- push @m, qq{
Applying in the name of $u->{userid}
\n};
- }
-
- my $dbh = $mgr->connect;
- my $sth;
- local($dbh->{RaiseError}) = 0;
-
- my %meta = ($self->modid_meta,
- $self->chap_meta($mgr),
- $self->stat_meta,
- $self->desc_meta);
-
- $meta{modid}{note} = "Please try to suggest a nested namespace that
- is based on an existing root namespace. New
- entries to the root namespace are less likely
- to be approved.";
-
- $meta{chapfirm} = {
- headline => "Do you really want this chapterid?",
- type => "checkbox",
- };
- $meta{similar} = {
-
- headline => "Modules with similar functionality",
- type => "textfield",
-
- note => "If any related modules already exist on
- CPAN, please let us know and discuss the
- relation between your module and these
- already existing modules below. Enter
- just the module names, separated by
- whitespace.",
-
- args => {
- size => 60,
- }
-
- };
- $meta{communities} = {
- headline => "Places where this module has been or will be discussed publicly",
- note => "Mailinglists, newsgroups, chatrooms, CVS repository, etc.",
- type => "textfield",
- args => {
- size => 60,
- }
-
- };
- $meta{rationale} = {
- headline => "Rationale",
- type => "textarea",
-
- note => "Please discuss your reasoning about the
- namespace choice, the uniqueness of your
- approach and why you believe this module
- should be listed in the module list.
- Especially if you suggest a new rootlevel
- namespace you are required to argue why this
- new namespace is necessary.",
-
- args => {
- rows => 15,
- cols => 60,
- }
- };
-
- my @errors = ();
- my @hints = ();
- my $applying_userid = $u->{userid};
- my($chap_confirm,$modid);
- if ( $req->param("SUBMIT_pause99_apply_mod_send") ) {
- my($modid,$root,@appropriate_chapterid);
- if (length($modid = $req->param("pause99_apply_mod_modid"))) {
- if ($modid =~ /([^A-Za-z0-9_\:])/) {
- my $illegal = ord($1);
- push @errors, sprintf(qq{The module name contains the illegal character 0x%x.
- Please correct and retry.}, #},
- $illegal);
- } elsif ($modid !~ /^[A-Za-z]/) {
- push @errors, qq{The module name doesn't start with a letter.
- Please correct and retry.};
- } elsif ($modid !~ /[A-Za-z0-9]\z/) {
- push @errors, qq{The module name doesn't end with a letter or digit.
- Please correct and retry.};
- }
-
- $sth = $dbh->prepare(qq{SELECT * FROM mods
- WHERE modid=?});
- $sth->execute($modid);
- if ($sth->rows) {
- my $modrec = $mgr->fetchrow($sth, "fetchrow_hashref");
- push @errors, qq{Module $modid has already been registered by $modrec->{userid}.};
-# with the modulelist line
-#
$mlline
};
- }
-
- $sth = $dbh->prepare(qq{SELECT * FROM packages
- WHERE package=?});
- $sth->execute($modid);
-
- # XXX check if somebody has already uploaded the module and if
- # so, tell the user. Link to readme.
-
- # XXX nonono, we should rather check the perms, not the uploads.
- # If somebody else has first come rights we must reject
- # everything now. If this user has first come rights we can
- # auto-register immediately (unless other errors occur, maybe
- # even a root namespace should be rejected). Only if nobody has
- # first come rights we shall proceed with the application.
- my $rows = $sth->rows;
- if ($rows > 0) {
- my $rec = $mgr->fetchrow($sth, "fetchrow_hashref");
- my $dist = $rec->{dist};
- my $registered_userid = $mgr->file_to_user($dist);
-
- if ($applying_userid eq $registered_userid) {
- if ($PAUSE::Config->{AUTO_REGISTER_FOR_FIRST_COME}) {
- # examine the perms of this user now if he is first-come,
- # set something so that we do not even send a mail and
- # promote/upgrade him to state "module list" right away.
- }
- } else {
- push @errors, qq{Dist $dist, current version
- $rec->{version} has been uploaded by $registered_userid.
- Please contact $registered_userid or choose a different namespace.};
- }
- }
- $sth->finish;
-
- # guess the chapter, code also found in mldistwatch
- ($root) = $modid =~ /^([^:]+)/;
- warn "root[$root]";
- $sth = $dbh->prepare("SELECT chapterid
- FROM mods
- WHERE modid = ? OR modid LIKE ?");
- $sth->execute($root, "$root\::%");
- my(%appr);
- if ($sth->rows) {
- while (my $chid = $mgr->fetchrow($sth, "fetchrow_array")) {
- $appr{$chid} = undef;
- }
- @appropriate_chapterid = keys %appr;
- }
-
-
- } else {
- push @errors, qq{No module name chosen. You need to supply a module name.};
- }
-
- my($chapterid) = $req->param('pause99_apply_mod_chapterid');
- die "chapterid not numeric" if $strict_chapterid && $chapterid !~ /^\d*$/;
- warn "appropriate_chapterid[@appropriate_chapterid]";
- my($chap_confirmed) = $req->param('pause99_apply_mod_chapfirm');
- if (!$chapterid) {
- push @errors, qq{No chapter given.};
- } elsif ( ! @appropriate_chapterid) {
- # That's OK, a new rootnamespace
- } elsif (! $self->is_subset($chapterid,\@appropriate_chapterid)){
- $chap_confirm++;
- unless ( $chap_confirmed ) {
- my $plural = @appropriate_chapterid>1 ? "s" : "";
- my $chlist = @appropriate_chapterid>1 ?
- $self->verbose_list(@appropriate_chapterid) : $appropriate_chapterid[0];
-
- push @errors, sprintf(qq{Module rootnamespace %s doesn\'t
- match chapter. %s is already registered
- in the chapter%s %s. If you really believe that
- it belongs to chapter %s too, please turn on the
- small checkbox next to the chapterselection.},
-
- $root,
- $root,
- $plural,
- $chlist,
- $chapterid
- );
- }
- }
-
- my($statd) = $req->param('pause99_apply_mod_statd');
- $req->parameters->set('pause99_apply_mod_statd',$statd='?') unless $statd;
- if ($statd eq '?') {
- push @errors, qq{The D status of the DSLIP [$statd] is not known.};
- }
-
- my($stats) = $req->param('pause99_apply_mod_stats');
- $req->parameters->set('pause99_apply_mod_stats',$stats='?') unless $stats;
- if ($stats eq '?') {
- push @errors, qq{The S status of the DSLIP [$stats] is not known.};
- }
-
- my($statl) = $req->param('pause99_apply_mod_statl');
- $req->parameters->set('pause99_apply_mod_statl',$statl='?') unless $statl;
- if ($statl eq "?") {
- push @errors, qq{The L status of the DSLIP [$statl] is not known.};
- }
-
- my($stati) = $req->param('pause99_apply_mod_stati');
- $req->parameters->set('pause99_apply_mod_stati',$stati='?') unless $stati;
- if ($stati eq "?") {
- push @errors, qq{The I status of the DSLIP [$stati] is not known.};
- }
-
- my($statp) = $req->param('pause99_apply_mod_statp');
- $req->parameters->set('pause99_apply_mod_statp',$statp='?') unless $statp;
- if ($statp eq "?") {
- push @errors, qq{The P status of the DSLIP [$statp] is not known.};
- }
-
- # must be treated as utf8
- my($description) = $req->param('pause99_apply_mod_description')||"";
- my $ud = $mgr->any2utf8($description);
- if ($ud ne $description) {
- $req->parameters->set('pause99_apply_mod_description',$ud);
- $description = $ud;
- }
- $description =~ s/^\s+//;
- $description =~ s/\s+\z//;
- if (length($description)>44) {
- substr($description,44) = '';
- push @errors, qq{The description was too long and had to be truncated.};
- } elsif (not length($description)) {
- push @errors, qq{The description is missing.};
- }
- $req->parameters->set("pause99_apply_mod_description", $description) if $description;
-
- goto FORMULAR2 if @errors;
-
- my(@to,$subject,@blurb,$query,$sth,@qvars,@qbind);
- my $time = time;
-
- @to = $mgr->{MailtoAdmins};
- my $userobj = $self->active_user_record($mgr,$applying_userid);
-
- if ($userobj->{cpan_mail_alias} =~ /^(publ|secr)$/
- &&
- time - ($userobj->{introduced}||0) > 86400
- ) {
- $to[0] .= sprintf ",%s\@cpan.org", lc $applying_userid;
- push @m, qq{ Sending mail to: @to};
- } else {
- my $user_email = $userobj->{secretemail};
- $user_email ||= $userobj->{email};
- push @to, $user_email if $user_email;
- push @m, qq{ Sending separate mails to: }, join(" AND ",
- map { "[$_]" } @to);
- }
-
- my $user_fullname = $userobj->{fullname};
-
- my $chap_shorttitle = "???";
- $sth = $dbh->prepare("SELECT shorttitle
- FROM chapters
- WHERE chapterid=?");
- $sth->execute($chapterid);
- if ($sth->rows == 1) {
- $chap_shorttitle = $mgr->fetchrow($sth, "fetchrow_array");
- $chap_shorttitle = substr($chap_shorttitle,3) if $chap_shorttitle =~ /^\d/;
- } else {
- warn "ALERT: could not find chaptertitle";
- }
-
- my $gmtime = gmtime($time) . " UTC";
-
- my($mdirname,$mbasename) = $modid =~ /^(.+::)([^:]+)$/;
- $mdirname ||= "";
- $mbasename ||= $modid;
- my $modwidth = $mdirname ? 15 : 17; # for the two colons
- $mdirname .= "\n::" if $mdirname;
- my $ml_entry = sprintf(("%s%-".$modwidth."s %s%s%s%s%s %-44s %s\n"),
- $mdirname, $mbasename, $statd, $stats, $statl, $stati, $statp,
- $description, $applying_userid);
- my $server = $PAUSE::Config->{SERVER_NAME}; # XXX: $r->server->server_hostname
-
- my $rationale = $req->param("pause99_apply_mod_rationale") || "";
- if ($rationale) {
- # wrap it
- $rationale =~ s/\r\n/\n/g;
- $rationale =~ s/\r/\n/g;
- my @rat = split /\n\n/, $rationale;
- my $tf = Text::Format->new( bodyIndent => 4, firstIndent => 5);
- $rationale = $tf->paragraphs(@rat);
- $rationale =~ s/^\s{5}/\n /gm;
- }
- my $similar = $req->param("pause99_apply_mod_similar") || "";
- if ($similar) {
- # wrap it
- my $tf = Text::Format->new( bodyIndent => 4, firstIndent => 4);
- $similar = $tf->format($similar);
- }
- my $communities = $req->param("pause99_apply_mod_communities") || "";
- if ($communities) {
- # wrap it
- my $tf = Text::Format->new( bodyIndent => 4, firstIndent => 4);
- $communities = $tf->format($communities);
- }
-
- my $session = $mgr->session;
- $session->{APPLY} = {
- modid => $modid,
- statd => $statd,
- stats => $stats,
- statl => $statl,
- stati => $stati,
- statp => $statp,
- description => $description,
- userid => $applying_userid,
- chapterid => $chapterid,
- };
- my $sessionID = $mgr->userid;
- $subject = qq{Module submission $modid};
- my $urlenc_module = URI::Escape::uri_escape($modid,'\W');
- @blurb = qq{
-The following module was proposed for inclusion in the Module List:
-
- modid: $modid
- DSLIP: $statd$stats$statl$stati$statp
- description: $description
- userid: $applying_userid ($user_fullname)
- chapterid: $chapterid ($chap_shorttitle)
- communities:
-$communities
- similar:
-$similar
- rationale:
-$rationale
- enteredby: $mgr->{User}{userid} ($mgr->{User}{fullname})
- enteredon: $gmtime
-
-The resulting entry would be:
-
-$ml_entry
-
-Thanks for registering,
---
-The PAUSE Team
-
-PS: The following links are only valid for module list maintainers:
-
-Registration form with editing capabilities:
- https://pause.perl.org/pause/authenquery?ACTION=add_mod&USERID=$sessionID&SUBMIT_pause99_add_mod_preview=1
-Immediate (one click) registration:
- https://pause.perl.org/pause/authenquery?ACTION=add_mod&USERID=$sessionID&SUBMIT_pause99_add_mod_insertit=1
-Peek at the current permissions:
- https://pause.perl.org/pause/authenquery?pause99_peek_perms_by=me&pause99_peek_perms_query=$urlenc_module
-};
-
- my($blurb) = join "", @blurb;
- require HTML::Entities;
- my($blurbcopy) = HTML::Entities::encode($blurb,"<>&");
- $blurbcopy =~ s|(https?://[^\s\"]+)|$1|g;
- $blurbcopy =~ s|(>http.*?)U|$1\n U|gs; # break the long URL
- # warn "DEBUG: UPLOAD[$PAUSE::Config->{UPLOAD}]";
- push @m, qq{
Please use this form to apply for the registration of
- a namespace for a module you have written or are going
- to write. The request will be sent off to the
- modules\@perl.org people who are maintaining the Modules
- List. A registration is not a prerequisite for
- uploading. It is just recommended for better
- searchability of the CPAN and to avoid namespace
- clashes. You will be notified when the registration is
- approved but you can upload immediately, there's no need
- to wait for an approval. On the contrary, you are
- encouraged to upload immediately.
If you are
- facing any problems with this form, please report to
- modules\@perl.org. Thank you for
- registering.
};
-
-
- FORMULAR2:
- my @formfields = qw( modid chapterid chapfirm statd stats statl stati statp
- description communities similar rationale );
- if (@errors) {
- my $plural = @errors > 1 ? "s" : "";
- push @m, qq{
ERROR:
- The submission didn't succeed due to the following reason$plural:
};
- push @m, join("\n", map { "
$_
" } @errors);
-
- push @m, qq{
Nothing done. Please correct the form below
- and retry.
};
-
- } elsif ($req->param("SUBMIT_pause99_apply_mod_preview")) {
- # Currently it is always eq "preview", but we do not check that.
- # Nothing to do here, they said so. Used in CPAN::Admin. Undocumented!
- } else {
- # As we have had so much success, there is no point in leaving the
- # form filled
- # warn "clearing all fields";
- for my $field (@formfields) {
- my $param = "pause99_apply_mod_$field";
- # there must be a more elegant way to specify empty list for
- # chapterid. If I knew, which, the setting of 99 would be
- # triggered later on. I would believe.
- if ($req->param($param)){
- if ($param =~ /chapterid/) {
- $req->parameters->set($param,"");
- } else {
- $req->parameters->set($param,"");
- }
- }
- }
- }
-
- my $submit_butts = $mgr->submit(
- name=>"SUBMIT_pause99_apply_mod_send",
- value=>" Submit to modules\@perl.org ",
- );
- push @m, qq{ };
- for my $field (@formfields){
- next if $field eq "chapfirm" && ! $chap_confirm;
- my $headline = $meta{$field}{headline} || $field;
- my $note = $meta{$field}{note} || "";
- push @m, qq{
$headline
};
- push @m, qq{
$note
} if $note;
- push @m, qq{
};
- my $fieldtype = $meta{$field}{type} or die "empty fieldtype";
- my $fieldname = "pause99_apply_mod_$field";
- push @m, $mgr->$fieldtype(
- 'name' => $fieldname,
- %{$meta{$field}{args} || {}}
- );
- push @m, qq{
\n};
- }
- push @m, qq{ };
- push @m, $submit_butts;
- return @m;
-}
-
-sub is_subset {
- my($self, $item, $arr) = @_;
- for my $i (@$arr) {
- return 1 if $i eq $item;
- }
- return;
-}
-
-sub verbose_list {
- my($self,@arr) = @_;
- my $result;
- return unless @arr;
- if (@arr > 2) {
- $result = join ", ", @arr[0..$#arr-1];
- $result .= ", and $arr[-1]";
- } elsif (@arr > 1) {
- $result = "$arr[0] and $arr[1]";
- } else {
- $result = $arr[0];
- }
- $result;
-}
-
-sub stat_meta {
- my($deftype) = "scrolling_list"; # or "radio_group";
- my(%statd,%stats,%statl,%stati,%statp,@statd,@stats,@statl,@stati,@statp);
- @statd{@statd = qw(i c a b R M S ?)} = qw( idea pre-alpha
- alpha beta released mature standard unknown);
- @stats{@stats = qw(d m u n a ?)} = qw(
- developer mailing-list comp.lang.perl.* none abandoned unknown);
- @statl{@statl = qw(p c + o h ?)} = qw( perl C C++ other hybrid unknown);
- @stati{@stati = qw(f r O p h n ?)} = qw( functions
- references+ties object-oriented pragma hybrid none unknown );
- @statp{@statp = qw(p g l b a 2 o d r n ?)} = qw( Standard-Perl
- GPL LGPL BSD Artistic Artistic_2 open-source distribution_allowed
- restricted_distribution no_licence unknown );
-
- for my $hash (\%statd,\%stats,\%statl,\%stati,\%statp) {
- for my $k (keys %$hash) {
- $hash->{$k} = $deftype =~ /radio/ ?
- qq{$k ($hash->{$k}) } :
- qq{$k -- $hash->{$k}};
- }
- }
-
- return (
- statd => {
- type => $deftype,
- headline => "Development Stage (Note: No implied timescales)",
- args => {
- values => \@statd,
- labels => \%statd,
- default => '?',
- }
- },
- stats => {
- type => $deftype,
- headline => "Support Level",
-
- note => qq{The module list says about the flags
- n and a:
-
-n - None known, try comp.lang.perl.modules
-a - abandoned; volunteers welcome to take over maintainance
-},
-
- args => {
- values => \@stats,
- labels => \%stats,
- default => '?',
- }
- },
- statl => {
- type => $deftype,
- headline => "Language Used",
- args => {
- values => \@statl,
- labels => \%statl,
- default => '?',
- }
- },
- stati => {
- type => $deftype,
- headline => "Interface Style",
- args => {
- values => \@stati,
- labels => \%stati,
- default => '?',
- }
- },
- statp => {
- type => $deftype,
- headline => "Public license",
-
- note => qq{This field is here to help acquiring
- solid data about which licences the CPAN modules are subject to.
- Filling in this form field is not a substitute for a proper
- license statement in the actual package you are uploading. So
- please verify that all your uploaded files contain a proper
- license. This field will be used to help certifying the legal
- status of your package. Standard-Perl denotes that
- the user may choose between GPL and Artistic, GPL
- stands for GNU General Public License, LGPL for GNU
- Lesser General Public License (previously known as "GNU Library
- General Public License"), BSD for the BSD License,
- Artistic for the Artistic license alone,
- Artistic_2 for the artistic license 2.0 or later
- open-source for any other Open Source license listed at http://www.opensource.org/licenses/,
- distribution_allowed is for any license that is not
- approved by www.opensource.org but that allows distribution
- without restrictions, restricted_distribution is for
- code that limits distribution somehow, and no_licence
- is for code that bears no licence at all. The last two items
- on the list might become a problem for CPAN in the future, so
- please try to clear things up to avoid them.--Thanks!
-
-},
-
- args => {
- values => \@statp,
- labels => \%statp,
- default => '?',
- }
- },
- );
-}
-
-sub chap_meta {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $dbh = $mgr->connect;
- my $sth3 = $dbh->prepare("SELECT chapterid, shorttitle
- FROM chapters");
- my(%chap);
- $sth3->execute;
- while (my($chapterid, $shorttitle) = $mgr->fetchrow($sth3, "fetchrow_array")) {
- $chap{$chapterid} = sprintf "%03d %s", $chapterid, $shorttitle;
- }
- my @sorted = sort { $a <=> $b } keys %chap;
- unshift @sorted, "";
- $chap{""} = "Please select chapter";
- $sth3->finish;
- return (
- chapterid => {
- type => "scrolling_list",
- headline => "Module List Chapter",
-
- note => "The module list has all modules
- categorized in chapters. Please pick the one
- you would prefer to have your module listed
- in.",
-
- args => {
- size => 1,
- default => "",
- values => \@sorted,
- labels => \%chap,
- },
- }
- );
-}
-
-sub desc_meta {
- return (
- description => {
- type => "textfield",
- headline => "Description in Module List (44 chars limit)",
- args => {
- size => 44,
- maxlength => 44,
- }
- },
- );
-}
-
-sub modid_meta {
- return (
- modid => {
- type => "textfield",
- headline => "Name of the module",
- args => {
- size => 44,
- maxlength => 112,
- }
- },
- );
-}
-
-=pod
-
-In user_meta liegt noch der ganze Scheiss herum, mit dem ich die
-unglaubliche Langsamkeit analysiert habe, die eintrat, als ich den
-alten Algorithmus durch 5.8 habe durchlaufen lassen.
-
-Am Schluss (mit $sort_method="splitted") war 5.8 etwa gleich schnell
-wie 5.6, aber die Trickserei ist etwas zu aufwendig fuer meinen
-Geschmack.
-
-Also, der Fehler war, dass ich zuerst einen String zusammengebaut
-habe, der UTF-8 enthalten konnte und uebermaessig lang war und dann
-darueber im Sort-Algorithmus lc laufen liess. Jedes einzelne lc hat
-etwas Zeit gekostet, da es im Sort-Algorithmus war, musste es 40000
-mal statt 2000 mal laufen. Soweit, so klar auf einen Blick: richtige
-Loesung ist es, den String mit Hilfe des "translit" Feldes zo kurz zu
-lassen, dass nur ASCII verbleibt, dann ein downgrade, dann lc, und
-dann erst Sortieren. In einem zweiten Hash traegt man den
-Display-String herum.
-
-Was bis heute ein Mysterium ist, ist die Frage, wieso das Einschalten
-der Statistik, also ein hoher *zusaetzlicher* Aufwand, die Zeit auf
-ein Sechstel biz Zehntel *gedrueckt* hat. Da muss etwas Schlimmes mit
-$a und $b passieren.
-
-=cut
-
-sub user_meta {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $dbh = $mgr->connect;
- my $sql = qq{SELECT userid, fullname, isa_list, asciiname
- FROM users};
- my $sth = $dbh->prepare($sql);
- $sth->execute;
- my(%u,%labels);
- # my $sort_method = "gogo";
- my $sort_method = "splitted";
- if (0) { # worked mechanically correct but slow with 5.7.3@16103.
- # The slowness is not in the fetchrow but in the sort with
- # lc below. At the time of the test $mgr->fetchrow turned
- # on UTF-8 flag on everything, including pure ASCII.
-
- while (my @row = $mgr->fetchrow($sth, "fetchrow_array")) {
- $u{$row[0]} = $row[2] ? "mailinglist $row[0]" : "$row[1] ($row[0])";
- }
-
- } elsif (0) {
-
- # here we are measuring where the time is spent and tuning up and
- # down and experiencing strange effects.
-
- my $start = Time::HiRes::time();
- my %tlc;
- while (my @row = $sth->fetchrow_array) {
- if ($] > 5.007) {
- # apparently it pays to only turn on UTF-8 flag if necessary
- defined && /[^\000-\177]/ && Encode::_utf8_on($_) for @row;
- }
- $u{$row[0]} = $row[2] ? "mailinglist $row[0]" :
- $row[3] ? "$row[3]=$row[1] ($row[0])" : "$row[1] ($row[0])";
-
- if (0) {
- # measuring lc() alone does not explain the slow sort. We see
- # about 0.4 secs for lc() on all names when they all have the
- # UTF-8 flag on, about 0.07 secs when only selected ones have
- # the flag on.
- next unless $row[1];
- my $tlcstart = Time::HiRes::time();
- $tlc{$row[1]} = lc $row[1];
- $tlc{$row[1]} = Time::HiRes::time() - $tlcstart;
- }
- }
- # warn sprintf "TIME: fetchrow and lc on users: %7.4f", Time::HiRes::time()-$start;
- my $top = 10;
- for my $t (sort { $tlc{$b} <=> $tlc{$a} } keys %tlc) {
- warn sprintf "%-43s: %9.7f\n", $t, $tlc{$t};
- last unless --$top;
- }
- } else { # splitted!
- my $start = Time::HiRes::time();
- while (my @row = $sth->fetchrow_array) {
- if ($] > 5.007) {
- # apparently it pays to only turn on UTF-8 flag if necessary
- defined && /[^\000-\177]/ && Encode::_utf8_on($_) for @row;
- }
- my $disp = $row[2] ?
- "$row[0] (mailinglist)" :
- $row[3] ?
- "$row[0]:$row[3]=$row[1]" :
- "$row[0]:$row[1]";
- substr($disp, 52) = "..." if length($disp) > 55;
- my($sort) = $disp =~ /^([\000-\177]+)/;
- utf8::downgrade($sort) if $] > 5.007;
- $u{$row[0]} = lc $sort;
- $labels{$row[0]} = $disp;
- }
- warn sprintf "TIME: fetchrow and split on users: %7.4f", Time::HiRes::time()-$start;
- }
- my $start = Time::HiRes::time();
- our @tlcmark = ();
- our $Collator;
- if ($sort_method eq "U:C") {
- require Unicode::Collate;
- $Collator = Unicode::Collate->new();
- }
- # use sort qw(_mergesort);
- # use sort qw(_quicksort);
- my @sorted = sort {
- if (0) {
- # Mysterium: the worst case was to have all names with UTF-8
- # flag, Sort_method="lc" and running no statistics. Turning on
- # the statistics here reduced runtime from 77-133 to 12 secs.
- # With only selected names having UTF-8 flag on we reach 10 secs
- # without the statistics and 12 with it. BTW, mergesort counts
- # 20885 comparisons, quicksort counts 23201.
- push(
- @tlcmark,
- sprintf("%s -- %s: %9.7f",
- $u{$a},
- $u{$b},
- Time::HiRes::time())
- );
- }
- if (0) {
- } elsif ($sort_method eq "lc") {
- # we reach minimum of 10 secs here, better than 77-133 but still
- # unacceptable. We seem to have to fight against two bugs: slow
- # lc() always is one bug, extremely slow lc() when combined with
- # sort is the other one. We must solve it as we did in metalist:
- # maintain a sortdummy in the database and let the database sort
- # on ascii.
- lc($u{$a}) cmp lc($u{$b});
- } elsif ($sort_method eq "U:C") {
- $Collator->cmp($a,$b);
- # v0.10 completely bogus and 67 secs
- } elsif ($sort_method eq "splitted") {
- $u{$a} cmp $u{$b};
- } else {
- # we reach 0.27 secs here with mergesort, 0.28 secs after we
- # switched to quicksort.
- $u{$a} cmp $u{$b};
- }
- } keys %u;
- warn sprintf "TIME: sort on users: %7.4f", Time::HiRes::time()-$start;
- if (@tlcmark) {
- warn "COMPARISONS: $#tlcmark";
- my($Ltlcmark) = $tlcmark[0] =~ /:\s([\d\.]+)/;
- # warn "$Ltlcmark;$tlcmark[0]";
- my $Mdura = 0;
- for my $t (1..$#tlcmark) {
- my($tlcmark) = $tlcmark[$t] =~ /:\s([\d\.]+)/;
- my $dura = $tlcmark - $Ltlcmark;
- if ($dura > $Mdura) {
- my($lterm) = $tlcmark[$t-1] =~ /(.*):/;
- warn sprintf "%s: %9.7f\n", $lterm, $dura;
- $Mdura = $dura;
- }
- $Ltlcmark = $tlcmark;
- }
- }
-
- return (
- userid => {
- type => "scrolling_list",
- args => {
- 'values' => \@sorted,
- size => 10,
- labels => $sort_method eq "splitted" ? \%labels : \%u,
- },
- }
- );
-}
-
-sub check_xhtml {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
- my @m;
- my $dir = "/var/run/httpd/deadmeat";
- if (my $file = $req->param("pause99_check_xhtml_look")) {
- open my $fh, "$dir/$file" or die "Couldn't open $file: $!";
- if ($] > 5.007) {
- binmode $fh, ":utf8";
- }
- local $/;
- my $html = <$fh>;
- push @m, $mgr->escapehtml($html);
- } else {
- require DirHandle;
- my $dh = DirHandle->new($dir) or die "Couldn't open dir[$dir]: $!";
- if (my @dirent = grep /\.xhtml$/, $dh->read()) {
- my %label;
- my %mtime;
- for my $de (@dirent) {
- my @stat = stat "$dir/$de";
- $label{$de} = sprintf " %s %d %s\n", $de, $stat[7], scalar gmtime($stat[9]);
- $mtime{$de} = $stat[9];
- }
- @dirent = sort { $mtime{$b} <=> $mtime{$a}} @dirent;
- push @m, $mgr->radio_group("name" => "pause99_check_xhtml_look",
- "values" => \@dirent,
- "labels" => \%label,
- "linebreak" => 1,
- );
- push @m, $mgr->submit(name => "SUBMIT_pause99_check_xhtml_sub",
- value => "Look");
- } else {
- push @m, qq{No bad xhtml output detected.};
- }
- }
- @m;
-}
-
-sub index_users {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m);
- push @m, "NOT YET";
- my $db = $mgr->connect;
- my $id_sql = qq{SELECT userid, fullname
- FROM users};
- my $id_sth = $db->prepare($id_sql);
-
- require WAIT;
- require WAIT::Database;
-
- my @localtime = localtime;
- $localtime[5] += 1900;
- $localtime[4]++;
- my $jobid = sprintf "%04s-%02s-%02s_%02s:%02s_%d", @localtime[5,4,3,2,1], $$;
- my $name = "$mgr->{WaitUserDb}-$jobid";
- my $directory = $mgr->{WaitDir};
- warn "name[$name] directory[$directory]";
- my $wdb = WAIT::Database->create(name => $name,
- directory => $directory,
- )
- or die "Could not create database $mgr->{WaitUserDb}: $@\n";
-
-
- my $filter = [
- "pause99_edit_users_utflc_20010505",
- "pause99_edit_users_digrams_20010505",
- ];
-
- # create-table statement
- my $table = $wdb->create_table(
- name => "uidx",
- attr => [
- 'docid',
- 'userid', # key
- ],
- keyset => [['docid']],
- ## layout => $layout,
- invindex => [
- userid_and_fullname => $filter,
- ]
- );
-
- # XXX
-
- $table->close;
- $wdb->close;
-
- @m;
-}
-
-sub WAIT::Filter::pause99_edit_users_digrams_20010505 {
- # must be written with "shift" and not with = @_. WAIT seems to need
- # that.
- my $string = shift;
- my @result;
- my $start;
-# use utf8;
- my $end = length($string) - 2;
- for ($start=0; $start<$end; $start++) {
- my $s = substr $string, $start, 3;
- push @result, $s;
- }
- @result;
-}
-
-sub WAIT::Filter::pause99_edit_users_utflc_20010505 {
-# use utf8;
- my $s = shift;
- my $lc = lc $s;
- $lc;
-}
-
-sub who_pumpkin {
- my $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
-
- my @m;
-
- push @m, qq{
Query the grouptable table for who is a
- pumpkin bit holder
-
-
Registered pumpkins:
-};
-
- my @hres;
- {
- my $db = $mgr->authen_connect;
- my $sth = $db->prepare("SELECT user FROM grouptable WHERE ugroup='pumpking' order by user");
- $sth->execute;
- while (my @row = $sth->fetchrow_array) {
- push @hres, $row[0];
- }
- $sth->finish;
- };
- my $output_format = $req->param("OF");
- if ($output_format){
- if ($output_format eq "YAML") {
- require YAML::Syck;
- local $YAML::Syck::ImplicitUnicode = 1;
- my $dump = YAML::Syck::Dump(\@hres);
- my $edump = Encode::encode_utf8($dump);
- my $res = $mgr->{RES};
- $res->content_type("text/plain; charset=utf8");
- $res->body($edump);
- return $mgr->{DONE} = HTTP_OK;
- } else {
- die "not supported OF=$output_format"
- }
- } else {
- push @m, join ", ", @hres;
- push @m, "
";
- my $href = sprintf("query?ACTION=who_pumpkin;OF=YAML");
- push @m, qq{
};
- return join "", @m;
- }
-}
-
-sub peek_perms {
- my $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
-
- my @m;
-
- push @m, qq{
Query the perms table by author or by
- module. Select the option and fill in a module name or
- user ID as appropriate. The answer is all modules that an
- user ID is registered for or all user IDs registered for a
- module, as appropriate.
-
-
Registration comes in one of three types: type
- modulelist is the registration in the old module
- list (like first-come with metadata). Type
- first-come is the automatic registration on a
- first-come-first-serve basis that happens on the initial
- upload. And type co-maint is the registration as
- co-maintainer which means that the primary maintainer of
- the namespace has granted permission to upload this module
- to other userid(s). Per namespace there can only be one
- primary maintainer (userid in the modulelist or the
- first-come category) and any number of userids in
- the co-maint category. Being registered in any of
- the categories means that a user is able not only to
- upload a module in that namespace but also be accepted by
- the indexer. In other words, the indexer will not ignore
- uploads for that namespace by that person.
-
-
The
- contents of the tables presented on this page are mostly
- generated automatically, so please report any errors you
- observe to @{$PAUSE::Config->{ADMINS}} so that the tables
- can be corrected.--Thank you!
";
- push @m, $submitbutton;
-
- @m;
-}
-
-sub share_perms {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m);
- my $req = $mgr->{REQ};
-
- $mgr->prefer_post(1); # because the querystring can get too long
-
- my $subaction = $req->param("SUBACTION");
- unless ($subaction) {
- ####################### 2.1 2.2 3.1 3.2 4.1
- SUBACTION: for my $sa (qw(movepr remopr makeco remocos remome)) {
- if ($req->param("pause99_share_perms_$sa")
- or
- $req->param("SUBMIT_pause99_share_perms_$sa")
- or
- $req->param("weaksubmit_pause99_share_perms_$sa")
- ) {
- $subaction = $sa;
- last SUBACTION;
- }
- }
- }
- my $u = $self->active_user_record($mgr);
- # warn sprintf "subaction[%s] u->userid[%s]", $subaction||"", $u->{userid}||"";
- push @m, qq{};
- push @m, qq{}; # let submit win
-
- my $scrolling_list_mod = $self->share_perms_scrl_mod($mgr,$u->{userid});
- my $scrolling_list_remove_primary = $self->share_perms_scrl_remove_primary($mgr,$u);
- my $scrolling_list_make_comaintainer = $self->share_perms_scrl_make_comaintainer($mgr,$u);
- my $scrolling_list_remove_maintainer = $self->share_perms_scrl_remove_maintainer($mgr,$u);
-
- unless ($subaction) {
-
- # NOTE: the 6 submit buttons below are "weak" submit buttons. I
- # want that people first reach the next page with more text and
- # more options.
-
-
- push @m, qq{
Permissions on PAUSE come in three flavors:
-
-
-
-
- only one user per module can be either
-
-
-
- registered in modulelist or
-
-
- primary maintainer on a first-come-first-serve
- basis;
-
-
-
-
- many users can get granted permissions as co-maintainers,
- which means their uploads for the given module are honoured by
- the indexer.
-
-
-
-
You can view your current set of permissions on the View Permissions page. To
- change permissions, select one of the following submit
- buttons, each of which leads you to a different page:
-
-
-
-
-
-
-
- 1. You are registered in modulelist
-
-
-
-
-
$scrolling_list_mod
-
-
-
- Module Metadata has been removed from PAUSE and
- is no longer editable. Please contact a PAUSE administrator to
- choose a new owner.
-
-
-
-
2. You are primary maintainer:
-
-
-
$scrolling_list_remove_primary
-
-
-
-
- 2.1 Transfer primary maintainership status to somebody else
- (you become co-maintainer)
-
-
-
-
-
-
-
-
- 2.2 Give up primary maintainership status (abandoning it without
- transfering it to someone else)
-
-
-
-
-
- 3. Making and unmaking co-maintainers (for both modulelist
- owners and primary maintainers):
-
-
-
-
-
$scrolling_list_make_comaintainer
-
-
-
-
- 3.1 Make somebody else co-maintainer
-
-
-
-
-
-
-
-
3.2 Remove a co-maintainer
-
-
-
4. You are co-maintainer
-
-
-
$scrolling_list_remove_maintainer
-
-
-
- 4.1 Give up co-maintainership status
-
-
-
-
-
-
-};
-
- return @m;
- }
-
- my $method = "share_perms_$subaction";
- # warn "method[$method]";
- push @m, $self->$method($mgr);
- @m;
-}
-
-sub share_perms_scrl_mod {
- my($self,$mgr,$userid) = @_;
- my $dbh = $mgr->connect;
- my $sql = qq{SELECT modid
- FROM mods
- WHERE userid=?
- AND mlstatus='list'
- ORDER BY modid};
- my @bind = $userid;
- my $sth = $dbh->prepare($sql);
- my $ret = $sth->execute(@bind);
- my @all_mods;
- while (my($id) = $mgr->fetchrow($sth, "fetchrow_array")) {
- # register this mailinglist for the selectbox
- push @all_mods, $id;
- }
- return "--NONE--" unless @all_mods;
- my $all_mods = scalar @all_mods;
- my $size = $all_mods > 18 ? 15 : $all_mods;
- $mgr->scrolling_list(
- 'name' => "pause99_edit_mod_3",
- 'values' => \@all_mods,
- 'size' => $size,
- );
-}
-
-sub share_perms_scrl_remove_primary {
- my($self,$mgr,$u) = @_;
- my $dbh = $mgr->connect;
-
- my $all_mods = $self->all_pmods_not_mmods($mgr,$u);
- my @all_mods = sort keys %$all_mods;
- my $n = scalar @all_mods;
- return "--NONE--" unless $n;
- my $size = $n > 18 ? 15 : $n;
- $mgr->scrolling_list(
- 'name' => "pause99_share_perms_pr_m",
- 'multiple' => 1,
- 'values' => \@all_mods,
- 'size' => $size,
- );
-}
-
-sub share_perms_scrl_make_comaintainer {
- my($self,$mgr,$u) = @_;
- my $dbh = $mgr->connect;
-
- my $all_mods = $self->all_pmods($mgr,$u);
- my @all_mods = sort keys %$all_mods;
- my $n = scalar @all_mods;
- return "--NONE--" unless $n;
- my $size = $n > 18 ? 15 : $n;
- # it should be sufficiently helpful to prepare only makeco_m on
- # these two submit buttons. For 3.2 people may be a little confused
- # but it is so rarely needed that we do not worry.
- $mgr->scrolling_list(
- 'name' => "pause99_share_perms_makeco_m",
- 'multiple' => 1,
- 'values' => \@all_mods,
- 'size' => $size,
- );
-}
-
-sub share_perms_scrl_remove_maintainer {
- my($self,$mgr,$u) = @_;
- my $dbh = $mgr->connect;
-
- my $all_mods = $self->all_only_cmods($mgr,$u);
- my @all_mods = sort keys %$all_mods;
- my %labels;
- for my $m (@all_mods) {
- # get the owner for modlist modules that don't have first-come
- my $owner = $all_mods->{$m} || $self->owner_of_module($mgr,$m) || '?';
- $labels{$m} = "$m => $owner";
- }
- my $n = scalar @all_mods;
- return "--NONE--" unless $n;
- my $size = $n > 18 ? 15 : $n;
- $mgr->scrolling_list(
- name => "pause99_share_perms_remome_m",
- multiple => 1,
- values => \@all_mods,
- labels => \%labels,
- size => $size,
- );
-}
-
-sub share_perms_remocos {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m);
- my $req = $mgr->{REQ};
-
- my $u = $self->active_user_record($mgr);
-
- my $db = $mgr->connect;
- my $all_mods = $self->all_pmods($mgr,$u);
- my $all_comaints = $self->all_comaints($mgr,$all_mods,$u);
- if (
- $req->param("SUBMIT_pause99_share_perms_remocos")
- ) {
- eval {
- my @sel = $req->param("pause99_share_perms_remocos_tuples");
- my $sth1 = $db->prepare("DELETE FROM perms WHERE package=? AND userid=?");
- if (@sel) {
- for my $sel (@sel) {
- my($selmod,$otheruser) = $sel =~ /^(\S+)\s--\s(\S+)$/;
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => "You do not seem to be owner of $selmod")
- unless exists $all_mods->{$selmod};
- unless (exists $all_comaints->{$sel}) {
- push @m, "
Cannot handle tuple $sel. If you
- believe, this is a bug, please complain.
";
- next;
- }
- my $ret = $sth1->execute($selmod,$otheruser);
- my $err = "";
- $err = $db->errstr unless defined $ret;
- $ret ||= "";
- warn "DEBUG: selmod[$selmod]ret[$ret]err[$err]";
- if ($ret) {
- push @m, "
Removed $otheruser from co-maintainers of $selmod.
\n";
- } else {
- push @m, "
Error trying to remove $otheruser from co-maintainers of
- $selmod: $err
\n";
- }
- }
- } else {
- push @m, qq{
You need to select one or more packages. Nothing done.
There are no co-maintainers registered to any of
- $u->{userid}'s modules.
};
-
- return @m;
- }
-
- push @m, qq{
Remove co-maintainer status
The scrolling
- list shows you, which packages are associated with other
- maintainers besides yourself. Every line denotes a tuple
- of a namespace and a userid. Select those that you want to
- remove and press Remove
};
- if (@all == 1) {
- # selectboxes with only ine option to select look confusing and
- # better be preselected:
- $req->parameters->set("pause99_share_perms_remocos_tuples",$all[0]);
- }
- push @m, $mgr->scrolling_list(
- 'name' => "pause99_share_perms_remocos_tuples",
- 'multiple' => 1,
- 'values' => \@all,
- 'size' => $size,
- );
- push @m, qq{
};
- push @m, qq{
};
- push @m, qq{
};
- @m;
-}
-
-sub all_comaints {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $all_mods = shift;
- my $u = shift;
- my $result = {};
- my $db = $mgr->connect;
- my $or = join " OR\n", map { "package='$_'" } keys %$all_mods;
- my $sth2 = $db->prepare(qq{SELECT package, userid
- FROM perms
- WHERE userid <> '$u->{userid}' AND ( $or )});
- $sth2->execute;
- while (my($p,$i) = $mgr->fetchrow($sth2,"fetchrow_array")) {
- $result->{"$p -- $i"} = undef;
- warn "p[$p]i[$i]";
- }
- return $result;
-}
-
-sub all_only_cmods {
- my($self,$mgr,$u) = @_;
- my $all_pmods = $self->all_pmods($mgr,$u);
- my $all_mods = $self->all_cmods($mgr,$u);
-
- for my $k (keys %$all_pmods) {
- delete $all_mods->{$k};
- }
- $all_mods;
-}
-
-sub share_perms_remome {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my(@m);
- my $req = $mgr->{REQ};
-
- my $u = $self->active_user_record($mgr);
- my $db = $mgr->connect;
-
- my $all_mods = $self->all_only_cmods($mgr,$u);
-
- if (
- $req->param("SUBMIT_pause99_share_perms_remome")
- ) {
- eval {
- my(@selmods);
- if (@selmods = $req->param("pause99_share_perms_remome_m")
- ) {
- local($db->{RaiseError}) = 0;
- my $sth = $db->prepare("DELETE FROM perms WHERE package=? AND userid=?");
- for my $selmod (@selmods) {
- die PAUSE::HeavyCGI::Exception
- ->new(ERROR => "You do not seem to be co-maintainer of $selmod")
- unless exists $all_mods->{$selmod};
- my $ret = $sth->execute($selmod,$u->{userid});
- my $err = "";
- $err = $db->errstr unless defined $ret;
- $ret ||= "";
- warn "DEBUG: selmod[$selmod]ret[$ret]err[$err]";
- if ($ret) {
- push @m, "
Removed $u->{userid} from co-maintainers of $selmod.
Sorry, there are no modules registered belonging to
- $u->{userid}.
};
-
- return @m;
- }
- push @m, qq{
Select a co-maintainer
Please select one or
- more namespaces for which you want to select a
- co-maintainer, enter the CPAN userid of the co-maintainer
- into the text field and press Make Co-Maintainer
Sorry, there are no modules registered belonging to
- $u->{userid}.
};
-
- return @m; } push @m, qq{
Give up maintainership
- status
Please select one or more namespaces for which you
- want to give up primary maintainership status and press
- Give Up Maintainership Status. Note: you keep co-maintainer
- status after this move. If you want to get rid of that too,
- please visit Give up
- co-maintainership status next.
Sorry, there are no modules registered belonging to
- $u->{userid}.
};
-
- return @m;
- }
-
- push @m, qq{
Pass maintainership status
Please select one
- or more namespaces for which you want to pass primary
- maintainership status, enter the CPAN userid of the new
- maintainer into the text field and press Pass Maintainership
- Status. Note: you keep co-maintainer status after this move.
- If you want to get rid of that too, please visit Give up
- co-maintainership status next.
};
-
- @m;
-}
-
-sub all_pmods {
- my $self = shift;
- my $mgr = shift;
- my $u = shift;
- my $db = $mgr->connect;
- my(%all_mods);
- my $sth2 = $db->prepare(qq{SELECT package
- FROM primeur
- WHERE userid=?});
- $sth2->execute($u->{userid});
- while (my($id) = $mgr->fetchrow($sth2, "fetchrow_array")) {
- $all_mods{$id} = undef;
- }
- $sth2->finish;
- \%all_mods;
-}
-
-sub all_pmods_not_mmods {
- my $self = shift;
- my $mgr = shift;
- my $u = shift;
- my $db = $mgr->connect;
- my(%all_mods);
- my $sth2 = $db->prepare(qq{SELECT package
- FROM primeur
- WHERE userid=?});
- $sth2->execute($u->{userid});
- while (my($id) = $mgr->fetchrow($sth2, "fetchrow_array")) {
- $all_mods{$id} = undef;
- }
- $sth2->finish;
- \%all_mods;
-}
-
-sub all_cmods {
- my $self = shift;
- my $mgr = shift;
- my $u = shift;
- my $db = $mgr->connect;
- my(%all_mods);
- my $sth2 = $db->prepare(qq{SELECT perms.package, primeur.userid
- FROM perms LEFT JOIN primeur
- ON perms.package = primeur.package
- WHERE perms.userid=?});
- $sth2->execute($u->{userid});
- while (my($id, $owner) = $mgr->fetchrow($sth2, "fetchrow_array")) {
- $all_mods{$id} = $owner;
- }
- $sth2->finish;
- \%all_mods;
-}
-
-
-
-
-=pod
-
-Thanks to Slaven Rezic for his help in finding the solution how to
-produce core dumps of apache under Linux. Here are the guts:
-
-Running h2ph is required and beforehand it is recommended to test as
-root something like this:
-
-mkdir tmp
-chown nobody tmp
-cd tmp
-limit coredumpsize 30m
-perl -e '
- require "syscall.ph";
- require "linux/sys.ph";
- require "linux/prctl.ph";
- $user = shift or die;
- my $uid = (getpwnam($user))[2];
- $< = $> = $uid;
- print syscall(&SYS_prctl,&PR_SET_DUMPABLE,1);
- warn $<;
- dump;' nobody
-ls -l core
-
-If this shows a core file when run with the same perl as the
-webserver, then it should succeed on the webserver too.
-
-You will additionally have to set coredumpsize for nobody via
-/etc/security/limits.conf and add CoreDumpDirectory
-/directory/owned/by/nobody to the httpd.conf or do something
-equivalent.
-
-=cut
-
-
-sub coredump {
- my $self = shift;
- my $mgr = shift;
-
- die "The coredump interface was just a testbed to find out how to
- enable coredumps on Linux. Now disabled.";
-
- require "syscall.ph";
- require "linux/sys.ph";
- require "linux/prctl.ph";
- warn syscall(&SYS_prctl,&PR_SET_DUMPABLE,1);
- chdir "/usr/local/apache/cores" or die "Couldn't chdir: $!";
- warn "**************>>>>>>>>>> strace -p $$\n";
- sleep 10;
- require Cwd;
- my $cwd = Cwd::cwd();
- require BSD::Resource;
- my($nowsoft,$nowhard) = BSD::Resource::getrlimit(BSD::Resource::RLIMIT_CORE());
- $mgr->{REQ}->logger({level => 'error', message => "UID[$<]EUID[$>]cwd[$cwd]nowsoft[$nowsoft]nowhard[$nowhard]"});
- CORE::dump;
-}
-
-sub dele_message {
- my($self,$mgr) = @_;
-
- my @m = qq{
Admins can add and delete messages to a message board.
- When a user visits PAUSE they see the pending messages for them and
- are requested to answer to the admin who placed the message. Usage
- scenario: email bounces, google doesn't get us closer to the user,
- that kind of thing. When the cause is settled the admin should
- delete the message to not any longer annoy the user with it. The
- user cannot delete the message.
-
-
To delete messages, click on the radio buttons and then press
- Delete.
};
-
- my $dbh = $mgr->connect;
- my $req = $mgr->{REQ};
- my $sth = $dbh->prepare("SELECT * FROM messages where mfrom=? AND mstatus='active'
- ORDER BY created desc");
- $sth->execute($mgr->{User}{userid});
- if ($sth->rows) {
- if ($req->param('SUBMIT_pause99_dele_message_sub')) {
- # get another handle
- my $sth2 = $dbh->prepare("UPDATE messages set mstatus='deleted'
- WHERE mfrom=? AND c=?");
- for my $m ($req->param('pause99_dele_message_m')) {
- $sth2->execute($mgr->{User}{userid}, $m);
- }
- $sth->execute($mgr->{User}{userid});
- }
- }
- if ($sth->rows) {
- push @m, qq{
Admins can add and delete messages to a message board.
- When a user visits PAUSE they see the pending messages for them and
- are requested to answer to the admin who placed the message. Usage
- scenario: email bounces, google doesn't get us closer to the user,
- that kind of thing. When the cause is settled the admin should
- delete the message to not any longer annoy the user with it. The
- user cannot delete the message.
-
-
To post a message, fill in the form and press
- Submit.
};
-
- my $dbh = $mgr->connect;
- my $req = $mgr->{REQ};
-
- my $mto = $req->param('pause99_post_message_mto');
- $mto = uc $mto;
- my $mess = $req->param('pause99_post_message_mess');
- warn "mto[$mto]mess[$mess]";
-
- my $showform = 0;
- my $regOK = 0;
-
- if ($req->param('SUBMIT_pause99_post_message_sub')) {
- my @errors = ();
- unless ($mto) {
- push @errors, "You must supply a message";
- }
- if ($mto) {
- my $sth = $dbh->prepare("SELECT userid FROM users where userid=?");
- $sth->execute($mto);
- unless ($sth->rows) {
- push @errors, sprintf "Userid %s is not known", $mgr->escapeHTML($mto);
- }
- $sth->finish;
- } else {
- push @errors, "You must supply a userid";
- }
- if( @errors ) {
- push @m, qq{
Error processing form
};
- for (@errors) {
- push @m, "
", "
$_
", "
";
- }
- push @m, qq{
Please retry.
};
- } else {
- # we don't sweat over the time zone, mysql does it in the zone
- # of the server and turning it into UTC seems not worth the
- # effort right now (2003-03-04)
- my $sth = $dbh->prepare("INSERT INTO messages
- (mfrom,mto,created,message)
- VALUES (? ,? ,NOW() ,? )");
- $sth->execute($mgr->{User}{userid},$mto,$mess);
- push @m, sprintf qq{Message to
- %s posted.},
- ($mgr->escapeHTML($mto))x2;
- for my $f (qw(mto mess)) {
- $req->parameters->set("pause99_post_message_$f","");
- }
- }
- }
- for my $arr (
- ['Userid','mto',10,10],
- ['Message','mess',60,255],
- ) {
- push @m, qq{
";
- }
- push @m, qq{};
-
-
- @m;
-}
-
-sub reset_version {
- my pause_1999::edit $self = shift;
- my $mgr = shift;
- my $req = $mgr->{REQ};
- my @m;
- my $u = $self->active_user_record($mgr);
- push @m, qq{};
- my $dbh = $mgr->connect;
- local($dbh->{RaiseError}) = 0;
-
- push @m, qq{
Note: resetting versions is a major inconvenience for
- module users. This page will probably be withdrawn from PAUSE if
- the perl community does not want to allow falling version numbers
- on the CPAN. For now: use with care. Thanks.
-
-
Below you see the packages and version numbers that
- the indexer considers the current and highest version number that
- it has seen so far. By selecting an item in the list and clicking
- Forget, this value is set to undef. This opens the
- way for a Force Reindexing run in which the version of the
- package in the reindexed distribution can become the current.
-
-
Did I say, this operation should not be done lightly? Because
- users of the module out there may still have that higher version
- installed and so will not notice the newer but lower-numbered
- release. Let me repeat: please make responsible use of this
- page.
-
-
Q: So why is this page up at all?
-
-
A: Combine a multi-module-distro with a small mistake in an
- older release or a bug in the PAUSE indexer. In such a case you
- will be happy to use this page and nobody else will ever notice
- there was a problem.
-
-};
- my $blurb = "";
- my($usersubstr) = sprintf("%s/%s/%s/",
- substr($u->{userid},0,1),
- substr($u->{userid},0,2),
- $u->{userid},
- );
- my($usersubstrlen) = length $usersubstr;
- my $sqls = "SELECT package, version, dist FROM packages
- WHERE substring(dist,1,$usersubstrlen) = ?";
- my $sths = $dbh->prepare($sqls);
- if ($req->param('SUBMIT_pause99_reset_version_forget')) {
- my $sqls2 = "SELECT version FROM packages
- WHERE package = ? AND substring(dist,1,$usersubstrlen) = ?";
- my $sths2 = $dbh->prepare($sqls2);
- my $sqlu = "UPDATE packages
- SET version='undef'
- WHERE package = ? AND substring(dist,1,$usersubstrlen) = ?";
- my $sthu = $dbh->prepare($sqlu);
- PKG: foreach my $f ($req->param('pause99_reset_version_PKG')) {
- $sths2->execute($f,$usersubstr);
- my($version) = $sths2->fetchrow_array;
- next PKG if $version eq 'undef';
- my $ret = $sthu->execute($f,$usersubstr);
- $blurb .= sprintf(
- "%s: %s '%s' => 'undef'\n",
- $ret==0 ? "Not reset" : "Reset",
- $f,
- $version,
- );
- }
- }
- if ($blurb) {
-
- $blurb = sprintf(qq{According to a request by %s the following
-packages have their recorded version set to 'undef'.
-
-%s
-
-%s},
- $mgr->{User}{fullname},
- $blurb,
- $Yours,
- );
- my %umailset;
- my $name = $u->{asciiname} || $u->{fullname} || "";
- my $Uname = $mgr->{User}{asciiname} || $mgr->{User}{fullname} || "";
-
- if ($u->{secretemail}) {
- $umailset{qq{"$name" <$u->{secretemail}>}} = 1;
- } elsif ($u->{email}) {
- $umailset{qq{"$name" <$u->{email}>}} = 1;
- }
- if ($mgr->{User}{userid} ne $u->{userid}) {
- if ($mgr->{User}{secretemail}) {
- $umailset{qq{"$Uname" <$mgr->{User}{secretemail}>}} = 1;
- }elsif ($mgr->{User}{email}) {
- $umailset{qq{"$Uname" <$mgr->{User}{email}>}} = 1;
- }
- }
- $umailset{$PAUSE::Config->{ADMIN}} = 1;
- my $header = {
- Subject => "Version reset for $u->{userid}"
- };
- $mgr->send_mail_multi([keys %umailset], $header, $blurb);
-
- push @m, qq{
This is perl %s;},
- $bin,
- );
- push @l, sprintf(qq{ cf_time %s; },
- $Config::Config{cf_time},
- );
-
- push @l, qq{when you run into problems try Port 8443 (https),
- where perl 5.8.7 should be running (or Port 8000
- if you need http).
};
- use HTTP::Date;
- my $httptime = HTTP::Date::time2str($downtime);
- use Time::Duration;
- my $delta = $downtime - time;
- my $expr = Time::Duration::duration($delta);
- my $willlast_dur = Time::Duration::duration($willlast);
-
- push @l, qq{
Scheduled downtime On
-$httptime (that is in $expr) PAUSE will be closed for maintainance
-work. The estimated downtime is $willlast_dur.
}; #};
-
- push @l, qq{
};
-
- } elsif (time < $downtime+$willlast) {
- my $user = $mgr->{User}{userid}; # if closed and somebody comes
- # here, it currently is always
- # ANDK
-
- my $closed_text = $mgr->{REQ}->env->{'psgix.notes'}{CLOSED};
-
- push @l, qq{
Hi $user, you
-see the site now but it is closed for maintainance.
-Please be careful not to disturb the database operation. Expect
-failures everywhere. Do not edit anything, it may get lost. Other
-users get the following text: