ikiwiki/legacy - old ikiwiki engine, based on git.ikiwiki.info

summary refs log tree commit diff

path: root/smiley_nb

diff options

Diffstat (limited to 'smiley_nb')

0 files changed, 0 insertions, 0 deletions

span>

preferences, the negative format (- or DR/CR). Note that it may move to

LedgerSMB::User at some point in the future.

=item parse_amount (user => $LedgerSMB::User::hash, amount => $variable);

If $amount is a Bigfloat, it is returned as is. If it is a string, it is

parsed according to the user preferences stored in the LedgerSMB::User object.

=item is_blank (name => $string)

This function returns true if $self->{$string} only consists of whitespace

characters or is an empty string.

=item is_run_mode ('(cli|cgi|mod_perl)')

This function 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.

# 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;

use Math::BigFloat lib => 'GMP';

use LedgerSMB::Sysconfig;

use Data::Dumper;

use strict;

package LedgerSMB;

sub new {

    my $type   = shift @_;

    my $argstr = shift @_;

    my $self = {};

    $self->{version}   = "1.3.0 Alpha 0 Pre";

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

    bless $self, $type;

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

    my $params = $query->Vars;

    $self->merge($params);

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

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

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

        $self->{menubar} = 1;

#menubar will be deprecated, replaced with below

        $self->{lynx} = 1;

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

}

else {

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

}

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

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

}

$self;

}

sub debug {

    my $self = shift @_;

    my %args = @_;

    my $file = $args{file};

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

    $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) = @_;

    my %args   = @_;

    my $str    = $args{string};

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

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

$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 );

            my $fragment = s/^(.*)\S*$/$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();

}

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     = @_;

    my $myconfig = $args{user};

    my $amount   = $args{amount};

    my $places   = $args{precision};

    my $dash     = $args{neg_format};

    my $negative;

    if ($amount) {

        $amount = $self->parse_amount( $myconfig, $amount );

        $negative = ( $amount < 0 );

        $amount =~ s/-//;

}

    if ( $places =~ /\d+/ ) {

#$places = 4 if $places == 2;

        $amount = $self->round_amount( $amount, $places );

}

# is the amount negative

# Parse $myconfig->{numberformat}

    my ( $ts, $ds ) = ( $1, $2 );

    if ($amount) {

        if ( $myconfig->{numberformat} ) {

            my ( $whole, $dec ) = split /\./, "$amount";

            $amount = join '', reverse split //, $whole;

            if ($places) {

                $dec .= "0" x $places;

                $dec = substr( $dec, 0, $places );

}

            if ( $myconfig->{numberformat} eq '1,000.00' ) {

                $amount =~ s/\d{3,}?/$&,/g;

                $amount =~ s/,$//;

                $amount = join '', reverse split //, $amount;

                $amount .= "\.$dec" if ( $dec ne "" );

}

            if ( $myconfig->{numberformat} eq '1 000.00' ) {

                $amount =~ s/\d{3,}?/$& /g;

                $amount =~ s/\s$//;

                $amount = join '', reverse split //, $amount;

                $amount .= "\.$dec" if ( $dec ne "" );

}

            if ( $myconfig->{numberformat} eq "1'000.00" ) {

                $amount =~ s/\d{3,}?/$&'/g;

                $amount =~ s/'$//;

                $amount = join '', reverse split //, $amount;

                $amount .= "\.$dec" if ( $dec ne "" );

}

            if ( $myconfig->{numberformat} eq '1.000,00' ) {

                $amount =~ s/\d{3,}?/$&./g;

                $amount =~ s/\.$//;

                $amount = join '', reverse split //, $amount;

                $amount .= ",$dec" if ( $dec ne "" );

}

            if ( $myconfig->{numberformat} eq '1000,00' ) {

                $amount = "$whole";

                $amount .= ",$dec" if ( $dec ne "" );

}

            if ( $myconfig->{numberformat} eq '1000.00' ) {

                $amount = "$whole";

                $amount .= ".$dec" if ( $dec ne "" );

}

            if ( $dash =~ /-/ ) {

                $amount = ($negative) ? "($amount)" : "$amount";

}

            elsif ( $dash =~ /DRCR/ ) {

                $amount = ($negative) ? "$amount DR" : "$amount CR";

}

else {

                $amount = ($negative) ? "-$amount" : "$amount";

}

else {

        if ( $dash eq "0" && $places ) {

            if ( $myconfig->{numberformat} eq '1.000,00' ) {

                $amount = "0" . "," . "0" x $places;

}

else {

                $amount = "0" . "." . "0" x $places;

}

else {

            $amount = ( $dash ne "" ) ? "$dash" : "";

}

$amount;

}

# This should probably go to the User object too.

sub parse_amount {

    my $self     = shift @_;

    my %args     = @_;

    my $myconfig = $args{user};

    my $amount   = $args{amount};

    if ( $amount eq '' or $amount == undef ) {

        return 0;

}

    if ( UNIVERSAL::isa( $amount, 'Math::BigFloat' ) )

{ # Amount may not be an object

        return $amount;

}

    my $numberformat = $myconfig->{numberformat};

    if (   ( $numberformat eq '1.000,00' )

        || ( $numberformat eq '1000,00' ) )

{

        $amount =~ s/\.//g;

        $amount =~ s/,/./;

}

    if ( $numberformat eq '1 000.00' ) {

        $amount =~ s/\s//g;

}

    if ( $numberformat eq "1'000.00" ) {

        $amount =~ s/'//g;

}

    $amount =~ s/,//g;

    if ( $amount =~ s/\((\d*\.?\d*)\)/$1/ ) {

        $amount = $1 * -1;

}

    if ( $amount =~ s/(\d*\.?\d*)\s?DR/$1/ ) {

        $amount = $1 * -1;

}

    $amount =~ s/\s?CR//;

    $amount = new Math::BigFloat($amount);

    return ( $amount * 1 );

}

sub round_amount {

    my ( $self, $amount, $places ) = @_;

# These rounding rules follow from the previous implementation.

# They should be changed to allow different rules for different accounts.

    Math::BigFloat->round_mode('+inf') if $amount >= 0;

    Math::BigFloat->round_mode('-inf') if $amount < 0;

    $amount = Math::BigFloat->new($amount)->ffround( -$places ) if $places >= 0;

    $amount = Math::BigFloat->new($amount)->ffround( -( $places - 1 ) )

      if $places < 0;

    return $amount;

}

sub call_procedure {

    my $self     = shift @_;

    my %args     = @_;

    my $procname = $args{procname};

    my @args     = @{ $args{args} };

    my $order_by = $args{order_by};

    my $argstr   = "";

    my @results;

    for ( 1 .. scalar @args ) {

        $argstr .= "?, ";

}

    $argstr =~ s/\, $//;

    my $query = "SELECT * FROM $procname()";

    if ($order_by){

        $query .= " ORDER BY $order_by";

}

    $query =~ s/\(\)/($argstr)/;

    my $sth = $self->{dbh}->prepare($query);

    $sth->execute(@args);

    my @types = @{$sth->{TYPE}};

    my @names = @{$sth->{NAME_lc}};

    while ( my $ref = $sth->fetchrow_hashref('NAME_lc') ) {

    for (0 .. $#names){

            if ($types[$_] == 3){

                $ref->{$names[$_]} = Math::BigFloat->new($ref->{$names[$_]});

}

        push @results, $ref;

}

@results;

}

# Keeping this here due to common requirements

sub is_allowed_role {

    my $self = shift @_;


context:
space:
mode: