PerlForms Code

#
# Copyright 2008 Samuel Borsutzky
#
# This file is part of PerlForms.
#
# PerlForms 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 3 of the License, or
# (at your option) any later version.
#
# PerlForms 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 PerlForms.  If not, see <http://www.gnu.org/licenses/>.
#
#
#

package PerlForms::REQ;

use strict;
use db;
use Net::LDAP;
use Net::LDAP::Entry;
use PerlForms::Env;
use PerlForms::Dict;
use base qw(PerlForms);
use vars qw($debug); 
our($fudhome,%storage);
$debug=0 unless(defined($debug));

### Verzeichnis-Variablen immer mit einem Slash enden lassen, so dass deren
### Anwendung unabhaengig von Slash vs. Backslash (Unix vs. Windows) bleibt.
### Diese Verzeichnisse sind PerlForms-App-uebergreifend, dh. fuer alle PerlForms-
### Apps (NagUtil, Funcdep, Ipls) gleich.

## todo e backends sollen anhand vom Obj. bei Bedarf geladen, dann aber für alle zugänglich gespeichert und offengehalten werden.
sub backends {
    my($self)=shift;
    $debug && print(STDERR __PACKAGE__."->backends got called by ".caller()."\n");

    unless(defined($self->{"storage"})) {
        warn(__PACKAGE__."->backends: No backends loaded. Returning.\n");
        return undef;
    }
    $debug && print(STDERR __PACKAGE__."->backends: known backends: ".join(",",keys(%{$self->{"storage"}}))."\n");
    
    foreach my$backendname ($self->app->backends) {
        unless(defined($self->{"storage"}->{$backendname})) {
            warn(__PACKAGE__."->backends: No backend definition for backend '".$backendname."'\n");
        }
        
        my$backend=$self->{"storage"}->{$backendname};
        
        ## Backends in req->(backends)->(backendname) oder so speichern
        if($backend->{"access"} eq "db") {
            unless(
                $self->{db}=db->new(
                    dbname=>$backend->{"dbname"},
                    user=>$backend->{"user"},
                    passwd=>$backend->{"passwd"},
                )
            ) {
                print STDERR "Error: ".__PACKAGE__."->backends: Database '".$backend->{"dbname"}."' currently down. Giving up.\n";
                print "Content-Type: text/plain\n\n";
                print "Error: ".__PACKAGE__."->backends: Database '".$backend->{"dbname"}."' currently down. Giving up.\n";
                return undef;
            }
        } elsif($backend->{"access"} eq "ldap") {
            unless(
                $self->{ldap}=Net::LDAP->new($backend->{"ipaddress"}, version => 3, port => 389)
            ) {
                warn(__PACKAGE__."->backends: Couldnt make a LDAP object or connect to LDAP server. ".$@);
                print(__PACKAGE__."->backends: Couldnt make a LDAP object or connect to LDAP server. ".$@);
                return undef;
            }
            
            my($mesg)=$self->{ldap}->bind(
                $backend->{"binddn"},
                password=>$backend->{"password"}
            ) or $self->faultt(msg=>"Couldnt bind to directory.");
        } else {
            warn(__PACKAGE__."->backends: Dont know how to access backend '".$backendname."'\n");
        }
    }
    
    $debug && print(STDERR __PACKAGE__."->backends returns to ".caller()."\n");
    1
}

## datenbank sauber disconnecten
sub DESTROY {
    my($self)=shift;
    $self->{db}->close if(defined($self->{db}));
    $self->{ldap}->unbind if(defined($self->{ldap}));
}

sub refresh {
    ## dummy, falls TEXT::REQ->refresh aufgerufen werden sollte...
    1
}

sub debug_init {
    my($self)=shift;
    
    my($sql)="
        select
            id,
            package,
            level
        from
            debug
    ";
    
    my($data)=$self->storages("perlformsdb")->{db}->hashref($sql)
        or warn(__PACKAGE__."->debug_init couldn't get debug levels from db.\n");
        
    $debug && warn(__PACKAGE__."->debug_init LOADING DEBUGGING SETTINGS.\n");
    
    while(my($key,$rec)=each(%$data)) {
        if(defined $rec->{"package"} and defined $rec->{"level"}) {
#            print(STDERR __PACKAGE__."->debug_init setting debug level for ".$rec->{"package"}." to ".$rec->{"level"}."\n");
            eval '$'.$rec->{"package"}.'::debug='.$rec->{"level"};
        }
    }
}

