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;

# beerbt: PerlForms::Dict::Object, NagUtil::REQ, NagUtil ???????

## todo e PerlForms in PerlForms::Base oder ::Simple oder so ändern
## todo c PerlForms->ui in REQ->ui umziehen
## todo c PerlForms->form in REQ->form umziehen
## todo c PerlForms->query in REQ->query umziehen

use strict;
use Carp qw(:DEFAULT cluck);
use vars qw($debug);
$debug=5 unless(defined($debug));

sub new {
    # expects:
    # descr: Most simple, generic constructor.
    my($self)={};
    my($class)=shift;
    bless($self,$class);
    my(%arg)=@_;
    $debug>=3 && print(STDERR __PACKAGE__."->new got called by ".caller()." with ".join(",",%arg).".\n");
    
    $self->{req}=$arg{req} if defined $arg{req};
    $self->{ui}=$arg{ui} if defined $arg{ui};
    $self->{class}=$class;
    
    if($self->can("init")) {
        $self->init(%arg);
    }
    
    $self;
}

sub date {
    shift if(ref($_[0]) and $_[0]->can("VERSION"));
    my(@lt);
    if(@_ and $_[0] and $_[0]=~/\d/) {
        @lt=localtime($_[0]);
    } else {
        @lt=localtime;
    }
    return sprintf(
        '%02d.%02d.%04d %02d:%02d:%02d',
        ($lt[3]),
        ($lt[4]+1),
        ($lt[5]+1900),
        ($lt[2]),
        ($lt[1]),
        ($lt[0])
    )
}

sub faultt {
    # expects: prg|req? ui? msg
    #
    # howto use:
    # Am besten ein ui oder - wenn nicht zur Hand - ein req übergeben.
    # Gibt es gerade beides nicht, dann nur msg übergeben, und fault baut sich
    # den Rest selber.
    #
    #
    $debug && print(STDERR __PACKAGE__."->faultt got called by ".caller()."\n");

    my($self)=shift;   
    my(%arg)=@_;

    if(defined($arg{msg})) {
        chomp($arg{msg});
        print(STDERR __PACKAGE__."->faultt: msg='".$arg{msg}."'\n") if($debug>=4);
    }
    
    unless(defined($self->{req})) {
        if(defined($arg{req})) {
            $self->{req}=$arg{req};
        } elsif(ref($self)=~/::REQ/) {
            $self->{req}=$self;
        } else {
            warn(__PACKAGE__."->faultt: Dont have a REQ.\n")
        }
    }

    $self->ui->bad(
        defined($arg{msg})?$arg{msg}:"Error, sais ".caller()
    ) or die(__PACKAGE__."->faultt: \$self->ui->bad failed. ".$!);

    if($debug>=3) {
        print(STDERR __PACKAGE__."->faultt will cluck now:\n");    
        cluck(__PACKAGE__."->faultt got called...");
    }
    
    exit 1;
}
#
#sub int2ip {
#    my($self)=shift if ref($_[0]) and $_[0]->can("VERSION");
#    ## $self->int2ip-aufruf geht in die hose!!
#    my($ip)=shift;
#    # The mysql-data-type int is 31bit long, plus a +/- sign.
#    # An IP address is 32bit long.
#    # Since i don't want to use the 64bit int of mysql,
#    # I use the +/- sign bit, by substracting 2^32 from the ip,
#    # thus storing all IP addresses below 128.0.0.0 as a 
#    # negative value.
#    # When decoding back to an IP address, I have to add those 2^32 back.
#    $ip+=2147483648;
#    $ip=unpack("B32", pack("N", $ip));
#    $ip =~ /^(\d{8})(\d{8})(\d{8})(\d{8})$/;
#    $ip =~ /^(\d{8})(\d{8})(\d{8})(\d{8})$/ or return;
#    my($nip) = unpack("N", pack("B32",substr("0" x 32 . $1, -32))).
#       ".".unpack("N", pack("B32",substr("0" x 32 . $2, -32))).
#       ".".unpack("N", pack("B32",substr("0" x 32 . $3, -32))).
#       ".".unpack("N", pack("B32",substr("0" x 32 . $4, -32)));
#    return $nip;
#}
#
#sub ip2int {
#    my($self)=shift;
#    my($ip)=shift;
#    return if(!$ip);
#    my($x,$y,$z,$nip);
#    foreach $x ( ( $ip =~ /^(\d{1,3})\.(\d{1,3})\.(\d{1,3})\.(\d{1,3})$/ ) ) {
#        $y = unpack("B32", pack("N",$x));
#        $y =~ s/^0+(?=\d)//g;
#        $z .= sprintf("%08d",$y);
#    }
#    $nip=unpack("N",pack("B32",$z));
#    # The mysql-data-type int is 31bit long, plus a +/- sign.
#    # An IP address is 32bit long.
#    # Since i don't want to use the 64bit int of mysql,
#    # I use the +/- sign bit, by substracting 2^31 from the ip,
#    # thus storing all IP addresses below 128.0.0.0 as a 
#    # negative value.
#    $nip-=2147483648;
#    return $nip;
#}

