322 lines
10 KiB
Perl
322 lines
10 KiB
Perl
# Module of TWiki Enterprise Collaboration Platform, http://TWiki.org/
|
|
#
|
|
# Copyright (C) 1999-2007 Peter Thoeny, peter@thoeny.org
|
|
# and TWiki Contributors. All Rights Reserved. TWiki Contributors
|
|
# are listed in the AUTHORS file in the root of this distribution.
|
|
# NOTE: Please extend that file, not this notice.
|
|
#
|
|
# This program is free software; you can redistribute it and/or
|
|
# modify it under the terms of the GNU General Public License
|
|
# as published by the Free Software Foundation; either version 2
|
|
# of the License, or (at your option) any later version. For
|
|
# more details read LICENSE in the root of this distribution.
|
|
#
|
|
# This program is distributed in the hope that it will be useful,
|
|
# but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
|
|
#
|
|
# As per the GPL, removal of this notice is prohibited.
|
|
|
|
=pod
|
|
|
|
---+ package TWiki::UI
|
|
|
|
Service functions used by the UI packages
|
|
|
|
=cut
|
|
|
|
package TWiki::UI;
|
|
|
|
use strict;
|
|
use Error qw( :try );
|
|
use Assert;
|
|
use CGI::Carp qw( fatalsToBrowser );
|
|
use CGI qw( :cgi -any );
|
|
use TWiki;
|
|
use TWiki::OopsException;
|
|
|
|
sub TRACE_PASSTHRU {
|
|
# Change to a 1 to trace passthrough
|
|
0;
|
|
};
|
|
|
|
=pod
|
|
|
|
---++ StaticMethod run( \&method, ... )
|
|
|
|
Entry point for execution of a UI function. The parameter is a
|
|
reference to the method.
|
|
|
|
... is a list of name-value pairs that define initial context identifiers
|
|
that must be set during initPlugin. This set will be extended to include
|
|
command_line if the script is detected as being run outside the browser.
|
|
|
|
=cut
|
|
|
|
sub run {
|
|
my ( $method, %initialContext ) = @_;
|
|
|
|
my ( $query, $pathInfo, $user, $url, $topic );
|
|
|
|
# Use unbuffered IO
|
|
$| = 1;
|
|
|
|
# -------------- Only needed to work around an Apache 2.0 bug on Unix
|
|
# OPTIONAL
|
|
# If you are running TWiki on Apache 2.0 on Unix you might experience
|
|
# TWiki scripts hanging forever. This is a known Apache 2.0 bug. A fix is
|
|
# available at http://issues.apache.org/bugzilla/show_bug.cgi?id=22030.
|
|
# You are recommended to patch your Apache installation.
|
|
#
|
|
# As a workaround, uncomment ONE of the lines below. As a drawback,
|
|
# errors will not be reported to the browser via CGI::Carp any more.
|
|
|
|
# Opening STDERR here and not in the BEGIN block as some perl accelerators
|
|
# close STDERR after each request so that we need to reopen it here again
|
|
|
|
# open(STDERR, ">>/dev/null"); # throw away cgi script errors, or
|
|
# open(STDERR, ">>$TWiki::cfg{DataDir}/error.log"); # redirect errors to a log file
|
|
|
|
|
|
if( DEBUG || $TWiki::cfg{WarningsAreErrors} ) {
|
|
# For some mysterious reason if this handler is defined
|
|
# in 'new TWiki' it gets lost again before we get here
|
|
$SIG{__WARN__} = sub { die @_; };
|
|
}
|
|
|
|
if( $ENV{'GATEWAY_INTERFACE'} ) {
|
|
# script is called by browser
|
|
$query = new CGI;
|
|
|
|
if( $TWiki::cfg{DrainStdin} ) {
|
|
# drain STDIN. This may be necessary if the script is called
|
|
# due to a redirect and the original query was a POST. In this
|
|
# case the web server is waiting to write the POST data to
|
|
# this script's STDIN, but CGI.pm won't drain STDIN as it is
|
|
# seeing a GET because of the redirect, not a POST. This script
|
|
# tries to write to STDOUT, which goes back to the web server,
|
|
# but the server isn't paying attention to that (as its waiting for
|
|
# the script to _read_, not _write_), and everything blocks.
|
|
# Some versions of apache seem to be more susceptible than others to
|
|
# this.
|
|
my $content_length =
|
|
defined($ENV{'CONTENT_LENGTH'}) ? $ENV{'CONTENT_LENGTH'} : 0;
|
|
read(STDIN, my $buf, $content_length, 0 ) if $content_length;
|
|
}
|
|
my $cache = $query->param('twiki_redirect_cache');
|
|
if ($cache) {
|
|
$cache = TWiki::Sandbox::untaintUnchecked($cache);
|
|
# Read cached post parameters
|
|
if (open(F, '<'.$cache)) {
|
|
local $/;
|
|
if (TRACE_PASSTHRU) {
|
|
print STDERR "Passthru: Loading cache for ",
|
|
$query->url(),'?',$query->query_string(),"\n";
|
|
print STDERR <F>,"\n";
|
|
close(F);
|
|
open(F, '<'.$cache);
|
|
}
|
|
$query = new CGI(\*F);
|
|
close(F);
|
|
unlink($cache);
|
|
print STDERR "Passtrhru: Loaded and unlinked $cache\n"
|
|
if TRACE_PASSTHRU;
|
|
} else {
|
|
print STDERR "Passtrhru: Could not find $cache\n"
|
|
if TRACE_PASSTHRU;
|
|
}
|
|
}
|
|
} else {
|
|
# script is called by cron job or user
|
|
$initialContext{command_line} = 1;
|
|
|
|
$user = $TWiki::cfg{SuperAdminGroup};
|
|
$query = new CGI();
|
|
while( scalar( @ARGV )) {
|
|
my $arg = shift( @ARGV );
|
|
if ( $arg =~ /^-?([A-Za-z0-9_]+)$/o ) {
|
|
my $name = $1;
|
|
my $arg = TWiki::Sandbox::untaintUnchecked( shift( @ARGV ));
|
|
if( $name eq 'user' ) {
|
|
$user = $arg;
|
|
} else {
|
|
$query->param( -name => $name, -value => $arg );
|
|
}
|
|
} else {
|
|
$query->path_info( TWiki::Sandbox::untaintUnchecked( $arg ));
|
|
}
|
|
}
|
|
}
|
|
|
|
my $session = new TWiki( $user, $query, \%initialContext );
|
|
|
|
local $SIG{__DIE__} = \&Carp::confess;
|
|
|
|
try {
|
|
$session->{loginManager}->checkAccess();
|
|
&$method( $session );
|
|
} catch TWiki::AccessControlException with {
|
|
my $e = shift;
|
|
unless( $session->{loginManager}->forceAuthentication() ) {
|
|
# Client did not want to authenticate, perhaps because
|
|
# we are already authenticated.
|
|
my $url = $session->getOopsUrl('accessdenied',
|
|
def => 'topic_access',
|
|
web => $e->{web},
|
|
topic => $e->{topic},
|
|
params => [ $e->{mode},
|
|
$e->{reason} ]);
|
|
$session->redirect( $url, 1 );
|
|
}
|
|
|
|
} catch TWiki::OopsException with {
|
|
my $e = shift;
|
|
my $url = $session->getOopsUrl( $e );
|
|
$session->redirect( $url, $e->{keep} );
|
|
|
|
} catch Error::Simple with {
|
|
my $e = shift;
|
|
print "Content-type: text/plain\n\n";
|
|
if( DEBUG ) {
|
|
# output the full message and stacktrace to the browser
|
|
print $e->stringify();
|
|
} else {
|
|
my $mess = $e->stringify();
|
|
print STDERR $mess;
|
|
$session->writeWarning( $mess );
|
|
# tell the browser where to look for more help
|
|
print 'TWiki detected an internal error - please check your TWiki logs and webserver logs for more information.'."\n\n";
|
|
$mess =~ s/ at .*$//s;
|
|
# cut out pathnames from public announcement
|
|
$mess =~ s#/[\w./]+#path#g;
|
|
print $mess;
|
|
}
|
|
} otherwise {
|
|
print "Content-type: text/plain\n\n";
|
|
print "Unspecified error";
|
|
};
|
|
|
|
$session->finish();
|
|
}
|
|
|
|
=pod twiki
|
|
|
|
---++ StaticMethod checkWebExists( $session, $web, $topic, $op )
|
|
|
|
Check if the web exists. If it doesn't, will throw an oops exception.
|
|
$op is the user operation being performed.
|
|
|
|
=cut
|
|
|
|
sub checkWebExists {
|
|
my ( $session, $webName, $topic, $op ) = @_;
|
|
ASSERT($session->isa( 'TWiki')) if DEBUG;
|
|
|
|
unless ( $session->{store}->webExists( $webName ) ) {
|
|
throw
|
|
TWiki::OopsException( 'accessdenied',
|
|
def => 'no_such_web',
|
|
web => $webName,
|
|
topic => $topic,
|
|
params => $op );
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ StaticMethod topicExists( $session, $web, $topic, $op ) => boolean
|
|
|
|
Check if the given topic exists, throwing an OopsException
|
|
if it doesn't. $op is the user operation being performed.
|
|
|
|
=cut
|
|
|
|
sub checkTopicExists {
|
|
my ( $session, $webName, $topic, $op ) = @_;
|
|
ASSERT($session->isa( 'TWiki')) if DEBUG;
|
|
|
|
unless( $session->{store}->topicExists( $webName, $topic )) {
|
|
throw TWiki::OopsException( 'accessdenied',
|
|
def => 'no_such_topic',
|
|
web => $webName,
|
|
topic => $topic,
|
|
params => $op );
|
|
}
|
|
}
|
|
|
|
=pod twiki
|
|
|
|
---++ StaticMethod checkMirror( $session, $web, $topic )
|
|
|
|
Checks if this web is a mirror web, throwing an OopsException
|
|
if it is.
|
|
|
|
=cut
|
|
|
|
sub checkMirror {
|
|
my ( $session, $webName, $topic ) = @_;
|
|
ASSERT($session->isa( 'TWiki')) if DEBUG;
|
|
|
|
my( $mirrorSiteName, $mirrorViewURL ) =
|
|
$session->readOnlyMirrorWeb( $webName );
|
|
|
|
return unless ( $mirrorSiteName );
|
|
|
|
throw TWiki::OopsException( 'mirror',
|
|
web => $webName,
|
|
topic => $topic,
|
|
params => [ $mirrorSiteName,
|
|
$mirrorViewURL ] );
|
|
}
|
|
|
|
=pod twiki
|
|
|
|
---++ StaticMethod checkAccess( $web, $topic, $mode, $user )
|
|
|
|
Check if the given mode of access by the given user to the given
|
|
web.topic is permissible, throwing a TWiki::OopsException if not.
|
|
|
|
=cut
|
|
|
|
sub checkAccess {
|
|
my ( $session, $web, $topic, $mode, $user ) = @_;
|
|
ASSERT($session->isa( 'TWiki')) if DEBUG;
|
|
|
|
unless( $session->{security}->checkAccessPermission(
|
|
$mode, $user, undef, undef, $topic, $web )) {
|
|
throw TWiki::OopsException( 'accessdenied',
|
|
def => 'topic_access',
|
|
web => $web,
|
|
topic => $topic,
|
|
params =>
|
|
[ $mode,
|
|
$session->{security}->getReason()]);
|
|
}
|
|
}
|
|
|
|
=pod
|
|
|
|
---++ StaticMethod readTemplateTopic( $session, $theTopicName ) -> ( $meta, $text )
|
|
|
|
Read a topic from the TWiki web, or if that fails from the current
|
|
web.
|
|
|
|
=cut
|
|
|
|
sub readTemplateTopic {
|
|
my( $session, $theTopicName ) = @_;
|
|
ASSERT($session->isa( 'TWiki')) if DEBUG;
|
|
|
|
$theTopicName =~ s/$TWiki::cfg{NameFilter}//go;
|
|
|
|
my $web = $TWiki::cfg{SystemWebName};
|
|
if( $session->{store}->topicExists( $session->{webName}, $theTopicName )) {
|
|
# try to read from current web, if found
|
|
$web = $session->{webName};
|
|
}
|
|
return $session->{store}->readTopic(
|
|
$session->{user}, $web, $theTopicName, undef );
|
|
}
|
|
|
|
1;
|