File Coverage

blib/lib/Siffra/Tools.pm

Criterion	Covered	Total	%
statement	64	329	19.4
branch	2	94	2.1
condition	2	30	6.6
subroutine	19	40	47.5
pod	18	18	100.0
total	105	511	20.5

package Siffra::Tools;

use 5.014;
use strict;
use warnings;
use Carp;
use utf8;
use Data::Dumper;
use DDP;
use Log::Any qw($log);
use Scalar::Util qw(blessed);
$Carp::Verbose = 1;

$| = 1;    #autoflush

use constant {
    FALSE => 0,
    TRUE  => 1,
    DEBUG => $ENV{ DEBUG } // 0,
};

use MIME::Types;
use IO::Uncompress::Unzip qw(unzip $UnzipError);

my %driverConnections = (
    pgsql => {
        module => 'DBD::Pg',
        dsn    => 'DBI:Pg(AutoCommit=>1,RaiseError=>1,PrintError=>1):dbname=%s;host=%s;port=%s',
    },
    mysql => {
        module => 'DBD::mysql',
    },
    sqlite => {
        module => 'DBD::SQLite',
    },
);

BEGIN
{
    binmode( STDOUT, ":encoding(UTF-8)" );
    binmode( STDERR, ":encoding(UTF-8)" );

    require Siffra::Base;
    use Exporter ();
    use vars qw($VERSION @ISA @EXPORT @EXPORT_OK %EXPORT_TAGS);
    $VERSION = '0.27';
    @ISA     = qw(Siffra::Base Exporter);

    #Give a hoot don't pollute, do not export more than needed by default
    @EXPORT      = qw();
    @EXPORT_OK   = qw();
    %EXPORT_TAGS = ();
} ## end BEGIN

#################### subroutine header begin ####################

=head2 sample_function

 Usage     : How to use this function/method
 Purpose   : What it does
 Returns   : What it returns
 Argument  : What it wants to know
 Throws    : Exceptions and other anomolies
 Comment   : This is a sample subroutine header.
           : It is polite to include more pod and fewer comments.

See Also   :

=cut

#################### subroutine header end ####################

=head2 C<new()>

  Usage     : $self->block_new_method() within text_pm_file()
  Purpose   : Build 'new()' method as part of a pm file
  Returns   : String holding sub new.
  Argument  : $module: pointer to the module being built
              (as there can be more than one module built by EU::MM);
              for the primary module it is a pointer to $self
  Throws    : n/a
  Comment   : This method is a likely candidate for alteration in a subclass,
              e.g., pass a single hash-ref to new() instead of a list of
              parameters.

=cut

sub new
{
    $log->debug( "new", { progname => $0, pid => $$, perl_version => $], package => __PACKAGE__ } );
    my ( $class, %parameters ) = @_;
    my $self = $class->SUPER::new( %parameters );

    return $self;
} ## end sub new

sub _initialize()
{
    $log->debug( "_initialize", { package => __PACKAGE__ } );
    my ( $self, %parameters ) = @_;
    $self->SUPER::_initialize( %parameters );

    eval { require JSON::XS; };
    $self->{ json } = JSON::XS->new->utf8;
} ## end sub _initialize

sub _finalize()
{
    $log->debug( "_finalize", { package => __PACKAGE__ } );
    my ( $self, %parameters ) = @_;
    $self->SUPER::_finalize( %parameters );
}

sub END
{
    $log->debug( "END", { package => __PACKAGE__ } );
    eval { $log->{ adapter }->{ dispatcher }->{ outputs }->{ Email }->flush; };
}

sub DESTROY
{
    my ( $self, %parameters ) = @_;
    $log->debug( 'DESTROY', { package => __PACKAGE__, GLOBAL_PHASE => ${^GLOBAL_PHASE}, blessed => FALSE } );
    return if ${^GLOBAL_PHASE} eq 'DESTRUCT';

    if ( blessed( $self ) && $self->isa( __PACKAGE__ ) )
    {
        $log->debug( "DESTROY", { package => __PACKAGE__, GLOBAL_PHASE => ${^GLOBAL_PHASE}, blessed => TRUE } );
    }
    else
    {
        # TODO
    }
} ## end sub DESTROY

=head2 C<connectDB()>
=cut

sub connectDB()
{
    my ( $self, %parameters ) = @_;
    $log->debug( "connectDB", { package => __PACKAGE__ } );

    my ( $database, $host, $password, $port, $username, $connection );

    if ( %parameters )
    {
        $connection = $parameters{ connection };
        $database   = $parameters{ database };
        $host       = $parameters{ host };
        $password   = $parameters{ password };
        $port       = $parameters{ port };
        $username   = $parameters{ username };
    } ## end if ( %parameters )
    elsif ( defined $self->{ configurations }->{ database } )
    {
        $connection = $self->{ configurations }->{ database }->{ connection };
        $database   = $self->{ configurations }->{ database }->{ database };
        $host       = $self->{ configurations }->{ database }->{ host };
        $password   = $self->{ configurations }->{ database }->{ password };
        $port       = $self->{ configurations }->{ database }->{ port };
        $username   = $self->{ configurations }->{ database }->{ username };
    } ## end elsif ( defined $self->{ ...})
    else
    {
        $log->error( "Tentando conectar mas sem configuração de DB..." );
        return FALSE;
    }

    my $driverConnection = $driverConnections{ lc $connection };
    if ( $driverConnection )
    {
        eval {
            require DBI;
            require "$driverConnection->{ module }";
        };

        my $dsn = sprintf( $driverConnection->{ dsn }, $database, $host, $port );
        my ( $scheme, $driver, $attr_string, $attr_hash, $driver_dsn ) = DBI->parse_dsn( $dsn ) or die "Can't parse DBI DSN '$dsn'";
        my $data_source = "$scheme:$driver:$driver_dsn";
        $log->info( $data_source );
        $log->info( "Conectando no banco $username\@$host\:$database" );
        $self->{ database }->{ connection } = eval { DBI->connect( $data_source, $username, $password, $attr_hash ); };

        if ( $@ )
        {
            $log->error( "Erro ao conectar ao banco [ $data_source ] [ $username\@$host:$port ]." );
            $log->error( @_ );
            return FALSE;
        } ## end if ( $@ )
    } ## end if ( $driverConnection...)
    else
    {
        $log->error( "Connection [ $connection ] não existe configuração..." );
        return FALSE;
    }

    return $self->{ database }->{ connection };
} ## end sub connectDB

=head2 C<begin_work()>
=cut

sub begin_work()
{
    my ( $self, %parameters ) = @_;
    if ( !defined $self->{ database }->{ connection } )
    {
        $log->error( "Tentando começar uma transação sem uma conexão com DB..." );
        return FALSE;
    }
    my $rc = $self->{ database }->{ connection }->begin_work or die $self->{ database }->{ connection }->errstr;
    return $rc;
} ## end sub begin_work

=head2 C<commit()>
=cut

sub commit()
{
    my ( $self, %parameters ) = @_;
    if ( !defined $self->{ database }->{ connection } )
    {
        $log->error( "Tentando commitar uma transação sem uma conexão com DB..." );
        return FALSE;
    }
    my $rc = $self->{ database }->{ connection }->commit or die $self->{ database }->{ connection }->errstr;
    return $rc;
} ## end sub commit

=head2 C<rollback()>
=cut

sub rollback()
{
    my ( $self, %parameters ) = @_;
    if ( !defined $self->{ database }->{ connection } )
    {
        $log->error( "Tentando reverter uma transação sem uma conexão com DB..." );
        return FALSE;
    }
    my $rc = $self->{ database }->{ connection }->rollback or die $self->{ database }->{ connection }->errstr;
    return $rc;
} ## end sub rollback

=head2 C<prepareQuery()>
=cut

sub prepareQuery
{
    my ( $self, %parameters ) = @_;
    my $sql = $parameters{ sql };

    my $sth = $self->{ database }->{ connection }->prepare( $sql ) or die $self->{ database }->{ connection }->errstr;
    return $sth;
} ## end sub prepareQuery

