mh « share « src - monkeysphere - Unnamed repository; edit this file 'description' to name the repository.

Mode	Name	Size
-rw-r--r--	add_hostname	1808	log plain
-rw-r--r--	add_revoker	523	log plain
-rw-r--r--	diagnostics	7270	log plain
-rw-r--r--	extend_key	838	log plain
-rw-r--r--	gen_key	2804	log plain
-rw-r--r--	import_key	2277	log plain
-rw-r--r--	publish_key	844	log plain
-rw-r--r--	revoke_hostname	2378	log plain
-rw-r--r--	revoke_key	512	log plain

returns 1 if the run mode is what is specified. Otherwise

returns 0.

=item is_allowed_role({allowed_roles => @role_names})

This function returns 1 if the user's roles include any of the roles in

@role_names. Currently it returns 1 when this is not found as well but when

role permissions are introduced, this will change to 0.

=item num_text_rows (string => $string, cols => $number, max => $number);

This function determines the likely number of rows needed to hold text in a

textbox. It returns either that number or max, which ever is lower.

=item merge ($hashref, keys => @list, index => $number);

This command merges the $hashref into the current object. If keys are

specified, only those keys are used. Otherwise all keys are merged.

If an index is specified, the merged keys are given a form of

"$key" . "_$index", otherwise the key is used on both sides.

=item redirect (msg => $string)

This function redirects to the script and argument set determined by

$self->{callback}, and if this is not set, goes to an info screen and prints

$msg.