sub check_attrib {
    my($self)=shift;
    $debug>=3 && print(STDERR __PACKAGE__."->check_attrib got called by ".caller()."\n");
    my(%attrib)=$self->param;
    $debug>=2 && print(STDERR __PACKAGE__."->check_attrib got attribs=(".join(",",%attrib).")\n");
    my(@msgs);
    return 0 unless defined $self->{obj} and ref($self->{obj});
    my$dict=$self->{obj}->dict;
    my$dict_attribs=$dict->{attrib};
    $debug>=4 && print(STDERR __PACKAGE__."->check_attrib checking attribs...\n");
    while(my($attrib,$val)=each(%attrib)) {
        ## ist dieses attribut im dict definiert?
        $debug && print(STDERR __PACKAGE__."->check_attrib checking attrib ".$attrib."'s val '".$val."'\n");
        if(
            defined($dict_attribs->{$attrib})
            and defined($dict_attribs->{$attrib}->{type})
        ) {
            $debug && print(STDERR __PACKAGE__."->check_attrib found a dict entry for ".$attrib."\n");
            ## algorithmen zur gueltigkeitspruefung von daten-typen
            if($dict_attribs->{$attrib}->{type} eq "ipaddress") {
                $debug && print(STDERR __PACKAGE__."->check_attrib ".$attrib." is an ipaddress\n");
                chomp($val);
                unless($val=~/^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
                    $debug && print(STDERR __PACKAGE__."->check_attrib ".$attrib." is invalid\n");
                    push(@msgs,$attrib." is not a valid ".$dict_attribs->{$attrib}->{type});
                }
            } elsif($dict_attribs->{$attrib}->{type} eq "time") {
                unless($val=~/(\d{1,2})\.(\d{1,2})\.(\d{1,4}) (\d{1,2}):(\d{1,2}):(\d{1,2})/) {
                    push(@msgs,$attrib." is not a valid ".$dict_attribs->{$attrib}->{type});
                }
            }
        }
    }
    
    $debug && print(STDERR __PACKAGE__."->check_attrib printing ".@msgs." msg(s)...\n");
    if(@msgs) {
        foreach my $msg (@msgs) {
            $self->ui->bad($msg);
        }
        exit;
    }
}
#
#sub uihelper {
#    my($self)=shift;
#    my(%arg)=@_;
#    $debug && print STDERR __PACKAGE__."->uihelper got called by ".caller()." with (".join(",",%arg).")\n";
#    my($ui);
#    if($self->type eq "HTML") {
#        require PerlForms::HTML::Tabs
#            or warn(__PACKAGE__."->uihelper require PerlForms::HTML::Tabs failed. ".$!);
#        $ui=new PerlForms::HTML::Tabs(%arg,req=>$self)
#            or warn(__PACKAGE__."->uihelper new PerlForms::HTML::Tabs failed. ".$!);
#    } else {
#        require PerlForms::TEXT::UI
#            or warn(__PACKAGE__."->uihelper require PerlForms::TEXT::UI failed. ".$!);
#        $ui=new PerlForms::TEXT::UI(%arg,req=>$self)
#            or warn(__PACKAGE__."->uihelper new PerlForms::TEXT::UI failed. ".$!);
#    }
#    $ui
#}

sub settings {
    my($self)=shift;
    
#    $self->{"fudhome"}=$PerlForms::Env::fudhome;
#    $self->{"fudtmp"}=$PerlForms::Env::fudtmp;
#    $self->{"storage"}=\%PerlForms::Env::storage;
    $self->{"fudhome"}=$self->env("fudhome");
    $self->{"fudtmp"}=$self->env("fudtmp");
    $self->{"storage"}={$self->env("storage")}; ## so wird das hash aus env zur hashref
    
    ### pfade
    ## Verzeichnis-Variablen immer mit einem Slash enden lassen, so dass deren
    ## Anwendung unabhaengig von Slash vs. Backslash (Unix vs. Windows) bleibt.
    ## Diese Verzeichnisse sind PerlForms-App-uebergreifend, dh. fuer alle PerlForms-
    ## Apps (NagUtil, Funcdep, Ipls) gleich.
#    $PerlForms::basedir=$self->{"fudhome"}."/";
#    $PerlForms::tmpdir=$PerlForms::basedir."var/";
    ## todo Verw. von $PerlForms::basedir und ::tmpdir durch $req->env("fudhome") ersetzen
    $PerlForms::basedir=$self->env("home")."/";
    $PerlForms::tmpdir=$self->env("home")."/var/";
    unless(-e $PerlForms::tmpdir) {
        die("Missing temporary directory ".$PerlForms::tmpdir)
    }
}

