colas@0: #
colas@0: # TWiki Enterprise Collaboration Platform, http://TWiki.org/
colas@0: #
colas@0: # Copyright (C) 2000-2006 TWiki Contributors.
colas@0: #
colas@0: # This program is free software; you can redistribute it and/or
colas@0: # modify it under the terms of the GNU General Public License
colas@0: # as published by the Free Software Foundation; either version 2
colas@0: # of the License, or (at your option) any later version. For
colas@0: # more details read LICENSE in the root of this distribution.
colas@0: #
colas@0: # This program is distributed in the hope that it will be useful,
colas@0: # but WITHOUT ANY WARRANTY; without even the implied warranty of
colas@0: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
colas@0: #
colas@0: # As per the GPL, removal of this notice is prohibited.
colas@0: #
colas@0: # This is both the factory for UIs and the base class of UI constructors.
colas@0: # A UI is the V part of the MVC model used in configure.
colas@0: #
colas@0: # Each structural entity in a configure screen has a UI type, either
colas@0: # stored directly in the entity or indirectly in the type associated
colas@0: # with a value. The UI type is used to guide a visitor which is run
colas@0: # over the structure to generate the UI.
colas@0: #
colas@0: package TWiki::Configure::UI;
colas@0: 
colas@0: use strict;
colas@0: use File::Spec;
colas@0: use FindBin;
colas@0: 
colas@0: use vars qw ($totwarnings $toterrors);
colas@0: 
colas@0: sub new {
colas@0:     my ($class, $item) = @_;
colas@0: 
colas@0:     Carp::confess unless $item;
colas@0: 
colas@0:     my $this = bless( { item => $item }, $class);
colas@0:     $this->{item} = $item;
colas@0: 
colas@0:     $this->{bin} = $FindBin::Bin;
colas@0:     my @root = File::Spec->splitdir($this->{bin});
colas@0:     pop(@root);
colas@0:     $this->{root} = File::Spec->catfile(@root, '');
colas@0: 
colas@0:     return $this;
colas@0: }
colas@0: 
colas@0: sub findRepositories {
colas@0:     my $this = shift;
colas@0:     unless (defined($this->{repositories})) {
colas@0:         my $replist = '';
colas@0:         $replist .= $TWiki::cfg{ExtensionsRepositories}
colas@0:           if defined $TWiki::cfg{ExtensionsRepositories};
colas@0:         $replist .= "$ENV{TWIKI_REPOSITORIES};" # DEPRECATED
colas@0:           if defined $ENV{TWIKI_REPOSITORIES};  # DEPRECATED
colas@0:         $replist = ";$replist;";
colas@0:         while ($replist =~ s/[;\s]+(.*?)=\((.*?),(.*?)(?:,(.*?),(.*?))?\)\s*;/;/) {
colas@0:             push(@{$this->{repositories}},
colas@0:                  { name => $1, data => $2, pub => $3});
colas@0:         }
colas@0:     }
colas@0: }
colas@0: 
colas@0: sub getRepository {
colas@0:     my ($this, $reponame) = @_;
colas@0:     foreach my $place (@{$this->{repositories}}) {
colas@0:         return $place if $place->{name} eq $reponame;
colas@0:     }
colas@0:     return undef;
colas@0: }
colas@0: 
colas@0: # Static UI factory
colas@0: # UIs *must* exist
colas@0: sub loadUI {
colas@0:     my ($id, $item) = @_;
colas@0:     $id = 'TWiki::Configure::UIs::'.$id;
colas@0:     my $ui;
colas@0: 
colas@0:     eval "use $id; \$ui = new $id(\$item);";
colas@0: 
colas@0:     return undef if (!$ui && $@);
colas@0: 
colas@0:     return $ui;
colas@0: }
colas@0: 
colas@0: # Static checker factory
colas@0: # Checkers *need not* exist
colas@0: sub loadChecker {
colas@0:     my ($id, $item) = @_;
colas@0:     $id =~ s/}{/::/g;
colas@0:     $id =~ s/[}{]//g;
colas@0:     $id =~ s/'//g;
colas@0:     $id =~ s/-/_/g;
colas@0:     my $checkClass = 'TWiki::Configure::Checkers::'.$id;
colas@0:     my $checker;
colas@0: 
colas@0:     eval "use $checkClass; \$checker = new $checkClass(\$item);";
colas@0:     # Can't locate errors are OK
colas@0:     die $@ if ($@ && $@ !~ /Can't locate /);
colas@0: 
colas@0:     return $checker;
colas@0: }
colas@0: 
colas@0: # Returns a response object as described in TWiki::Net
colas@0: sub getUrl {
colas@0:     my ($this, $url) = @_;
colas@0: 
colas@0:     require TWiki::Net;
colas@0:     my $tn = new TWiki::Net();
colas@0:     my $response = $tn->getExternalResource($url);
colas@0:     $tn->finish();
colas@0:     return $response;
colas@0: }
colas@0: 
colas@0: # STATIC Used by a whole bunch of things that just need to show a key-value row
colas@0: # (called as a method, i.e. with class as first parameter)
colas@0: sub setting {
colas@0:     my $this = shift;
colas@0:     my $key = shift;
colas@0:     return CGI::Tr(CGI::td({class=>'firstCol'}, $key).
colas@0:                    CGI::td({class=>'secondCol'}, join(' ', @_)))."\n";
colas@0: }
colas@0: 
colas@0: # Generate a foldable block (twisty). This is a DIV with a table in it
colas@0: # that contains the settings and doc rows.
colas@0: sub foldableBlock {
colas@0:     my( $this, $head, $attr, $body ) = @_;
colas@0:     my $headText = $head . CGI::span({ class => 'blockLinkAttribute' }, $attr);
colas@0:     $body = CGI::start_table({width => '100%', -border => 0, -cellspacing => 0, -cellpadding => 0}).$body.CGI::end_table();
colas@0:     my $mess = $this->collectMessages($this->{item});
colas@0: 
colas@0:     my $anchor = $this->_makeAnchor( $head );
colas@0:     my $id = $anchor;
colas@0:     my $blockId = $id;
colas@0:     my $linkId = 'blockLink'.$id;
colas@0:     my $linkAnchor = $anchor.'link';
colas@0:     return CGI::a({ name => $linkAnchor }).
colas@0:       CGI::a({id => $linkId,
colas@0:               class => 'blockLink blockLinkOff',
colas@0:               href => '#'.$linkAnchor,
colas@0:               rel => 'nofollow',
colas@0:               onclick => 'foldBlock("' . $id . '"); return false;'
colas@0:              },
colas@0:              $headText.$mess).
colas@0:                CGI::div( {id => $blockId,
colas@0:                           class=> 'foldableBlock foldableBlockClosed'
colas@0:                          }, $body ).
colas@0:                            "\n";
colas@0: }
colas@0: 
colas@0: # encode a string to make an HTML anchor
colas@0: sub _makeAnchor {
colas@0:     my ($this, $str) = @_;
colas@0: 
colas@0:     $str =~ s/\s(\w)/uc($1)/ge;
colas@0:     $str =~ s/\W//g;
colas@0:     return $str;
colas@0: }
colas@0: 
colas@0: sub NOTE {
colas@0:     my $this = shift;
colas@0:     return CGI::p({class=>"info"}, join("\n",@_));
colas@0: }
colas@0: 
colas@0: # a warning
colas@0: sub WARN {
colas@0:     my $this = shift;
colas@0:     $this->{item}->inc('warnings');
colas@0:     $totwarnings++;
colas@0:     return CGI::div(CGI::span({class=>'warn'},
colas@0:                               CGI::strong('Warning: ').join("\n",@_)));
colas@0: }
colas@0: 
colas@0: # an error
colas@0: sub ERROR {
colas@0:     my $this = shift;
colas@0:     $this->{item}->inc('errors');
colas@0:     $toterrors++;
colas@0:     return CGI::div(CGI::span({class=>'error'},
colas@0:                               CGI::strong('Error: ').join("\n",@_)));
colas@0: }
colas@0: 
colas@0: # Used in place of CGI::hidden, which is broken in some versions.
colas@0: # Assumes $name does not need to be encoded
colas@0: # HTML encodes the value
colas@0: sub hidden {
colas@0:     my ($this, $name, $value) = @_;
colas@0:     $value ||= '';
colas@0:     $value =~ s/([[\x01-\x09\x0b\x0c\x0e-\x1f"%&'*<=>@[_\|])/'&#'.ord($1).';'/ge;
colas@0: 	return '<input type="hidden" name="'.$name.'" value="'.$value.'" />';
colas@0: }
colas@0: 
colas@0: # Invoked to confirm authorisation, and handle password changes. The password
colas@0: # is changed in $TWiki::cfg, a change which is then detected and written when
colas@0: # the configuration file is actually saved.
colas@0: sub authorised {
colas@0:     my $pass = $TWiki::query->param('cfgAccess');
colas@0: 
colas@0:     # The first time we get here is after the "next" button is hit. A password
colas@0:     # won't have been defined yet; so the authorisation must fail to force
colas@0:     # a prompt.
colas@0:     if (!defined($pass)) {
colas@0:         return 0;
colas@0:     }
colas@0: 
colas@0:     # If we get this far, a password has been given. Check it.
colas@0:     if (!$TWiki::cfg{Password} && !$TWiki::query->param('confCfgP')) {
colas@0:         # No password passed in, and TWiki::cfg doesn't contain a password
colas@0:         print CGI::div({class=>'error'}, <<'HERE');
colas@0: WARNING: You have not defined a password. You must define a password before
colas@0: you can save.
colas@0: HERE
colas@0:         return 0;
colas@0:     }
colas@0: 
colas@0:     # If a password has been defined, check that it has been used
colas@0:     if ($TWiki::cfg{Password} &&
colas@0:         crypt($pass, $TWiki::cfg{Password}) ne $TWiki::cfg{Password}) {
colas@0:         print CGI::div({class=>'error'}, "Password incorrect");
colas@0:         return 0;
colas@0:     }
colas@0: 
colas@0:     # Password is correct, or no password defined
colas@0:     # Change the password if so requested
colas@0:     my $newPass = $TWiki::query->param('newCfgP');
colas@0: 
colas@0:     if ($newPass) {
colas@0:         my $confPass = $TWiki::query->param('confCfgP') || '';
colas@0:         if ($newPass ne $confPass) {
colas@0:             print CGI::div({class=>'error'},
colas@0:               'New password and confirmation do not match');
colas@0:             return 0;
colas@0:         }
colas@0:         $TWiki::cfg{Password} = _encode($newPass);
colas@0:         print CGI::div({class=>'error'}, 'Password changed');
colas@0:     }
colas@0: 
colas@0:     return 1;
colas@0: }
colas@0: 
colas@0: 
colas@0: sub collectMessages {
colas@0:     my $this = shift;
colas@0:     my ($item)  =  @_;
colas@0: 
colas@0:     my $warnings      =  $item->{warnings} || 0;
colas@0:     my $errors        =  $item->{errors} || 0;
colas@0:     my $errorsMess    =  "$errors error"     .  (($errors   > 1) ? 's' : '');
colas@0:     my $warningsMess  =  "$warnings warning" .  (($warnings > 1) ? 's' : '');
colas@0:     my $mess          =  '';
colas@0:     $mess .= ' ' . CGI::span({class=>'error'}, $errorsMess) if $errors;
colas@0:     $mess .= ' ' . CGI::span({class=>'warn'}, $warningsMess) if $warnings;
colas@0: 
colas@0:     return $mess;
colas@0: }
colas@0: 
colas@0: sub _encode {
colas@0:     my $pass = shift;
colas@0:     my @saltchars = ( 'a'..'z', 'A'..'Z', '0'..'9', '.', '/' );
colas@0:     my $salt = $saltchars[int(rand($#saltchars+1))] .
colas@0:       $saltchars[int(rand($#saltchars+1)) ];
colas@0:     return crypt($pass, $salt);
colas@0: }
colas@0: 
colas@0: 1;