=head2 C<doQuery()>
=cut

sub doQuery
{
    my ( $self, %parameters ) = @_;
    my $sql = $parameters{ sql };

    my $sth = $self->{ database }->{ connection }->do( $sql ) or die $self->{ database }->{ connection }->errstr;
    return $sth;
} ## end sub doQuery

=head2 C<executeQuery()>
=cut

sub executeQuery()
{
    my ( $self, %parameters ) = @_;
    my $sql = $parameters{ sql };

    $self->connectDB() unless ( defined( $self->{ database }->{ connection } ) );

    my $sth = $self->prepareQuery( sql => $sql );
    my $res = $sth->execute() or die $self->{ database }->{ connection }->errstr;

    my @rows;
    my $line;
    push( @rows, $line ) while ( $line = $sth->fetchrow_hashref );

    return @rows;
} ## end sub executeQuery

=head2 C<teste()>
=cut

sub teste()
{
    my ( $self, %parameters ) = @_;

    $self->{ configurations }->{ teste } = 'LALA';
    return $self;
} ## end sub teste

=head2 C<getFileMD5()>
-------------------------------------------------------------------------------
 Retorna o MD5 do arquivo
 Parametro 1 - Caminho e nome do arquivo a ser calculado
 Retorna o MD5 do arquivo informado
-------------------------------------------------------------------------------
=cut

sub getFileMD5()
{
    my ( $self, %parameters ) = @_;
    my $file = $parameters{ file };

    return FALSE unless ( -e $file );

    my $return;

    eval { require Digest::MD5; };
    if ( $@ )
    {
        $log->error( 'Package Digest::MD5 não encontrado...' );
        return FALSE;
    }

    if ( open( my $fh, $file ) )
    {
        binmode( $fh );
        $return = Digest::MD5->new->addfile( $fh )->hexdigest;
        close( $fh );
    } ## end if ( open( my $fh, $file...))
    else
    {
        $log->error( "Não foi possível abrir o arquivo [ $file ]..." );
    }

    return $return;
} ## end sub getFileMD5

=head2 C<parseBlockText()>
=cut

