File Coverage

blib/lib/Acme/Pythonic/Functions.pm

Criterion	Covered	Total	%
statement	15	201	7.4
branch	0	94	0.0
condition	0	21	0.0
subroutine	5	31	16.1
pod	24	26	92.3
total	44	373	11.8

package Acme::Pythonic::Functions;

use 5;
use warnings;
use strict;

#######################################################################
#  Acme::Pythonic::Functions is Copyright (C) 2009-2012, Hauke Lubenow.
#
#  This module is free software; you can redistribute it and/or modify it
#  under the same terms as Perl 5.14.2.
#  For more details, see the full text of the licenses in the directory
#  LICENSES. The full text of the licenses can also be found in the
#  documents 'perldoc perlgpl' and 'perldoc perlartistic' of the official
#  Perl 5.14.2-distribution. In case of any contradictions, these
#  'perldoc'-texts are decisive.
#
#  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.
#  FOR MORE DETAILS, SEE THE FULL TEXTS OF THE LICENSES IN THE DIRECTORY
#  LICENSES AND IN THE 'PERLDOC'-TEXTS MENTIONED ABOVE.
#######################################################################

use Carp;

use Exporter;

our ($VERSION, @ISA, @EXPORT);
@ISA         = qw(Exporter);

$VERSION     = 0.38;

@EXPORT      = qw(append endswith extend has_key insert isdigit isin isdir isfile len listdir lstrip lstrip2 oslistdir osname pront readfile remove replace rstrip rstrip2 startswith strip writefile);

# Internal Functions

sub checkArgs {

    my ($nr, @vals) = @_;

    my $lenvals = @vals;

    if($lenvals != $nr) {

        my $name = (caller 1)[3];
        my @temp = split("::", $name);
        $name = pop(@temp) . "()";

        my $arg = "arguments";

        if($nr == 1) {
            $arg = "argument";
        }

        croak "Error: Function '$name' takes exactly $nr $arg ($lenvals given),";
    }
}

# print-Replacement-Function

sub pront {
    if ($#_ == -1) {
        @_ = ("");
    }
    for (@_) {
        print"$_\n"
    }
}

# String-Functions

sub endswith {

    &checkArgs(2, @_);

    if ($_[0] =~ /\Q$_[1]\E$/) {
        return 1;
    }
    else {
        return 0;
    }
}


sub lstrip {

    &checkArgs(1, @_);

    my $a = $_[0];

    $a =~ s/^\s+//;

    return $a;
}


sub isdigit {

    &checkArgs(1, @_);

    if($_[0] =~ /\D/) {
        return 0;
    }
    else {
        return 1;
    }
}


sub lstrip2 {

    &checkArgs(2, @_);

    my ($a, $b) = @_;

    if($a !~ /^\Q$b\E/) {
        return $a;
    }

    if (length($b) > length($a)) {
        return $a;
    }

    return substr($a, length($b));
}


sub replace {

    my $nrargs = @_;

    if($nrargs < 3 || $nrargs > 4) {
        croak "Error: Function 'replace()' takes either 3 or 4 arguments ($nrargs given),";
    }

    my $count = 0;

    if($nrargs == 4) {
        $count = pop(@_);
    }

    unless (isdigit($count)) {
        carp "Warning: Argument 4 of function 'replace()' should be a number; assuming 0,";
        $count = 0;
    }

    my ($all, $old, $new) = @_;

    if ($count == 0) {
        $all =~ s/\Q$old\E/$new/g;
        return $all;
    }

    for (1 .. $count) {
        $all =~ s/\Q$old\E/$new/;
    }

    return $all;
}


sub rstrip {

    &checkArgs(1, @_);

    my $a = $_[0];

    $a =~ s/\s+$//;

    return $a;
}


sub rstrip2 {

    &checkArgs(2, @_);

    my ($a, $b) = @_;

    if($a !~ /\Q$b\E$/) {
        return $a;
    }

    if (length($b) > length($a)) {
        return $a;
    }

    return substr($a, 0, length($a) - length($b));
}


sub startswith {

    &checkArgs(2, @_);

    if ($_[0] =~ /^\Q$_[1]\E/) {
        return 1;
    }
    else {
        return 0;
    }
}


sub strip {

    &checkArgs(1, @_);

    my $a = $_[0];

    $a =~ s/^\s+//;
    $a =~ s/\s+$//;

    return $a;
}

# List-Functions

sub append {

    if($#_ < 1) {
        carp "Warning: Not enough arguments for 'append()',";
    }

    return @_;
}

sub extend {

    if($#_ < 1) {
        carp "Warning: Not enough arguments for 'extend()',";
    }

    return @_;
}


