discourse-legacysite-perl/site/glist/lib/GT/CGI/Action/Common.pm

# ==================================================================
# Gossamer Threads Module Library - http://gossamer-threads.com/
#
#   GT::CGI::Action::Common
#   Author: Scott Beck
#   CVS Info :                          
#   $Id: Common.pm,v 1.14 2004/09/07 23:35:14 jagerman Exp $
#
# Copyright (c) 2004 Gossamer Threads Inc.  All Rights Reserved.
# ==================================================================
#
# Description: 
#       Provides a base class for GT::CGI::Action objects
#

package GT::CGI::Action::Common;
# ==================================================================

use vars qw/@EXPORT @ISA/;
use strict;
use constants

    # Index in config action values
    ACT_FUNCTION     => 0,
    ACT_ERROR_PAGE   => 1,
    ACT_SUCCESS_PAGE => 2,

    # Index in config page values
    PAGE_CAN         => 0,
    PAGE_FUNCTION    => 1,

    # Action returns
    ACT_ERROR => 0,
    ACT_OK    => 1,
    ACT_EXIT  => 3;

use Carp;
use Exporter();

@ISA = qw/Exporter/;
@EXPORT = qw(
    ACT_FUNCTION
    ACT_ERROR_PAGE
    ACT_SUCCESS_PAGE
    PAGE_CAN
    PAGE_FUNCTION
    ACT_EXIT
    ACT_OK
    ACT_ERROR
);

sub new {
# ----------------------------------------------------------------------------
    my $class = shift;
    croak "Areguments to new() must be a hash" if @_ & 1;
    my %opts = @_;

    my $guess_mime = exists($opts{guess_mime}) ? delete($opts{guess_mime}) : 1;

    my $cgi = delete $opts{cgi};
    unless (defined $cgi) {
        require GT::CGI;
        $cgi = new GT::CGI;
    }

    my $tpl = delete $opts{template};
    unless (defined $tpl) {
        require GT::Template;
        $tpl = new GT::Template;
    }

    my $debug = delete $opts{debug};

    my $tags = delete $opts{tags};
    $tags = {} unless defined $tags;

    my $config = delete $opts{config};
    croak "No config specified"
        unless defined $config;

    my $action = delete $opts{action};
    my $heap = delete $opts{heap};

    croak "Unknown arguments: ", sort keys %opts if keys %opts;

    my $self = bless {
        cgi        => $cgi,
        template   => $tpl,
        tags       => $tags,
        guess_mime => $guess_mime,
        action     => $action,
        debug      => $debug,
        heap       => $heap
    }, $class;
    $self->config($config);
    return $self;
}

sub config {
# ----------------------------------------------------------------------------
    my $self = shift;
    if (@_) {
        $self->{config} = shift;
        unless (ref $self->{config}) {
            require GT::Config;
            $self->{config} = GT::Config->load($self->{config}, {
                inheritance  => 1,
                cache        => 1,
                create_ok    => 0,
                strict       => 0,
                debug        => $self->{debug},
                compile_subs => 0,
            });
        }
        croak "Unknown arguments: @_" if @_;
    }
    return $self->{config};
}

sub tags {
# ----------------------------------------------------------------------------
    my $self = shift;
    my %tags;
    if (ref($_[0]) eq 'HASH') {
        %tags = %{shift()};
    }
    else {
        croak "Arguments to tags() must be a hash or hash ref" if @_ & 1;
        %tags = @_;
    }
    @{$self->{tags}}{keys %tags} = (values %tags)
        if keys %tags;
    return $self->{tags};
}

sub cgi {
# ----------------------------------------------------------------------------
    my $self = shift;
    if (@_) {
        $self->{cgi} = shift;
        croak "Unknown arguments: @_" if @_;
    }
    return $self->{cgi};
}

sub heap {
# ----------------------------------------------------------------------------
    my $self = shift;
    if (@_) {
        $self->{heap} = shift;
        croak "Unknown arguments: @_" if @_;
    }
    return $self->{heap};
}

sub action {
# ----------------------------------------------------------------------------
    my $self = shift;
    if (@_) {
        $self->{action} = shift;
        croak "Unknown arguments: @_" if @_;
    }
    return $self->{action};
}

sub guess_mime {
# ----------------------------------------------------------------------------
    my $self = shift;
    if (@_) {
        $self->{guess_mime} = shift;
        croak "Unknown arguments: @_" if @_;
    }
    return $self->{guess_mime};
}

sub debug {
# ----------------------------------------------------------------------------
    my $self = shift;
    if (@_) {
        $self->{debug} = shift;
        croak "Unknown arguments: @_" if @_;
    }
    return $self->{debug};
}

sub template {
# ----------------------------------------------------------------------------
    my $self = shift;
    if (@_) {
        $self->{template} = shift;
        croak "Unknown arguments: @_" if @_;
    }
    return $self->{template};
}

# Shortcut to $self->tags(message => "message");
sub info {
# ----------------------------------------------------------------------------
    my $self = shift;
    my $message = shift;
    croak "Unknown arguments: @_" if @_;
    $self->tags(message => $message);
}

# Shortcut to $self->tags(message => "message"); $self->print_page("page");
sub print_info {
# ----------------------------------------------------------------------------
    my $self = shift;
    my $page = shift;
    croak "No page specified" unless defined $page;
    $self->info(@_);
    $self->print_page($page);
}

# Shortcut to $self->tags(error => "message");
sub error {
# ----------------------------------------------------------------------------
    my $self = shift;
    my $error = shift;
    croak "Unknown arguments: @_" if @_;
    $self->tags(error => $error);
}

# Shortcut to $self->tags(error => "message"); $self->print_page("page");
sub print_error {
# ----------------------------------------------------------------------------
    my $self = shift;
    my $page = shift;
    croak "No page specified" unless defined $page;
    $self->info(@_);
    $self->print_page($page);
}

# Shortcut to print $self->cgi->cookie(..)->cookie_header, "\r\n";
sub print_cookie {
# ----------------------------------------------------------------------------
    my $self = shift;
    print $self->cgi->cookie(@_)->cookie_header, "\r\n";
}

sub print_page {
# ----------------------------------------------------------------------------
    my $self = shift;
    my $page = shift;
    croak "No page specified to print" unless defined $page;
    $self->tags(page => $page);

    if (defined $self->{config}{pages}{$page}[PAGE_FUNCTION]) {
        my ($class, $func) = ($self->{config}{pages}{$page}[PAGE_FUNCTION] =~ /(.+)::([^:]+)/);
        eval "use $class();";
        die "$@\n" if $@;
        my $this = $class->new(%$self);
        $this->$func(@_);
    }

    if ($self->guess_mime) {
        require GT::MIMETypes;
        my $type = GT::MIMETypes->guess_type($page);
        print $self->cgi->header($type);
        if ($type =~ /text/) {
            return $self->template->parse_print($page, $self->tags);
        }
        else {
            local *FH;
            open FH, "<$page"
                or die "Could not open $page; Reason: $!";
            my $buff;
            binmode STDOUT;
            while (read(FH, $buff, 4096)) {
                print STDOUT $buff;
            }
            close FH;
            return 1;
        }
    }
    else {
        print $self->cgi->header;
    }
    $self->template->parse_print($page, $self->tags);
}

1;

__END__