=item redo_rows (fields => \@list, count => $integer, [index => $string);

This function is undergoing serious redesign at the moment. If index is

defined, that field is used for ordering the rows. If not, runningnumber is

used. Behavior is not defined when index points to a field containing

non-numbers.

=item set (@attrs)

Copies the given key=>vars to $self. Allows for finer control of

merging hashes into self.

=item remove_cgi_globals()

Removes all elements starting with a . because these elements conflict with the

ability to hide the entire structure for things like CSV lookups.

=back

# This work contains copyrighted information from a number of sources

# all used with permission.

# This file contains source code included with or based on SQL-Ledger

# which is Copyright Dieter Simader and DWS Systems Inc. 2000-2005

# and licensed under the GNU General Public License version 2 or, at

# your option, any later version. For a full list including contact

# information of contributors, maintainers, and copyright holders,

# see the CONTRIBUTORS file.

# Original Copyright Notice from SQL-Ledger 2.6.17 (before the fork):

# Author: DWS Systems Inc.

# Web: http://www.sql-ledger.org

# Contributors: Thomas Bayen <bayen@gmx.de>

# Antti Kaihola <akaihola@siba.fi>

# Moritz Bunkus (tex)

# Jim Rawlings <jim@your-dba.com> (DB2)

#====================================================================

=cut

use CGI::Simple;

$CGI::Simple::DISABLE_UPLOADS = 0;

use Math::BigFloat;

use LedgerSMB::Sysconfig;

use Data::Dumper;

use LedgerSMB::Auth;

use LedgerSMB::Template;

use LedgerSMB::Locale;

use LedgerSMB::User;

use strict;

$CGI::Simple::POST_MAX = -1;

package LedgerSMB;

our $VERSION = '1.2.99';

sub new {

    my $type   = shift @_;

    my $argstr = shift @_;

    my %cookie;

    my $self = {};

    $self->{version} = $VERSION;

    $self->{dbversion} = "1.2.0";

    bless $self, $type;

    my $query = ($argstr) ? new CGI::Simple($argstr) : new CGI::Simple;

    my $params = $query->Vars;

    $self->{VERSION} = $VERSION;

    $self->merge($params);

    $self->{have_latex} = $LedgerSMB::Sysconfig::latex;

# Adding this so that empty values are stored in the db as NULL's. If

# stored procedures want to handle them differently, they must opt to do so.

# -- CT

    for (keys %$self){

        if ($self->{$_} eq ''){

            $self->{$_} = undef;

}

    if ($self->is_run_mode('cgi', 'mod_perl')) {

        $ENV{HTTP_COOKIE} =~ s/;\s*/;/g;

        my @cookies = split /;/, $ENV{HTTP_COOKIE};

        foreach (@cookies) {

            my ( $name, $value ) = split /=/, $_, 2;

            $cookie{$name} = $value;

}

    $self->{action} =~ s/\W/_/g;

    $self->{action} = lc $self->{action};

    if ( $self->{path} eq "bin/lynx" ) {

        $self->{menubar} = 1;

# Applying the path is deprecated. Use menubar instead. CT.

        $self->{lynx} = 1;

        $self->{path} = "bin/lynx";

}

else {

        $self->{path} = "bin/mozilla";

}

    if ( ( $self->{script} =~ m#(\.\.|\\|/)# ) ) {

        $self->error("Access Denied");

}

    if (!$self->{script}) {

        $self->{script} = 'login.pl';

}

# if ($self->{action} eq 'migrate_user'){

# return $self;

# }

    if ($self->{script} eq 'login.pl' &&

        ($self->{action} eq 'authenticate'  || $self->{action} eq '__default' 

        || !$self->{action})){

        return $self;

}

    if (!$self->{company} && $self->is_run_mode('cgi', 'mod_perl')){

         my $ccookie = $cookie{${LedgerSMB::Sysconfig::cookie_name}};

         $ccookie =~ s/.*:([^:]*)$/$1/;

         $self->{company} = $ccookie;

}

    $self->_db_init;

    if ($self->is_run_mode('cgi', 'mod_perl')) {

#check for valid session unless this is an inital authentication

#request -- CT

       if (!LedgerSMB::Auth::session_check( $cookie{${LedgerSMB::Sysconfig::cookie_name}}, $self) ) {

            print STDERR "Session did not check";

            $self->_get_password("Session Expired");

exit;

}

       $self->{_user} = LedgerSMB::User->fetch_config($self);

}

    my %date_setting = (

        'mm/dd/yy' => "SQL, US",

        'mm-dd-yy' => "POSTGRES, US",

        'dd/mm/yy' => "SQL, EUROPEAN",

        'dd-mm-yy' => "POSTGRES, EUROPEAN",

        'dd.mm.yy' => "GERMAN",

);

    $self->{dbh}->do("set DateStyle to '" 

        .$date_setting{$self->{_user}->{dateformat}}."'");

#my $locale = LedgerSMB::Locale->get_handle($self->{_user}->{countrycode})

    $self->{_locale} = LedgerSMB::Locale->get_handle('en') # temporary

     or $self->error(__FILE__.':'.__LINE__.": Locale not loaded: $!\n");

    $self->{stylesheet} = $self->{_user}->{stylesheet};

    return $self;

}

#This function needs to be moved into the session handler.

sub _get_password {

    my ($self) = shift @_;

    $self->{sessionexpired} = shift @_;

    LedgerSMB::Auth::credential_prompt();

exit;

}

sub debug {

    my $self = shift @_;

    my $args = shift @_;

    my $file;

    if (scalar keys %$args){

        $file = $args->{'file'};

}

    my $d    = Data::Dumper->new( [$self] );

    $d->Sortkeys(1);

    if ($file) {

        open( FH, '>', "$file" ) or die $!;

        print FH $d->Dump();

        close(FH);

}

else {

        print "\n";

        print $d->Dump();

}

sub escape {

    my $self = shift;

    my %args = @_;

    my $str  = $args{string};

    my $regex = qr/([^a-zA-Z0-9_.-])/;

    $str =~ s/$regex/sprintf("%%%02x", ord($1))/ge;

    return $str;

}

sub is_blank {

    my $self = shift @_;

    my %args = @_;

    my $name = $args{name};

    if (not defined $name){

# TODO: Raise error

}

    my $rc;

    if ( $self->{$name} =~ /^\s*$/ ) {

        $rc = 1;

}

else {

        $rc = 0;

}

$rc;

}

sub is_run_mode {

    my $self = shift @_;

    my $mode = lc shift @_;

    my $rc   = 0;

    if ( $mode eq 'cgi' && $ENV{GATEWAY_INTERFACE} ) {

        $rc = 1;

}

    elsif ( $mode eq 'cli' && !( $ENV{GATEWAY_INTERFACE} || $ENV{MOD_PERL} ) ) {

        $rc = 1;

}

    elsif ( $mode eq 'mod_perl' && $ENV{MOD_PERL} ) {

        $rc = 1;

}

$rc;

}

sub num_text_rows {

    my $self    = shift @_;

    my %args    = @_;

    my $string  = $args{string};

    my $cols    = $args{cols};

    my $maxrows = $args{max};

    my $rows = 0;

    for ( split /\n/, $string ) {

        my $line = $_;

        while ( length($line) > $cols ) {

            my $fragment = substr( $line, 0, $cols + 1 );

            $fragment =~ s/^(.*)\W.*$/$1/;

            $line =~ s/$fragment//;

            if ( $line eq $fragment ) {    # No word breaks!

                $line = "";

}

            ++$rows;

}

        ++$rows;

}

    if ( !defined $maxrows ) {

        $maxrows = $rows;

}

    return ( $rows > $maxrows ) ? $maxrows : $rows;

}

sub redirect {

    my $self = shift @_;

    my %args = @_;

    my $msg  = $args{msg};

    if ( $self->{callback} || !$msg ) {

main::redirect();

exit;

}

else {

        $self->info($msg);

}

# TODO: Either we should have an amount class with formats and such attached

# Or maybe we should move this into the user class...

sub format_amount {

# Based on SQL-Ledger's Form::format_amount

    my $self     = shift @_;

    my %args  = (ref($_[0]) eq 'HASH')? %{$_[0]}: @_;

    my $myconfig = $args{user} || $self->{_user};

    my $amount   = $args{amount};

    my $places   = $args{precision};

    my $dash     = $args{neg_format};

    my $format   = $args{format};

    if (!defined $format){

       $format = $myconfig->{numberformat}

}

    if (!defined $args{precision} and defined $args{money}){

       $places = $LedgerSMB::Sysconfig::decimal_places;

}

    my $negative;

    if ($amount) {