sub pfmodule {
    my($self)=shift;
    
    my($what,$obj);
    if(defined $_[0]) {
        $what=shift;
    } elsif(!defined $self->{obj}) {
        if(defined($self->{what})) {
            $what=$self->{what};
        } else {
            warn(__PACKAGE__."->pfmodule needs an obj or a what!\n");
            return undef;
        }
    } else {
        $obj=$self->{obj}
    }
    if(defined $what) { ## what ist nur defined, wenn es kein obj gab, oder what als param. übergeben wurde und alles andere somit übeschreibt.
        my$req;
        if(ref($self)=~/::REQ$/) {
            $req=$self;
        } elsif(defined $self->{req}) {
            $req=$self->{req}
        } else {
            warn(__PACKAGE__."->pfmodule needs a req!\n");
            return undef;
        }

#        require PerlForms::Dict::Object;
#        $obj=PerlForms::Dict::Object->new(req=>$req,what=>$what);
        $obj=$self->newobj(what=>$what);
    }

    if(defined($obj->dict->{pfmodule})) {
        return $obj->dict->{pfmodule};
    } elsif(defined($self->{prg}) and $self->{prg} eq "ldap") {
        return "IPLS::Ldap";
    } else {
        return "NagUtil";
    }
}

sub ui {
    # expects: req? ui?
    # returns: UI object.
    # descr: returns the current UI. If there is not UI yet, it makes one. Can
    #        also be used to manually set a UI. simply specify the ui parameter.
    my($self)=shift;
    my(%arg)=@_;
    $debug && print(STDERR 
        __PACKAGE__."->ui got called by ".caller()." with ".join(",",%arg)." (Please ignore the uninitialized value message above!).\n"
    );
    
    if(defined($arg{ui}) and ref($arg{ui})) {
        $debug && print(STDERR __PACKAGE__."->ui set ui to ".$arg{ui}."\n");
        $self->{ui}=$arg{ui};
    } elsif(!defined($self->{ui}) or !ref($self->{ui})) {
        unless(defined($self->{req})) {
            if(defined($arg{req})) {
                $self->{req}=$arg{req};
            } elsif(ref($self)=~/::HTML::REQ[\W:]*$/) {
                $self->{req}=$self;
            } else {
                require PerlForms::TEXT::REQ
                or warn(__PACKAGE__."->ui require PerlForms::TEXT::REQ failed. ".$!);
                $self->{req}=new PerlForms::TEXT::REQ(%arg)
                or warn(__PACKAGE__."->ui new PerlForms::TEXT::REQ failed. ".$!);
            }
            if(!defined($self->{req})) {
                warn(__PACKAGE__."->ui: new TEXT::REQ failed. ".$!."\n");
                return undef;
            }
        }
        
        if(defined($self->{req}->{ui})) {
            $self->{ui}=$self->{req}->{ui}
        } elsif($self->{req}->type eq "HTML") {
            require PerlForms::HTML::Tabs
            or warn(__PACKAGE__."->ui require PerlForms::HTML::UI failed. ".$!);
            $self->{ui}=PerlForms::HTML::Tabs->new(%arg,req=>$self->{req},obj=>$self->{obj})
            or warn(__PACKAGE__."->ui new PerlForms::HTML::UI failed (caller: ".caller()."). ".$!);
        } else {
            require PerlForms::TEXT::UI
            or warn(__PACKAGE__."->ui require PerlForms::TEXT::UI failed. ".$!);
            $self->{ui}=PerlForms::TEXT::UI->new(%arg,req=>$self->{req},obj=>$self->{obj})
            or warn(__PACKAGE__."->ui new PerlForms::TEXT::UI failed. ".$!);
        }
    }
    
    if(defined($self->{req}) and !defined($self->{req}->{ui})) {
        $self->{req}->{ui}=$self->{ui}
    }

    $debug && print(STDERR __PACKAGE__."->ui returning ".$self->{ui}."\n");
    return defined $self->{ui}?$self->{ui}:{};
}

## todo PerlForms->form nach REQ->form umziehen
sub form {
    my$self=shift;
    my%arg=@_;
    
    unless(defined($self->{form})) {
        unless(defined($arg{obj}) or defined($arg{what})) {
            $arg{obj}=$self->obj(%arg);
        }
        require PerlForms::HTML::Form;
        $self->{form}=Form->new(
            %arg,
            req=>$self->{req}
        );
        $self->{ui}=$self->{form}->{ui};
    }
    
    $self->{form}
}

sub newlist {
    # expects: req? ui?
    # returns: UI object.
    # descr: returns the current UI. If there is not UI yet, it makes one. Can
    #        also be used to manually set a UI. simply specify the ui parameter.
    my($self)=shift;
    my(%arg)=@_;
    $debug && print(STDERR 
        __PACKAGE__."->newlist got called by ".caller()." with ".join(",",%arg)." (Please ignore the uninitialized value message above!).\n"
    );
    
    $arg{req}=$self->{req};
    $arg{obj}=$self->{obj} if(!defined($arg{obj}) and defined($self->{obj}));
    $arg{ui}=$self->{ui} if(!defined($arg{ui}) and defined($self->{ui}));
    
    if($self->{req}->type eq "HTML") {
        require PerlForms::HTML::List
        or warn(__PACKAGE__."->newlist require PerlForms::HTML::List failed. ".$!);
        $self->{ui}=HTML::List->new(%arg)
        or warn(__PACKAGE__."->newlist new HTML::List failed (caller: ".caller()."). ".$!);
    } else {
        require PerlForms::TEXT::List
        or warn(__PACKAGE__."->newlist require PerlForms::TEXT::List failed. ".$!);
        $self->{ui}=TEXT::List->new(%arg)
        or warn(__PACKAGE__."->newlist new TEXT::List failed (caller: ".caller()."). ".$!);
    }

    $debug && print(STDERR __PACKAGE__."->newlist returning ".$self->{ui}."\n");
    return defined $self->{ui}?$self->{ui}:{};
}

sub newobj {
    # expects: what|abkuerz
    my$self=shift;
    my%arg=@_;
    $debug && print STDERR __PACKAGE__."->newobj got called by ".caller()."\n";
    
    unless(defined $self->{req}) {
        if(ref($self)=~/::REQ$/) {
            $self->{req}=$self;
        } else {
            warn(__PACKAGE__."->newobj needs a req! caller: ".caller().". returning undef.\n");
            return undef;
        }
    }
    
    my$obj;
    if(defined $arg{what} or defined $arg{abkuerz} or defined $arg{idattrib}) {
#        require PerlForms::Dict::Object;
#        $obj=PerlForms::Dict::Object->new(%arg,req=>$self->{req});
        $obj=$self->{req}->dict->obj(%arg,req=>$self->{req});
    } elsif(defined $self->{obj}) {
        $obj=$self->{obj}
    } else {
        warn(__PACKAGE__."->newobj needs a what or an abkuerz. returning undef.\n");
        return undef;
    }
    $debug && print STDERR __PACKAGE__."->newobj: obj returns: ".$obj->what."\n";
    $obj;
}

sub obj {
    my$self=shift;
    my%arg=@_;
    
    unless(defined($self->{obj})) {
        if(defined($arg{obj})) {
            $self->{obj}=$arg{obj};
        } elsif(defined($self->{what})) {
            $self->{obj}=$self->newobj(what=>$self->{what});
        } elsif(defined($arg{what})) {
            $self->{obj}=$self->newobj(what=>$arg{what});
        } else {
            return undef
        }
    }
    
    $self->{obj}
}

sub objs { ## takes a what
    ## gibt ein PerlForms::Dict::Object für das angeg. what zurück. Sollte es so
    ## eines für das angeg. what schon geben, dann wird kein neues generiert 
    ## sondern das bestehende zurückgegeben.
    ## Achtung: Die objs werden in einer Objekt-Variable gespeichert; wenn also
    ## eines in req->obj schon existiert, wird obj->objs trotzdem ein neues ge-
    ## nerieren.
    my$self=shift;
    
    unless(defined($self->{objs}->{$_[0]})) {
        $self->{objs}->{$_[0]}=$self->newobj(what=>$_[0]);
    }
    warn(__PACKAGE__."->objs: obj couldnt be generated.\n")
    unless(defined($self->{objs}->{$_[0]}));
    
    $self->{objs}->{$_[0]}
}

## todo w newthing: Class->newthing macht Sinn/wäre praktisch
## todo d pfmodule: jedes obj soll wissen, zu welchem Pf-Modul es gehört. Anstatt 
##      pm direkt anzugeben könnte es sich besser aus Pf-Module und what zusam-
##      mensetzen.
sub newthing {
    # expects: obj|what
    my$self=shift;
    my%arg=@_;
    $debug && print STDERR __PACKAGE__."->newthing got called by ".caller()."\n";
    
    unless(defined($self->{req})) {
        if(ref($self)=~/::REQ$/) {
            $self->{req}=$self;
        } else {
            warn(__PACKAGE__."->newthing needs a req! returning undef.\n");
            return undef;
        }
    }
    
    ## obj
#    $arg{obj}=$self->newobj(%arg) unless(defined($arg{obj}));
#    $debug && print STDERR __PACKAGE__."->newthing: obj is defined: ".$arg{obj}->what."\n";
    my$obj;
    if(defined($arg{obj})) {
        $obj=$arg{obj}
    } elsif(defined($arg{what})) {
#        $obj=$self->newobj(%arg)
        $obj=$self->objs($arg{what})
    } else {
        $obj=$self->obj(%arg)
    }
    
    unless(eval 'require '.$obj->pm) {
        $debug && print STDERR __PACKAGE__."->newthing: require ".$obj->pm." failed. ".$!."\n";
        my$pm=$obj->pm;
        $pm=~s/::/\//g;
        my$pmfile='"'.$self->{req}->{"fudhome"}.'/lib/'.$pm.'.pm"';
        if(-e $pmfile) {
            my($cmd)='perl -c ".$pmfile." 2>&1';
            my($checkout)=`$cmd`;
            $self->faultt(
                msg=>"
                    ".__PACKAGE__." eval require ".$obj->pm." failed: ".$@."
                    Output of the Perl syntax check: ".$checkout."
                "
            );
#        } elsif(defined $obj->pm) {
        } elsif(defined($self->{req}->dict->is_what($obj->what))) {
            print STDERR __PACKAGE__."->newthing: generating new ".$obj->what." thing.\n";
            require PerlForms::Object;
            return PerlForms::Object->new(
                req=>$self->{req},
                ui=>$arg{ui},
                obj=>$obj
            )
        } else {
            print STDERR __PACKAGE__."->newthing: pm file ".$pmfile." doesnt exist and ".$obj->what." is not a defined Pf-Object-Class. returning undef.\n";
#            $self->faultt(
#                msg=>"
#                    ".__PACKAGE__."newthing eval require ".$obj->pm." failed: ".$@."
#                    Perl Module file does not exist.
#                "
#            );
            return undef
        }
    } else {
        print STDERR __PACKAGE__."->newthing: require ".$obj->pm." successful.\n";
        return eval $obj->pm.'->new(
            req=>$self->{req},
            ui=>$arg{ui},
            obj=>$obj
        )' or $self->{req}->faultt(msg=>__PACKAGE__."->newthing eval new failed. ".$@);
    }
}

## todo e newthing wo sinnvoll durch thing/s ersetzen
sub thing {
    ## wird nichts oder mehr als ein wert übergeben (hash vermutet), wird
    ## $self->{thing} zurückgegeben, vorher ggf. generiert.
    my$self=shift;
    my%arg=@_;
    
    unless(defined($self->{thing})) {
        $self->{thing}=$self->newthing(obj=>$self->obj);
    }
    
    $self->{thing}
}

sub things { ## takes a what
    ## gibt ein PerlForms::Object für das angeg. what zurück. Sollte es so eines
    ## für das angeg. what schon geben, dann wird kein neues generiert sondern
    ## das bestehende zurückgegeben.
    ## Achtung: Die things werden in einer Objekt-Variable gespeichert; wenn also
    ## ein req->thing schon existiert, wird thing->thing trotzdem ein neues gene-
    ## rieren.
    my$self=shift;
    
    unless(defined($self->{things}->{$_[0]})) {
        $self->{things}->{$_[0]}=$self->newthing(what=>$_[0]);
    }
    warn(__PACKAGE__."->things: thing couldnt be generated.\n")
    unless(defined($self->{things}->{$_[0]}));
    
    $self->{things}->{$_[0]}
}

sub query {
    # expects: <qname> {attribs}
    my$self=shift;
#    print STDERR __PACKAGE__."->query got called by ".caller()." with ".join(",",@_)."\n";
    my$qname=shift;
    my%attribs=@_;
    
    unless(defined($self->{"query"})) {
        require PerlForms::Query;
        $self->{"query"}=PerlForms::Query->new(
            req=>$self->{req},
            ui=>$self->{ui}
        );
    }
    
    if(defined($qname) and $self->{"query"}->can($qname)) {
#        print STDERR __PACKAGE__."->query running a query-method.\n";
        eval('$self->->'.$qname.'(%attribs)')
    } else {
#        print STDERR __PACKAGE__."->query returning a query object.\n";
        $self->{"query"}
    }
}



package Main;

1;