CGI::Kwiki - A Quickie Wiki that's not too Tricky

    > mkdir cgi-bin/my-kwiki
    > cd cgi-bin/my-kwiki
    > kwiki-install

    Kwiki software installed! Point your browser at this location.

    config_class:      CGI::Kwiki::Config
    driver_class:      CGI::Kwiki::Driver
    cgi_class:         CGI::Kwiki::CGI
    cookie_class:      CGI::Kwiki::Cookie
    database_class:    CGI::Kwiki::Database
    metadata_class:    CGI::Kwiki::Metadata
    display_class:     CGI::Kwiki::Display
    edit_class:        CGI::Kwiki::Edit
    formatter_class:   CGI::Kwiki::Formatter
    template_class:    CGI::Kwiki::Template
    search_class:      CGI::Kwiki::Search
    changes_class:     CGI::Kwiki::Changes
    prefs_class:       CGI::Kwiki::Prefs
    pages_class:       CGI::Kwiki::Pages
    slides_class:      CGI::Kwiki::Slides
    javascript_class:  CGI::Kwiki::Javascript
    style_class:       CGI::Kwiki::Style
    scripts_class:     CGI::Kwiki::Scripts

    formatter_class: MyKwikiFormatter

    package MyKwikiFormatter;
    use base 'CGI::Kwiki::Formatter';

    sub bold {
        my ($self, $text) = @_;
        $text =~ s!'''(.*?)'''!<b>$1</b>!g;
        return $text;
    }

    1;

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;
    die $@ if $@;
    shift @files;
    my %files = @files;
    for my $file (keys %files) {
        my ($directory, $perms) = $self->directory($file);
        $perms ||= 0755;
        if (not -d $directory) {
            mkdir($directory, $perms);
        }
        $self->create_file(
            "$directory/" .  $self->name($file) . $self->suffix($file),
            $self->render_template($files{$file})
        );
    }
}

sub create_file {
    my ($self, $file_path, $content) = @_;
    open FILE, "> $file_path"
      or die "Can't open $file_path for output:\n$!";
    print FILE $content;
    close FILE;
    $self->perms($file_path);
}

sub directory { '.' }
sub suffix { '' }
sub name { $_[1] }
sub render_template { $_[1] }
sub perms {}
sub data {
    my ($self) = @_;
    my $package = ref($self);
    local $/;
    my $data = eval "package $package; <DATA>";
    die $@ if $@;
    return $data;
}

sub decode {
    my ($self) = @_;
    utf8::decode($_[1]) if $self->use_utf8 and defined $_[1];
    return $_[1] if defined wantarray;
}

sub encode {
    my ($self) = @_;
    utf8::encode($_[1]) if $self->use_utf8 and defined $_[1];
    return $_[1] if defined wantarray;
}

sub escape {
    my ($self, $data) = @_;
    $self->encode($data);
    return CGI::Util::escape($data);
}

sub unescape {
    my ($self, $data) = @_;
    $data = CGI::Util::unescape($data);
    $self->decode($data);
    return $data;
}

my $use_utf8;
sub use_utf8 {
    my ($self) = @_;
    $use_utf8 = $_[1] if @_ > 1;
    return $use_utf8 if defined($use_utf8);
    return($use_utf8 = 0) if $] < 5.008;
    return 1 unless $self->config;
    return($use_utf8 = (lc($self->config->encoding) =~ /^utf-?8$/));
}

sub loc {
    my ($self) = shift;
    my $i18n_class = $self->config->{i18n_class} or die;
    eval "use $i18n_class; 1" or return $_[0];
    $i18n_class->initialize($self->use_utf8 || 0);
    return $i18n_class->loc(@_);
}

1;

__END__