sub parseBlockText()
{
    my $me     = ( caller( 0 ) )[ 3 ];
    my $parent = ( caller( 1 ) )[ 3 ];
    $log->debug( "parseBlockText", { package => __PACKAGE__, file => __FILE__, me => $me, parent => $parent } );

    my ( $self, %parameters ) = @_;
    my $file        = $parameters{ file };
    my $layout      = $parameters{ layout };
    my $length_type = $parameters{ length_type };
    my $retorno     = { rows => undef, error => 0, message => undef, };

    if ( !$file || !-e $file )
    {
        $log->error( "O arquivo [ $file ] não existe..." );
        $retorno->{ message } = 'Arquivo não existe';
        $retorno->{ error }   = TRUE;
        return $retorno;
    } ## end if ( !$file || !-e $file...)

    my $fh;
    my $types = MIME::Types->new;
    my $mime  = $types->mimeTypeOf( $file );

    if ( $mime->{ MT_type } =~ /application\/zip/ )
    {
        $log->info( "Arquivo zipado, tentando descompactar..." );
        $fh = new IO::Uncompress::Unzip $file or die "IO::Uncompress::Unzip failed: $UnzipError\n";
        $log->info( "Arquivo descompactado com sucesso..." );

        my $HeaderInfo         = $fh->getHeaderInfo();
        my $UncompressedLength = $HeaderInfo->{ UncompressedLength }->get64bit();

    } ## end if ( $mime->{ MT_type ...})
    else
    {
        open $fh, "<:encoding(UTF-8)", $file or die "Erro ao abrir o arquivo [ $file ]...\n";
    }

    $log->info( "Começando a parsear o arquivo [ $file ]..." );

    while ( my $linha = <$fh> )
    {
        $linha =~ s/\n|\r//g;

        my $tipo_de_registro = substr( $linha, 0, $length_type );
        my $posicao          = 0;
        my $auxiliar         = ();

        if ( !$layout->{ $tipo_de_registro } )
        {
            my $tipos = join ",", sort keys %{ $layout };
            my $msg   = "Não existe o tipo de registro [ $tipo_de_registro ] no layout cadastrado [ $tipos ] na linha [ $. ]...";
            $log->error( $msg );
            $log->error( "Linha [ $. ] = [$linha]..." );
            $retorno->{ rows }    = undef;
            $retorno->{ message } = $msg;
            $retorno->{ error }   = 1;
            return $retorno;
        } ## end if ( !$layout->{ $tipo_de_registro...})

        my $tamanho_da_linha_no_layout  = $layout->{ $tipo_de_registro }->{ total_length };
        my $tamanho_da_linha_no_arquivo = length( $linha );

        if ( $tamanho_da_linha_no_arquivo != $tamanho_da_linha_no_layout )
        {
            my $msg = "Tamanho da linha [ $. ] do tipo [ $tipo_de_registro ] no arquivo [ $file ] ($tamanho_da_linha_no_arquivo) esta diferente do layout ($tamanho_da_linha_no_layout)";

            #my $msg = "Tamanho da linha [ %d ] do tipo [ %s ] no arquivo [ %s ] ( %d ) esta diferente do layout ( %d )";
            #$log->error( $msg );
            $retorno->{ rows }    = undef;
            $retorno->{ message } = $msg;
            $retorno->{ error }   = 1;
            return $retorno;
        } ## end if ( $tamanho_da_linha_no_arquivo...)

        foreach my $field ( @{ $layout->{ $tipo_de_registro }->{ fields } } )
        {
            $auxiliar->{ $field->{ field } } = $self->trim( substr( $linha, $posicao, $field->{ length } ) );
            $posicao += $field->{ length };

            my $out = $field->{ out };

            if ( $field->{ match } )
            {
                if ( $auxiliar->{ $field->{ field } } !~ /$field->{match}/ )
                {
                    my $msg = "O campo [ $field->{ field } ] com o valor [ $auxiliar->{ $field->{ field } } ] não corresponde a regra de validação [ $field->{match} ] no registro [ $. ]...";
                    $log->error( $msg );
                    $retorno->{ rows }    = undef;
                    $retorno->{ message } = $msg;
                    $retorno->{ error }   = 1;
                    return $retorno;
                } ## end if ( $auxiliar->{ $field...})

                if ( $out )
                {
                    $out =~ s/\?\?\?/$auxiliar->{ $field->{field} }/g;
                    $auxiliar->{ $field->{ field } } = eval( $out );
                }
            } ## end if ( $field->{ match }...)
            elsif ( $out && $out !~ /\$/ )
            {
                $out =~ s/\?\?\?/$auxiliar->{ $field->{field} }/g;
                $auxiliar->{ $field->{ field } } = eval( $out );
            }
        } ## end foreach my $field ( @{ $layout...})

        push( @{ $retorno->{ rows }->{ $tipo_de_registro } }, $auxiliar );
    } ## end while ( my $linha = <$fh>...)
    return $retorno;
} ## end sub parseBlockText

=head2 C<parseCSV()>
=cut

sub parseCSV()
{
    my ( $self, %parameters ) = @_;
    my $file           = $parameters{ file };
    my $sep_char       = $parameters{ sep_char } // ',';
    my $quote_char     = $parameters{ quote_char } // '"';
    my $encoding       = $parameters{ encoding } // 'iso-8859-1';
    my $originalHeader = $parameters{ originalHeader };
    my $retorno        = { rows => undef, error => 0, message => undef, };

    $log->info( "Começando a parsear o arquivo [ $file ]..." );

    # Read/parse CSV
    eval { require Text::CSV_XS; };

    if ( $@ )
    {
        $log->error( $@ );
        return $retorno;
    }

    my $csv = eval {

        Text::CSV_XS->new(
            {
                binary             => 1,
                auto_diag          => 0,
                diag_verbose       => 0,
                blank_is_undef     => 1,
                empty_is_undef     => 1,
                allow_loose_quotes => 0,
                sep_char           => $sep_char,
                quote_char         => $quote_char,
                strict             => 1,
            }
        );

    };

    if ( $@ )
    {
        $log->error( $@ );
        $retorno->{ error }   = 1;
        $retorno->{ message } = $@;
    } ## end if ( $@ )
    else
    {
        $csv->callbacks(
            after_parse => sub {

                # Limpar os espaços em branco no começo e no final de cada campo.
                map { defined $_ ? ( ( $_ =~ /^\s+$/ ) ? ( $_ = undef ) : ( s/^\s+|\s+$//g ) ) : undef } @{ $_[ 1 ] };
            },

            #error => sub {
            #    my ( $err, $msg, $pos, $recno, $fldno ) = @_;
            #    Text::CSV_XS->SetDiag(0);
            #    return;
            #}
        );

        my @rows;
        my $fh;
        my $types = MIME::Types->new;
        my $mime  = $types->mimeTypeOf( $file );

        if ( $mime->{ MT_type } =~ /application\/zip/ )
        {
            $log->info( "Arquivo zipado, tentando descompactar..." );
            $fh = new IO::Uncompress::Unzip $file or die "IO::Uncompress::Unzip failed: $UnzipError\n";
            $log->info( "Arquivo descompactado com sucesso..." );

            my $HeaderInfo         = $fh->getHeaderInfo();
            my $UncompressedLength = $HeaderInfo->{ UncompressedLength }->get64bit();

        } ## end if ( $mime->{ MT_type ...})
        else
        {
            open $fh, "<:encoding($encoding)", $file or die "Erro ao abrir o arquivo [ $file ]...\n";
        }

        my @header = eval {
            $csv->header(
                $fh,
                {
                    detect_bom         => ( $encoding =~ /utf-8/i ) ? 1 : 0,
                    sep_set            => [ $sep_char ],
                    munge_column_names => sub {
                        uc;
                    }
                }
            );
        };

        my ( $errorCode, $errorMessage, $position, $line, $field ) = $csv->error_diag();
        if ( $errorCode > 0 )
        {
            undef @rows;
            $retorno->{ error }   = $errorCode;
            $retorno->{ message } = "$errorMessage @ linha $line, posição $position, campo $field";
            return $retorno;
        } ## end if ( $errorCode > 0 )
        $retorno->{ header } = \@header;

        if ( $originalHeader )
        {
            if ( !$self->validaHeader( originalHeader => $originalHeader, header => \@header ) )
            {
                my $msg = 'Header do arquivo está diferente do layout...';
                $retorno->{ error }   = 1;
                $retorno->{ message } = $msg;
                return $retorno;
            } ## end if ( !$self->validaHeader...)
            else
            {
                $log->info( "*** Header validado com sucesso ***" );
            }
        } ## end if ( $originalHeader )

        while ( my $row = $csv->getline( $fh ) )
        {
            push @rows, $row;
        }
        close $fh;

        ( $errorCode, $errorMessage, $position, $line, $field ) = $csv->error_diag();

        # 2012 "EOF - End of data in parsing input stream"
        # 2014 "ENF - Inconsistent number of fields"
        # 2023 "EIQ - QUO character not allowed"
        # 2027 "EIQ - Quoted field not terminated"
        if ( $errorCode > 0 && $errorCode != 2012 )
        {
            undef @rows;
            if ( $errorMessage =~ /Inconsistent number of fields/i )
            {
                $errorMessage = 'Número inconsistente de campos';
            }
            $retorno->{ error }   = $errorCode;
            $retorno->{ message } = "$errorMessage @ linha $line, posição $position, campo $field";
        } ## end if ( $errorCode > 0 &&...)
        else
        {
            @{ $retorno->{ rows } } = @rows;
        }
    } ## end else [ if ( $@ ) ]

    return $retorno;
} ## end sub parseCSV

=head2 C<validaHeader()>
=cut

sub validaHeader()
{
    $log->debug( "validaHeader", { package => __PACKAGE__ } );
    my ( $self, %parameters ) = @_;
    my @originalHeader = @{ $parameters{ originalHeader } };
    my @header         = @{ $parameters{ header } };

    $log->info( "Validando o header do arquivo..." );

    my $originalHeaderString = join( '_&_', @originalHeader );
    my $headerString         = join( '_&_', @header );

    return ( $originalHeaderString eq $headerString ) ? TRUE : FALSE;
} ## end sub validaHeader

=head2 C<validaArCorreios()>
=cut

sub validaArCorreios()
{
    #$log->debug( "validaArCorreios", { package => __PACKAGE__ } );
    my ( $self, %parameters ) = @_;
    my $arCorreios = $parameters{ ar };

    return ( $arCorreios =~ /^([a-zA-Z]{2})(\d{9})([a-zA-Z]{2})$/ ) ? TRUE : FALSE;
} ## end sub validaArCorreios

=head2 C<trim()>
=cut

sub trim()
{
    my ( $self, $string ) = @_;

    eval { $string =~ s/^\s+|\s+$//g; };

    if ( $@ )
    {
        $log->error( "Erro ao fazer o trim na string $string" );
    }

    return $string;
} ## end sub trim

=head2 C<getProgressBar()>
=cut

sub getProgressBar()
{
    my ( $self, %parameters ) = @_;
    my $name   = $parameters{ name }   // 'Progress';
    my $count  = $parameters{ count }  // 0;
    my $remove = $parameters{ remove } // 1;
    my $eta    = $parameters{ eta }    // 'linear';
    my $silent = $parameters{ silent } // !DEBUG;

    eval { require Term::ProgressBar; };
    if ( $@ )
    {
        die Dumper 'Sem o Term::ProgressBar...';
    }

    my $progress = Term::ProgressBar->new(
        {
            name   => $name,
            count  => $count,
            remove => $remove,
            ETA    => $eta,
            silent => $silent,
        }
    );

    return $progress;
} ## end sub getProgressBar

=head2 C<getTimeStampHash()>
=cut

#-------------------------------------------------------------------------------
# Retorna o timestamp atual do sistema em forma de HASH
#-------------------------------------------------------------------------------
sub getTimeStampHash
{
    my ( $self, %parameters ) = @_;
    my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime( time );

    {
        year  => $year + 1900,
        month => sprintf( '%02d', ( $mon + 1 ) ),
        day   => sprintf( '%02d', $mday ),
        hour  => sprintf( '%02d', $hour ),
        min   => sprintf( '%02d', $min ),
        sec   => sprintf( '%02d', $sec ),
        wday  => $wday,
        yday  => $yday,
        isdst => $isdst
    };
} ## end sub getTimeStampHash

=head2 C<getTimeStamp()>
=cut

#-------------------------------------------------------------------------------
# Retorna o timestamp atual do sistema
#-------------------------------------------------------------------------------
sub getTimeStamp
{
    my ( $sec, $min, $hour, $mday, $mon, $year, $wday, $yday, $isdst ) = localtime( time );
    return sprintf( "%4d%02d%02d%02d%02d%02d", $year + 1900, $mon + 1, $mday, $hour, $min, $sec );
}

#################### main pod documentation begin ###################
## Below is the stub of documentation for your module.
## You better edit it!

=encoding UTF-8


=head1 NAME

Siffra::Tools - Module abstract (<= 44 characters) goes here

=head1 SYNOPSIS

  use Siffra::Tools;
  blah blah blah


=head1 DESCRIPTION

Stub documentation for this module was created by ExtUtils::ModuleMaker.
It looks like the author of the extension was negligent enough
to leave the stub unedited.

Blah blah blah.


=head1 USAGE



=head1 BUGS



=head1 SUPPORT



=head1 AUTHOR

    Luiz Benevenuto
    CPAN ID: LUIZBENE
    Siffra TI
    [e-mail]
    https://siffra.com.br

=head1 COPYRIGHT

This program is free software; you can redistribute
it and/or modify it under the same terms as Perl itself.

The full text of the license can be found in the
LICENSE file included with this module.


=head1 SEE ALSO

perl(1).

=cut

#################### main pod documentation end ###################

1;

# The preceding line will help the module return a true value