## dict ist essenziell für alles perlforms, daher gleich am Anfang...
sub dict {
    my$self=shift;
    
    unless(defined($self->{dict})) {
        require PerlForms::Dict or die(__PACKAGE__."->dict: require PerlForms::Dict failed. ".$!);
        $self->{dict}=PerlForms::Dict->new();
        die(__PACKAGE__."->dict: ".$!) unless defined $self->{dict};
        $self->{dict}->load_dict("PerlForms");
    }
    
    $self->{dict}
}

sub env {
    require PerlForms::Env;
    defined eval '$PerlForms::Env::'.$_[1]?eval '$PerlForms::Env::'.$_[1]
    :defined eval '%PerlForms::Env::'.$_[1]?eval '%PerlForms::Env::'.$_[1]
    :defined eval '@PerlForms::Env::'.$_[1]?eval '@PerlForms::Env::'.$_[1]
    :undef
}

sub app {
    my$self=shift;
    print STDERR __PACKAGE__."->app got called by ".caller()."\n";

    unless(defined $self->{app}) {
#        print STDERR __PACKAGE__."->app: app not defined yet.\n";
        if(defined $self->dict->apps->{$self->{prg}}->{pm}) {
            my$pm='PerlForms::App::'.$self->dict->apps->{$self->{prg}}->{pm};
            print STDERR __PACKAGE__."->app: generating an app object of ".$pm."\n";
            eval "require $pm" or warn(__PACKAGE__."->new: require $pm failed: ".$@."\n");
            $self->{app}=$pm->new(req=>$self);
            $self->{app}->load_modules;
        } else {
            warn("No pm defined for path '".$self->{prg}."'");
            return PerlForms::App->new(req=>$self);
        }
#    } else {
#        print STDERR __PACKAGE__."->app: app already defined.\n";
    }
    
    print STDERR __PACKAGE__."->app returning ".$self->{app}."\n";
    
    $self->{app}
}

sub storages {
    my$self=shift;
#    
#    print STDERR __PACKAGE__."->storages got called by ".caller()."\n";
    
    unless(defined($self->{"storages"}->{$_[0]})) {
#        print STDERR __PACKAGE__."->storages: it's not defined yet.\n";
#        print STDERR __PACKAGE__."->storages: env->storage is valid.\n" if(defined($self->env("storage")));
#        print STDERR __PACKAGE__."->storages: ".join(",",$self->env("storage"))."\n";
        my%storage=$self->env("storage");
#        print STDERR __PACKAGE__."->storages: ".$storage{$_[0]}."\n";
#        print STDERR __PACKAGE__."->storages: storage ".$_[0]." is valid.\n" if(defined(${$self->env("storage")}{$_[0]}));
        if(defined($storage{$_[0]}) and $storage{$_[0]}->{"access"} eq "db") {
#            print STDERR __PACKAGE__."->storages: it's a db.\n";
            ## todo d storage in db umbenennen, sodass der unterschied zw. einer schnittstelle und einer tats. datenbank (sei es ldap oder sql) zu erkenne ist. 
            require PerlForms::Storage::Db;
            $self->{"storages"}->{$_[0]}=PerlForms::Storage::Db->new(req=>$self,name=>$_[0])
        } elsif(defined($storage{$_[0]}) and $storage{$_[0]}->{"access"} eq "ldap") {
#            print STDERR __PACKAGE__."->storages: it's a ldap.\n";
            require PerlForms::Storage::Ldap;
            $self->{"storages"}->{$_[0]}=PerlForms::Storage::Ldap->new(req=>$self,name=>$_[0])
        } else {
            warn(__PACKAGE__."->storage: storage ".$_[0]." is not known. returning undef.\n");
            return undef
        }
    }
    
    $self->{"storages"}->{$_[0]}
}



package Main;

1;