sub insert {

    if($#_ < 1) {
        carp "Warning: Not enough arguments for 'insert()'; nothing inserted,";
        return @_;
    }

    my $a = pop;
    my $b = pop;

    if($b =~ /\D/) {
        carp "Warning: Second argument for 'insert()' must be a number; nothing inserted,";
        return @_;
    }

    my @c = @_;

    if ($b > $#c + 1) {
        carp "Warning: Position for 'insert()' beyond list; nothing inserted,";
        return @_;
    }

    splice(@c, $b, 0, $a);

    return @c;
}


sub lenlist {
    return $#_ + 1;
}


sub remove {

    if($#_ < 1) {
        carp "Warning: Not enough arguments for 'remove()',";
        return @_;
    }

    my $a = pop;

    my @b = @_;
    my $i;
    my $x = 0;

    for $i (0 .. $#_) {
        if ($_[$i] eq $a) {
            splice(@b, $i, 1);
            $x = 1;
            last;
        }
    }

    unless($x) {
        carp "Warning: Element to remove not found in list; nothing removed,";
    }

    return @b;
}

# Hash-Functions

sub has_key {

    if($#_ < 2 || $#_ % 2) {
        croak "Error: Unsuitable arguments to 'has_key()',";
    }

    my $key = pop;
    my %hash = @_;

    if (exists $hash{$key}) {
        return 1;
    }
    else {
        return 0;
    }
}


# Functions for several datatypes

sub isin {

    my $lenarg = @_;

    if ($lenarg < 3) {
        croak "Error: 'isin()' takes at least 3 arguments ($lenarg given),";
    }

    my $mode = pop;

    if ($mode ne "s" && $mode ne "l" && $mode ne "h") {
        croak "Error: Last argument to 'isin()' must be 's', 'l' or 'h',";
    }

    if ($mode eq "s") {

        if ($lenarg != 3) {
            croak "Error: 'isin()' in mode 's' takes exactly 3 arguments ($lenarg given),";
        }

        if ($_[0] =~ m/\Q$_[1]\E/) {
            return 1;
        }
        return 0;
    }

    if ($mode eq "l") {
        my $a = pop;
        for (@_) {
            if ($_ eq $a) {
                return 1;
            }
        }
        return 0;
    }

    # Only mode 'h' is left by now.

    if ($lenarg % 2) {
        croak "Error: Unsuitable arguments to 'isin()' in 'h'-mode,";
    }

    my $key = pop;
    my %hash = @_;

    if (exists $hash{$key}) {
        return 1;
    }
    else {
        return 0;
    }
}

sub len {

    my $lenarg = @_;

    if ($lenarg < 2) {
        croak "Error: 'len()' takes at least 2 arguments ($lenarg given),";
    }

    my $mode = pop;

    if ($mode ne "s" && $mode ne "l" && $mode ne "h") {
        croak "Error: Last argument to 'len()' must be 's', 'l' or 'h',";
    }

    if ($mode eq "s") {

        if ($lenarg != 2) {
            croak "Error: 'len()' in mode 's' takes exactly 2 arguments ($lenarg given),";
        }

        return length($_[0]);
    }

    if ($mode eq "l") {
        return $lenarg - 1;
    }

    # Only mode 'h' is left by now.

    if (! $lenarg % 2) {
        croak "Error: Unsuitable arguments to 'isin()' in 'h'-mode,";
    }

    return ($lenarg - 1) / 2;
}


# File-related-Functions

sub isdir {

    &checkArgs(1, @_);

    if(-d $_[0]) {
        return 1;
    }
    else {
        return 0;
    }
}

sub isfile {

    &checkArgs(1, @_);

    if(-f $_[0]) {
        return 1;
    }
    else {
        return 0;
    }
}

sub readfile {

    &checkArgs(1, @_);

    my $file = shift;

    open(FH, "<$file") or croak "Error reading file '$file',";
    my @a = ; # Gulp !
    close(FH);

    return @a;
}


sub writefile {

    if($#_ < 1) {
        croak "Error: Function 'writefile()' needs a list to write to a file as an argument,";
    }

    my ($file, @a) = @_;

    open(FH, ">$file") or croak "Error writing to file '$file',";

    print(FH @a);

    close(FH);
}

sub listdir {

    &checkArgs(1, @_);

    my $dir = shift;
    if (! -d $dir) {
        croak "Error: No such directory: '$dir',";
    }
    my $filename;
    my @files = ();
    opendir (DIR, $dir) || croak "Error opening directory '$dir',";
    while(($filename = readdir(DIR))){
        if ($filename ne "." && $filename ne "..") {
            push(@files, "$filename");
        }
    }
    return @files;
}

sub oslistdir {
    return listdir(@_);
}


# System-related-Functions

sub osname {

    &checkArgs(0);

    return $^O;
}

1;

__END__