view release on metacpan or  search on metacpan

lib/CGI/Kwiki.pm  view on Meta::CPAN

package CGI::Kwiki;
$VERSION = '0.18';
@EXPORT = qw(attribute);
@CHAR_CLASSES = qw($ADMIN $UPPER $LOWER $ALPHANUM $WORD $WIKIWORD);
@EXPORT_OK = (@CHAR_CLASSES, qw(encode decode escape unescape));
%EXPORT_TAGS = (char_classes => [@CHAR_CLASSES]);

use strict;
use base 'Exporter';
use CGI qw(-no_debug);

use vars qw($ADMIN);
$ADMIN ||= 0;

use vars qw($UPPER $LOWER $ALPHANUM $WORD $WIKIWORD);
if ($] < 5.008) {
    $UPPER    = "A-Z\xc0-\xde";
    $LOWER    = "a-z\xdf-\xff";
    $ALPHANUM = "A-Za-z0-9\xc0-\xff";
    $WORD     = "A-Za-z0-9\xc0-\xff_";
    $WIKIWORD = $WORD;
}
else {
    $UPPER    = '\p{UppercaseLetter}';
    $LOWER    = '\p{LowercaseLetter}';
    $ALPHANUM = '\p{Letter}\p{Number}';
    $WORD     = '\p{Letter}\p{Number}\p{ConnectorPunctuation}';
    $WIKIWORD = "$UPPER$LOWER\\p{Number}\\p{ConnectorPunctuation}";
}

# All classes defined by CGI::Kwiki
sub classes {
    qw(
        new
        config
        config_yaml
        driver
        cgi
        cookie
        database
        metadata
        backup
        display
        edit
        formatter
        template
        plugin
        search
        changes
        prefs
        pages
        slides
        javascript
        style
        scripts
        blog
        i18n
        import
    )
}

# Traditional CGI runner
sub run_cgi {
    eval "use CGI::Carp qw(fatalsToBrowser)";
    die $@ if $@;

    my $cgi_class = (eval { require CGI::Fast; 1 } ? 'CGI::Fast' : 'CGI');
    while (my $cgi = $cgi_class->new) {
        my $driver = load_driver();
        $CGI::Kwiki::user_name = 
            $ENV{REMOTE_USER} || 
                CGI->remote_host();
        my $html = $driver->drive;
        if (ref $html) {
            print CGI::redirect($html->{redirect});
        } else {
            my $header = $driver->cookie->header;
            $driver->encode($header);
            $driver->encode($html);
            print $header, $html;
        }
	last if $cgi_class eq 'CGI';
    }
}

# Speedy mod_perl runner
sub handler {
    my ($r) = @_;
    my $base_directory = $r->location;
    chdir($base_directory) 
      or die "Can't chdir to '$base_directory'\n";
    eval "use Apache::Constants qw(OK REDIRECT)";
    die $@ if $@;

    my $driver = load_driver();
    $CGI::Kwiki::user_name = 
      $ENV{REMOTE_USER} ||
      $r->get_remote_host || 
      $r->connection->remote_ip;
    my $html = $driver->drive;
    if (ref $html) {
        $r->method('GET');
        $r->headers_in->unset('Content-length');
        $r->header_out('Location' => $html->{redirect});
        $r->status(&REDIRECT);
        $r->send_http_header;
    }
    else {
        $r->print($driver->cookie->header, $html);
        $r->status(&OK);
    }
    return;
}

# A generic class attribute set/get method generator
sub attribute {
    my ($attribute) = @_;
    my $pkg = caller;
    no strict 'refs';
    local $SIG{__WARN__} = sub {}; # shut up 'redefined' warnings
    *{"${pkg}::$attribute"} =
      sub {
          my $self = shift;
          return $self->{$attribute} unless @_;
          $self->{$attribute} = shift;
          return $self;
      };
}

# The most basic attributes inherited by almost all classes
attribute 'driver';
attribute 'config';
attribute 'cgi';
attribute 'plugin';
attribute 'template';
attribute 'formatter';
attribute 'database';
attribute 'metadata';
attribute 'backup';
attribute 'prefs';
attribute 'i18n';

# Constructor inherited by most classes
sub new {
    my ($class, $driver) = @_;
    my $self = bless {}, $class;
    $self->driver($driver);
    $self->config($driver->config);
    $self->cgi($driver->cgi);
    $self->plugin($driver->plugin);
    $self->template($driver->template);
    $self->formatter($driver->formatter);
    $self->database($driver->database);
    $self->metadata($driver->metadata);
    $self->backup($driver->backup);
    $self->prefs($driver->prefs);
    return $self;
}

sub load_driver {
    require CGI::Kwiki::Config;
    my $config = CGI::Kwiki::Config->new;
    my $driver_class = $config->driver_class;
    eval qq{ require $driver_class }; die $@ if $@;
    my $driver = $driver_class->new($config);
    $config->driver($driver);
    return $driver;
}

# I run a development Kwiki in the mykwiki/ subdirectory of CGI-Kwiki's
# development directory. I edit all the data files and templates in
# there, and then I use this rebuild method to pack them into the DATA
# sections of their respective modules.
sub rebuild {
    my $filename = $0;
    my $module = $filename;
    $module =~ s/.*lib\/(?=CGI)//;
    $module =~ s/\.pm$//;
    $module =~ s/\//::/g;
    my $self = $module->new(load_driver);
    my $data = '';
    my ($directory) = $self->directory;
    for my $file (sort glob("mykwiki/$directory/*")) {
        my $label = $file;
        $label =~ s/.*\///;
        $label =~ s/\.\w+$//;
        next if $label =~ /^%/; # XXX exclude Chinese pages
        $data .= "__${label}__\n";
        open FILE, $file or die $!;
        $data .= do {local $/; <FILE>};
        close FILE;
    }
    $data =~ s/^=/^=/gm;
    open MODULE, $filename
      or die $!;
    my $module_text = do {local $/;<MODULE>};
    close MODULE;
    unless ($module_text =~ /^(.*__DATA__\n.*=cut\n\n)/s) {
        die "Can't parse $filename\n";
    }
    $module_text = $1 . $data;
    open MODULE, "> $filename"
      or die "Can't open $filename of output:\n$!";
    print MODULE $module_text;
    close MODULE;
    print "$filename updated\n";
    exit 0;
}

# Support for unpacking the DATA files attached to many CGI::Kwiki classes
sub create_files {
    my ($self) = @_;
    umask 0000;
    my $package = ref($self);
    my @files = split /^__([$WORD\/]+)__\n/m, $self->data;