view release on metacpan or  search on metacpan

GuruMeditation.pm  view on Meta::CPAN

##  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.
##
##  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. See the GNU
##  General Public License for more details.
##
##  You should have received a copy of the GNU General Public License
##  along with this program; if not, write to the Free Software
##  Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
##  USA, or contact Ralf S. Engelschall <rse@engelschall.com>.
##
##  GuruMeditation.pm: Module Implementation
##

package CGI::GuruMeditation;

require 5.006;
use strict;
use IO::File;

our $VERSION = '1.10';

our $option  = { -name => "", -debug => 0 };

sub configure {
    my (@args) = @_;

    if (@args >= 2 and (@args % 2) == 0) {
        $CGI::GuruMeditation::option = { %{$CGI::GuruMeditation::option}, @args };
    }
    elsif (@args == 1) {
        $CGI::GuruMeditation::option->{-name} = $args[0];
    }
}

sub import {
    my ($self, @args) = @_;

    #   parse parameters
    configure(@args);

    #   no operation outside CGI environments
    #   (usually either CGI/1.1 or CGI-Perl/1.1)
    return unless ($ENV{'GATEWAY_INTERFACE'} =~ m|^CGI|);

    #   setup termination handler
    $SIG{__DIE__} = sub {
        my ($msg) = @_;

        #   determine stack backtrace
        my $bt = [];
        if ($option->{-debug}) {
            for (my $i = 0; $i < 100; $i++) {
                my $caller = {}; @${caller}{qw(
                    -package -filename -line -subroutine -hasargs
                    -wantarray -evaltext -is_require -hints -bitmask
                )} = caller($i) or last;
                push(@{$bt}, $caller);
            }
        }

        #   fetch options from external variable
        my $option = $CGI::GuruMeditation::option;

        #   determine whether we are running under Apache/mod_perl
        my $mod_perl = 0;
        if (exists($ENV{'MOD_PERL'})) {
            $mod_perl = ($ENV{'MOD_PERL_API_VERSION'} ? $ENV{'MOD_PERL_API_VERSION'} : 1);
        }

        #   pass-through if exception is caught (via "eval" except for Apache/mod_perl)
        die @_ if ($^S and not $mod_perl);

        #   make sure we are not called multiple times
        $SIG{__DIE__} = 'IGNORE';

        #   helper function: properly escape characters for HTML inclusion
        sub escape_html {
            my ($txt) = @_;
            $txt =~ s/&/&amp;/sg;
            $txt =~ s/</&lt;/sg;
            $txt =~ s/>/&gt;/sg;
            $txt =~ s/\"/&quot;/sg;
            $txt =~ s/^[ \t]+//s;
            $txt =~ s/[ \t]+$//s;
            $txt =~ s/\r//sg;
            $txt =~ s/\n\n+/\n/sg;
            return $txt;
        }

        #   helper function: render mail address as simply scrambled HTML hyperlink
        sub html_url {
            my ($url, $link) = @_;
            my $html = $url;
            $html = escape_html($html);
            $html =~ s/@/<!-- XXX -->&#64;<!-- XXX -->/sg;
            $html =~ s/\./<!-- XXX -->&#46;<!-- XXX -->/sg;
            if ($link) {
                my $href = $url;
                $href =~ s/@/&#64;/sg;
                $href =~ s/\./&#46;/sg;
                $html = "<a href=\"mailto:$href\">$html</a>";
            }
            return $html;
        }

        #   helper function: calculate minimum number
        sub min {
            my ($a, $b) = @_;
            return ($a <= $b ? $a : $b);
        }

        #   determine title
        my $name = $ENV{'SCRIPT_FILENAME'} || "unknown";
        $name =~ s/^.*\/([^\/]+)$/$1/s;
        $name =~ s/\.[a-z0-9]{2,4}$//s;
        my @prog = split(//, $name);