File manager

File manager - Edit - /usr/local/share/perl5/HDB/CMDS.pm

Back
############################################################################# ## Name: CMDS.pm ## Purpose: HDB::CMDS ## Author: Graciliano M. P. ## Modified by: ## Created: 14/01/2003 ## RCS-ID: ## Copyright: (c) 2002 Graciliano M. P. ## Licence: This program is free software; you can redistribute it and/or ## modify it under the same terms as Perl itself ############################################################################# package HDB::CMDS ; use HDB::Parser ; use strict qw(vars); no warnings ; our $VERSION = '1.0' ; ######## # VARS # ######## my %args_select = ( table => [qw(table)] , where => [qw(where w)] , limit => [qw(limit limite)] , sort => [qw(sort order)] , group => [qw(group grop)] , return => [qw(return ret r)] , col => [qw(col cols)] , cache => [[qw(cache)],1] , ); my %DEFAULT_COLS = ( 'address' => 200 , 'age' => 'INTEGER' , 'bairro' => 30 , 'cep' => 9 , 'cidade' => 40 , 'city' => 40 , 'country' => 4 , 'data' => 'int(9999999999)' , 'date' => 'int(9999999999)' , 'descricao' => 'TEXT' , 'email' => 50 , 'endereco' => 200 , 'estado' => 3 , 'fax' => 'INTEGER' , 'hits' => 'INTEGER' , 'hora' => 8 , 'id' => 'INTEGER' , 'idade' => 'INTEGER' , 'mail' => 50 , 'message' => 'TEXT' , 'msg' => 'TEXT' , 'mensagem' => 'TEXT' , 'name' => 40 , 'nick' => 16 , 'nome' => 40 , 'pais' => 4 , 'pass' => 16 , 'password' => 16 , 'phone' => 'INTEGER' , 'preco' => 15 , 'price' => 15 , 'senha' => 16 , 'sex' => 1 , 'sexo' => 1 , 'size' => 5 , 'state' => 3 , 'tamanho' => 5 , 'tel' => 'INTEGER' , 'telefone' => 'INTEGER' , 'temperatura' => 4 , 'time' => 10 , 'titulo' => 250 , 'title' => 250 , 'uf' => 3 , 'uid' => 8 , 'url' => 250 , 'username' => 16 , 'user' => 16 , 'zip' => 9 , ); my @DEFAULT_TYPES = qw(* TEXT INT FLOAT BOOL) ; my %DEFAULT_MOD = ( 'MySQL' => 'mysql' , 'SQLite' => 'sqlite' , 'Oracle' => 'Oracle' , ) ; ################### # PREDEFINED_COLS # ################### sub predefined_columns { return( %DEFAULT_COLS ) ;} ################# # DEFAULT_TYPES # ################# sub default_types { return( @DEFAULT_TYPES ) ;} ############### # DEFAULT_MOD # ############### sub default_mod { return( %DEFAULT_MOD ) ;} ########### # ALIASES # ########### sub sel { &select ;} sub cols { &names ;} sub creat { &create ;} sub create_table { &create ;} sub predefined_cols { &predefined_columns ;} sub sql { $_[0]->{sql} ;} ########## # SELECT # ########## sub select { my $this = shift ; my (undef , $where , @args) = @_ ; if ($_[0] =~ /^table$/i) { @args = @_ ; $where = undef ;} elsif ($#_ >= 2 && $#_ <= 3 && ( ref $_[2] \|\| $_[2] =~ /^(?:(?:n\|names?\|c\|cols?\|columns?)\s[,;]\s)?(?:\$?[\$\@\%]{1,2}\|<[\$\@\%]>)$/i ) ) { if (ref $_[2]) { @args = HDB::CORE::parse_ref($_[2]) ;} elsif ($#_ == 2) { @args = ('return' , $_[2]) ;} } elsif ($#_ == 1 && $_[1] =~ /^(?:(?:n\|names?\|c\|cols?\|columns?)\s[,;]\s)?(?:\$?[\$\@\%]{1,2}\|<[\$\@\%]>)$/i ) { @args = ('return' , $_[1]) ; $where = undef ; } if ($#_ >= 2 && $where =~ /^(?:cache\|col\|cols\|grop\|group\|limit\|limite\|order\|r\|ret\|return\|sort\|table\|w\|where)$/si) { unshift (@args, $where) ; $where = undef ; } my %args ; &HDB::CORE::parse_args(\%args , \%args_select , @args) ; $args{table} = $_[0] if !defined $args{table} ; $args{where} = $where if !defined $args{where} ; $args{table} = _format_table_name($args{table}) ; if (! defined $args{return}) { if ( $_[-1] =~ /^(?:(?:n\|names?\|c\|cols?\|columns?)\s[,;]\s)?(?:\$?[\$\@\%]{1,2}\|<[\$\@\%]>)$/i ) { $args{return} = $_[-1] ;} } $this->{return} = $args{return} ; $this->{sql} = undef ; { my ($cols , $db_max) ; if ($args{col} =~ /^\s([<>])\s([\w\.]+)/) { $db_max = $1 ; $cols = $2 ; } else { $cols = $args{col} ;} if ($db_max) { if ($db_max eq '>') { $db_max = 'max' ;} elsif ($db_max eq '<') { $db_max = 'min' ;} if ($cols eq '') { $cols = "$db_max(ID) as ID" ;} else { $cols = "$db_max($cols) as $cols" ;} } elsif ($cols eq "") { $cols = '' ;} else { $cols =~ s/^\s,//s ; $cols =~ s/,\s$//s ; } my $where = &HDB::Parser::Parse_Where($args{where},$this) ; my $group ; if ( $args{group} ) { $group = "GROUP BY $args{group}" ;} my $sort ; if ( $args{sort} ) { ($sort) = ( $args{sort} =~ /([\w\.]+)/gs ) ; $sort = "ORDER BY $sort" ; if ($args{sort} =~ /</s) { $sort .= ' DESC' ;} } #elsif (! defined $args{sort} ) { $sort = "ORDER BY ID" ;} my $limit ; if ($args{limit} ne '') { my ($sz,$init) = ( $args{limit} =~ /(\d+)(?:\D+(\d+)\|)/ ); my $into_where ; ($limit , $into_where) = $this->LIMIT($sz,$init) ; if ( $into_where ) { $where = "$where AND ($into_where)" ;} } $this->{sql} = "SELECT $cols FROM $args{table}" ; $this->{sql} .= " $where" if $where ne '' ; $this->{sql} .= " $group" if $group ne '' ; $this->{sql} .= " $sort" if $sort ne '' ; $this->{sql} .= " $limit" if $limit ne '' ; } $this->_undef_sth ; eval{ $this->{sth} = $this->dbh->prepare( $this->{sql} ) ; $this->{sth}->{ShowErrorStatement} = 1 ; $this->{sth}->execute ; $this->{sth}->err ; }; return $this->Error("SQL error: $this->{sql}") if $@ ; return $this->Return( $args{return} ) ; } ########## # INSERT # ########## sub insert { my $this = shift ; my ($table , @up) = @_ ; $table = _format_table_name($table) ; if ($#_ == 1) { @up = HDB::CORE::parse_ref($_[1]) ;} return $this->Error('Invalid table!') if !$table ; return $this->Error('Nothing to insert!') if !@up ; my @names = $this->names($table) ; my @cols ; if (ref($_[1]) eq 'HASH') { my %up = @up ; @up = () ; foreach my $names_i ( @names ) { if (defined $up{$names_i}) { push(@up , $up{$names_i}) ; push(@cols , $names_i) ;} elsif (defined $up{uc($names_i)}) { push(@up , $up{uc($names_i)}) ; push(@cols , $names_i) ;} elsif (defined $up{lc($names_i)}) { push(@up , $up{lc($names_i)}) ; push(@cols , $names_i) ;} elsif (defined $up{"\u\L$names_i\E"}) { push(@up , $up{"\u\L$names_i\E"}) ; push(@cols , $names_i) ;} } } else { @cols = @names ;} foreach my $up_i ( @up ) { if (ref($up_i) eq 'HASH') { $up_i = &HDB::Encode::Pack_HASH($up_i) ;} elsif (ref($up_i) eq 'ARRAY') { $up_i = &HDB::Encode::Pack_ARRAY($up_i) ;} &HDB::Parser::filter_null_bytes($up_i) ; } $this->_undef_sth ; { my @ins_pnt = ('?') x @up ; $this->{sql} = "INSERT INTO $table (". join(',',@cols) .") VALUES (". join(',',@ins_pnt) .")" ; eval { $this->{sth} = $this->dbh->prepare( $this->{sql} ) }; } $this->{sth}->{ShowErrorStatement} = 1 ; eval { $this->lock_table($table) if $this->{SQL}{LOCK_TABLE} ; $this->{sth}->execute(@up) ; $this->unlock_table($table) if $this->{SQL}{LOCK_TABLE} ; $this->{sth}->err ; }; $this->_undef_sth ; return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ; $this->ON_INSERT(\@cols,\@up) if $this->can('ON_INSERT') ; return 1 ; } ########## # UPDATE # ########## sub update { my $this = shift ; my ($table , $where , %up) = @_ ; $table = _format_table_name($table) ; if ($#_ == 2) { %up = HDB::CORE::parse_ref($_[2]) ;} if (! $table) { $this->Error('Invalid table!') ;} if (! %up) { $this->Error('Nothing to update!') ;} $where = &HDB::Parser::Parse_Where($where,$this) ; my ($set_cols,@up) ; my @names = $this->names($table) ; foreach my $names_i ( @names ) { if (defined $up{$names_i}) { push(@up , $up{$names_i}) ; $set_cols .= "$names_i = ? , " ;} elsif (defined $up{uc($names_i)}) { push(@up , $up{uc($names_i)}) ; $set_cols .= "\U$names_i\E = ? , " ;} elsif (defined $up{lc($names_i)}) { push(@up , $up{lc($names_i)}) ; $set_cols .= "\L$names_i\E = ? , " ;} elsif (defined $up{"\u\L$names_i\E"}) { push(@up , $up{"\u\L$names_i\E"}) ; $set_cols .= "\u\L$names_i\E = ? , " ;} } return if !@up ; foreach my $up_i ( @up ) { if (ref($up_i) eq 'HASH') { $up_i = &HDB::Encode::Pack_HASH($up_i) ;} elsif (ref($up_i) eq 'ARRAY') { $up_i = &HDB::Encode::Pack_ARRAY($up_i) ;} &HDB::Parser::filter_null_bytes($up_i) ; } $set_cols =~ s/ , $// ; $this->{sql} = "UPDATE $table SET $set_cols $where" ; $this->_undef_sth ; eval { $this->{sth} = $this->dbh->prepare( $this->{sql} ) }; eval { $this->lock_table($table) if $this->{SQL}{LOCK_TABLE} ; $this->{sth}->execute(@up) ; $this->unlock_table($table) if $this->{SQL}{LOCK_TABLE} ; }; $this->_undef_sth ; return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ; return 1 ; } ########## # DELETE # ########## sub delete { my $this = shift ; my ($table , $where) = @_ ; $table = _format_table_name($table) ; if (! $table) { $this->Error('Invalid table!') ;} $where = &HDB::Parser::Parse_Where($where,$this) ; $this->{sql} = "DELETE FROM $table $where" ; eval { $this->lock_table($table) if $this->{SQL}{LOCK_TABLE} ; $this->dbh->do( $this->{sql} ) ; $this->unlock_table($table) if $this->{SQL}{LOCK_TABLE} ; }; return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ; return 1 ; } ########## # CREATE # ########## sub create { my $this = shift ; my ($table , @cols) = @_ ; $table = _format_table_name($table) ; if ($#_ == 1) { @cols = HDB::CORE::parse_ref($_[1]) ;} if (! $table) { $this->Error('Invalid table!') ;} if (! @cols) { $this->Error('Cols not paste!') ;} my %tables = map { ("\L$_\E") => 1 } ($this->tables) ; if ( $tables{"\L$table\E"} ) { return ;} my (%cols,@order) ; for (my $i = 0 ; $i <= $#cols ; $i+=1) { my $name = $cols[$i] ; my $type ; if (ref($name)) { $name = HDB::CORE::parse_ref($name) ; $type = 'DEFAULT' ; } else { $type = $cols[$i+1] ; $i++ ;} my $is_primary ; if ($name =~ /^\s\/) { $name =~ s/^\s\\s//gs ; $is_primary = 1 ;} $name =~ s/^\s+//gs ; $name =~ s/\s+$//gs ; $type = $this->get_type( $type , $name ) ; if ($is_primary) { $type = $this->Set_PRIMARYKEY($type) ;} push(@order , $name) ; $cols{$name} = $type ; } if (ref($_[1]) eq 'HASH') { @order = sort @order ;} if (! $cols{id}) { push(@order , 'id') ; $cols{id} = $this->AUTOINCREMENT() ; if ($cols{id} !~ /PRIMARY[\s_-]KEY/si) { $cols{id} .= ' PRIMARY KEY' ;} } $this->{sql} = "CREATE TABLE $table (" ; my $c ; foreach my $order_i ( @order ) { if (++$c > 1) { $this->{sql} .= " , " ;} $this->{sql} .= "$order_i $cols{$order_i}" ; } $this->{sql} .= ")" ; eval { $this->dbh->do( $this->{sql} ) }; return $this->Error("SQL error: $this->{sql}\nERROR MSG:\n$@") if $@ ; $this->ON_CREATE($table,\%cols,\@order) if $this->can('ON_CREATE') ; return 1 ; } ####### # CMD # ####### sub cmd { my $this = shift ; $this->{sql} = $_[0] ; my $return = $_[1] ; $this->_undef_sth ; eval{ $this->{sth} = $this->dbh->prepare( $this->{sql} ) ; $this->{sth}->execute ; }; return $this->Error("SQL error: $this->{sql}") if $@ ; return $this->Return( $return ) ; } ######### # NAMES # ######### sub names { my $this = shift ; my ( $table ) = @_ ; $table = _format_table_name($table) ; if (! $table) { return $this->Error('Invalid table!') ;} elsif ( $this->{CACHE}{names}{$table} ) { return @{ $this->{CACHE}{names}{$table} } ;} if ( $this->{SQL}{SHOW} ) { $this->{sql} = "SHOW COLUMNS FROM $table" ;} elsif ( $this->{SQL}{LIMIT} ) { $this->{sql} = "SELECT * FROM $table LIMIT 1" ;} else { $this->{sql} = "SELECT * FROM $table" ;} $this->_undef_sth ; eval{ $this->{sth} = $this->dbh->prepare( $this->{sql} ) ; $this->{sth}->execute ; }; return $this->Error("SQL error: $this->{sql}") if $@ ; my @names ; if ( $this->{SQL}{SHOW} ) { while (my $ref = $this->{sth}->fetchrow_arrayref) { push(@names , @$ref[0]) ;} } else { ## substr() to make a copy of the value and avoid DBI bug! eval { @names = map { substr($_ , 0) } @{ $this->{sth}->{'NAME'} } }; #eval { @names = @{ $this->{sth}->{'NAME'} } }; } $this->_undef_sth ; return () if !@names ; if ( $this->{cache} ) { $this->{CACHE}{names}{$table} = \@names ; } return @names ; } ########## # TABLES # ########## sub tables { my $this = shift ; my @tables = map { $_ =~ s/.\.//; $_ =~ s/(['"`])(.)\1/$2/gs; ## some DB return quoted. $_ } $this->dbh->tables() ; return( sort @tables ) ; } ############### # TABLES_HASH # ############### sub tables_hash { return map { $_ => 1 } $_[0]->tables ; } ################ # TABLE_EXISTS # ################ sub table_exists { my %tables = $_[0]->tables ; return 1 if $tables{$_[1]} ; return ; } ################# # TABLE_COLUMNS # ################# sub table_columns { my $this = shift ; my ( $table ) = @_ ; if (! $table) { $this->Error('Invalid table!') ; return ;} return $this->dbh->table_info($table) ; } ######## # DROP # ######## sub drop { my $this = shift ; my ( $table ) = @_ ; $table = _format_table_name($table) ; if (! $table) { $this->Error('Invalid table!') ; return ;} my %tables = map { ("\L$_\E") => 1 } ($this->tables) ; if (! $tables{"\L$table\E"} ) { return ;} $this->flush_table_cache($table) ; eval{ $this->dbh->do("DROP TABLE $table") }; return $this->Error("DROP ERROR: table $table") if $@ ; $this->ON_DROP($table) if $this->can('ON_DROP') ; return 1 ; } ############## # DUMP_TABLE # ############## sub dump_table { my $this = shift ; my ( $table ) = @_ ; $table = _format_table_name($table) ; if (!$table) { $this->Error('Invalid table!') ; return ;} my $dump ; $dump .= "TABLE $table:\n\n" ; my %cols = $this->table_columns($table) ; my @cols = $this->names($table) ; foreach my $Key (@cols) { $dump .= " $Key = $cols{$Key}\n" ; } $dump .= "\nROWS:\n\n" ; my @sel = $this->select( $table , '@$' ) ; foreach my $sel_i ( @sel ) { $dump .= "$sel_i\n" ; } return $dump ; } ############### # FLUSH_CACHE # ############### sub flush_cache { if ( !$_[0]->{CACHE} ) { return ;} my @sth = $_[0]->_get_cache_sth ; delete $_[0]->{CACHE} ; foreach my $sth_i ( @sth ) { $sth_i->finish if $sth_i ;} return 1 ; } ##################### # FLUSH_TABLE_CACHE # ##################### sub flush_table_cache { my $this = shift ; my ( $table ) = @_ ; $table = _format_table_name($table) ; if ( !$this->{CACHE} ) { return ;} my @sth = $this->_get_cache_table_sth($table) ; delete $this->{CACHE}{names}{$table} ; delete $this->{CACHE}{insert}{$table} ; delete $this->{CACHE}{update}{$table} ; foreach my $sth_i ( @sth ) { $sth_i->finish if $sth_i ;} return 1 ; } ###################### # _FORMAT_TABLE_NAME # ###################### sub _format_table_name { my ( $table ) = @_ ; $table =~ s/(?:\.\|::)/_/gs ; $table =~ s/[^\w\.]//gs ; return $table ; } ####################### # _FORMAT_COLUMN_NAME # ####################### sub _format_column_name { my ( $col ) = @_ ; $col =~ s/(?:\.\|::)/_/gs ; $col =~ s/[^\w\.]//gs ; return $col ; } ################## # _GET_CACHE_STH # ################## sub _get_cache_sth { my $cache = $_[0]->{CACHE} ; my @types = qw(insert update) ; my @sth ; foreach my $types_i ( @types ) { foreach my $Key ( keys %{$$cache{$types_i}} ) { push(@sth , $$cache{$types_i}{$Key}{sth} ) ; } } return @sth ; } ######################## # _GET_CACHE_TABLE_STH # ######################## sub _get_cache_table_sth { my $cache = $_[0]->{CACHE} ; my $table = $_[1] ; my @types = qw(insert update) ; my @sth ; foreach my $types_i ( @types ) { push(@sth , $$cache{$types_i}{$table}{sth} ) ; } return @sth ; } ############## # _UNDEF_STH # ############## sub _undef_sth { if ( $_[0]->{sth} ) { $_[0]->{sth}->finish ; $_[0]->{sth} = undef ; } } ########## # RETURN # ########## sub Return { my $this = shift ; my ( $return ) = @_ ; my $ret_names ; $return =~ s/\s//gs ; if ($return =~ /^(?:n\|c)/si ) { $ret_names = 1 ; $return =~ s/[^\$\@\%<>]//gs ; } if ($return !~ /^(?:\$?[\$\@\%]{1,2}\|<[\$\@\%]>)$/ ) { $return = '$' ;} $return =~ s/^\$\$\%$/\$\$\@/ ; $return =~ s/^\%\%$/\$\%/ ; my $sth = $_[1] \|\| $this->{sth} ; return undef if !$sth ; if ($return =~ /<\s([\$\@\%])\s>\s$/) { my $type = $1 ; local(HANDLE); tie(HANDLE, 'HDB::CMDS::TieHandle',$sth,$type) ; return( \HANDLE ) ; } my $ret_type ; if ($return =~ /\@$/) { $ret_type = 1 ;} elsif ($return =~ /\%$/) { $ret_type = 2 ;} my @names ; eval{ my $names = $sth->{'NAME'} ; @names = @{$names} ; }; if (! @names) { $this->_undef_sth ; return undef ;} my @rows ; while (my $ref = $sth->fetchrow_arrayref) { foreach my $ref_i ( @$ref ) { &HDB::Parser::unfilter_null_bytes($ref_i) ; if ( &HDB::Encode::Is_Packed_HASH($ref_i) ) { $ref_i = &HDB::Encode::UnPack_HASH($ref_i) ;} elsif ( &HDB::Encode::Is_Packed_ARRAY($ref_i) ) { $ref_i = &HDB::Encode::UnPack_ARRAY($ref_i) ;} } if ($ret_type == 1) { push(@rows , [@$ref]) ;} elsif ($ret_type == 2) { my %hash ; for my $i (0..$#names) { $hash{ $names[$i] } = $$ref[$i] ;} push(@rows , \%hash) ; } else { push(@rows , join("::" , @$ref ) ) ;} } $this->_undef_sth ; my @ret_names ; if ($ret_names) { @ret_names = \@names ;} if ($return =~ /^[\@\%\$]$/) { if (wantarray) { return( @ret_names , @rows ) ;} else { return( $rows[0] ) ;} } elsif ($return =~ /^\$\$$/) { return( @ret_names , $rows[0] ) ;} elsif ($return =~ /^\$\@$/) { return( @ret_names , @{ $rows[0] } ) ;} elsif ($return =~ /^\$\%$/) { return( @ret_names , %{ $rows[0] } ) ;} elsif ($return =~ /^\$\$\@$/) { if ( ref( @{$rows[0]}[0] ) eq 'HASH' ) { return( @ret_names , %{@{$rows[0]}[0]} ) ;} elsif ( ref( @{$rows[0]}[0] ) eq 'ARRAY' ) { return( @ret_names , @{@{$rows[0]}[0]} ) ;} else { return( @ret_names , @{ $rows[0] } ) ;} } elsif ($return =~ /^\@[\@\%\$]$/) { return( @ret_names , @rows ) ;} } # $ # @ # % # @@ # @% # %% ############ # GET_TYPE # ############ sub get_type { my $this = shift ; my ( $type , $name ) = @_ ; $type =~ s/^\s+//gs ; $type =~ s/\s+$//gs ; ## * if ($type =~ /^(?:\\|)$/s) { $type = 'TEXT' ;} ## TEXT if ($type eq 'TEXT' \|\| $type =~ /^(?:TEXT\s)?(\d+\|$\s\d+\s$)$/s) { my $sz = $1 ; $sz =~ s/\D//gs ; $sz = 65535 if $sz eq '' ; if ( !$this->Accept_Type('TEXT') ) { $type = $this->Type_TEXT($sz) ;} else { if ($sz == 0) { $type = "INTEGER" ;} elsif ($sz <= 255) { $type = "VARCHAR($sz)" ;} elsif ($sz <= 65535 ) { $type = 'TEXT' ;} elsif ($sz <= 16777215 ) { $type = 'MEDIUMTEXT' ;} elsif ($sz <= 4294967295 ) { $type = 'LONGTEXT ' ;} if ( !$this->Accept_Type($type) ) { $type = $this->Type_TEXT($sz) ;} } } ## INTEGER if ($type =~ /^(?:INTEGER\|INT)\s(?:$?([\+\-]?\d+\|\w+)$?\|)$/si) { my $sz = $1 ; if ( !$this->Accept_Type('INTEGER') ) { $type = $this->Type_INTEGER($sz) ;} else { if (!$sz) { $type = "INTEGER" ;} elsif ($sz =~ /^(?:t\|tin\|shor)/i) { $type = "TINYINT" ;} elsif ($sz =~ /^(?:s\|sma)/i) { $type = "SMALLINT" ;} elsif ($sz =~ /^(?:m\|med)/i) { $type = "MEDIUMINT" ;} elsif ($sz =~ /^(?:b\|big)/i) { $type = "BIGINT" ;} elsif ($sz =~ /^[\+\-]?\d+$/) { if ($sz >= -127 && $sz <= 127) { $type = "TINYINT" ;} elsif ($sz >= -32768 && $sz <= 32767) { $type = "SMALLINT" ;} elsif ($sz >= -8388608 && $sz <= 8388607) { $type = "MEDIUMINT" ;} elsif ($sz >= -2147483648 && $sz <= 2147483647) { $type = "INTEGER" ;} elsif ($sz < -2147483648 \|\| $sz > 2147483647) { $type = "BIGINT" ;} } if (! $this->Accept_Type($type)) { $type = $this->Type_INTEGER($sz) ;} } } ## FLOAT elsif ($type =~ /^(\s[\+\-]\s(?:FLOATING\|FLOAT\|DOUBLE))\s(?:$(.?)$\|())$/si) { $type = $this->Type_FLOAT($1,$2) ; } ## INT elsif ($type =~ /\w+INT$/si) { if (! $this->Accept_Type($type)) { $type = 'INTEGER' ;} } ## BOOLEAN elsif ($type =~ /^(?:boolean\|boo?l)$/si) { $type = 'BOOLEAN' ;} ## AUTO elsif ($type =~ /^(?:AUTOINCREMENT\|AUTO)$/si) { $type = $this->AUTOINCREMENT() ;} ## DEF elsif ($type =~ /^(?:DEFAULT\|DEF)$/si) { $type = $DEFAULT_COLS{$name} \|\| 'TEXT' ; $type = $this->get_type($type) ; } ## TYPE MASK: if ( $this->{SQL}{TYPES_MASK} && $this->{SQL}{TYPES_MASK}{$type} ) { $type = $this->{SQL}{TYPES_MASK}{$type} ; } return( $type ) ; } ################## # SET_PRIMARYKEY # ################## sub Set_PRIMARYKEY { my $this = shift ; my ( $type ) = @_ ; my $primarykey = $this->PRIMARYKEY() ; my $primarykey_re = $primarykey ; $primarykey_re =~ s/\s+/\\s\+/gs ; if ($type !~ /$primarykey_re/si) { $type .= " $primarykey" ;} return( $type ) ; } ############### # ACCEPT_TYPE # ############### sub Accept_Type { my $this = shift ; my $type = "\L$_[0]\E" ; if (ref($this->{SQL}{TYPES}) eq 'ARRAY') { my %types = map { ("\L$_\E") => 1 } @{ $this->{SQL}{TYPES} } ; $this->{SQL}{TYPES} = \%types ; } if ( $this->{SQL}{TYPES}{$type} \|\| $this->{SQL}{TYPES}{''} ) { return( 1 ) ;} return( undef ) ; } ######################## # HDB::CMDS::TIEHANDLE # ######################## package HDB::CMDS::TieHandle ; sub TIEHANDLE { my $class = shift ; my $this = { sth => $_[0] , type => $_[1] } ; bless($this , $class) ; } sub READLINE { my $this = shift ; my $sth = $this->{sth} ; if ($this->{type} eq "\$") { my $ref = $sth->fetchrow_arrayref ; return if !$ref ; return( join("::" , @$ref ) ) ; } elsif ($this->{type} eq "\@") { my $ref = $sth->fetchrow_arrayref ; return if !$ref ; foreach my $ref_i ( @$ref ) { &HDB::Parser::unfilter_null_bytes($ref_i) ; if ( &HDB::Encode::Is_Packed_HASH($ref_i) ) { $ref_i = &HDB::Encode::UnPack_HASH($ref_i) ;} elsif ( &HDB::Encode::Is_Packed_ARRAY($ref_i) ) { $ref_i = &HDB::Encode::UnPack_ARRAY($ref_i) ;} } return( @$ref ) ; } elsif ($this->{type} eq "\%") { my $ref = $sth->fetchrow_hashref ; return if !$ref ; foreach my $Key ( keys %$ref ) { &HDB::Parser::unfilter_null_bytes($$ref{$Key}) ; if ( &HDB::Encode::Is_Packed_HASH($$ref{$Key}) ) { $$ref{$Key} = &HDB::Encode::UnPack_HASH($$ref{$Key}) ;} elsif ( &HDB::Encode::Is_Packed_ARRAY($$ref{$Key}) ) { $$ref{$Key} = &HDB::Encode::UnPack_ARRAY($$ref{$Key}) ;} } return( %$ref ) ; } return ; } sub DESTROY { } ####### # END # ####### 1; __END__ =head1 NAME HDB::CMDS - Hybrid DataBase Commands =head1 DESCRIPTION This are the commands/methods to access/manage the databases. =head1 select Make a SQL select query. Example: my @sel = $HDB->select('users' , 'name =~ joe' , '@%') ; ## table , where , return ## ... or ... my @sel = $HDB->select('users' , 'name =~ joe' , cols => 'name,user,id' , limit => 1 , '@%') ; ## ... or ... my @sel = $HDB->select( table => 'users' , ## Need to start with 'table' to paste a full HASH of arguments! where => 'name == joe' , col => 'name, user , id' , limit => '1' , sort => 'id' , group => 'name' , cache => '0' , return => '@%' , ) ; B<Arguments:> =over 10 =item TABLE The table name. =item WHERE Where condintion. See the topic 'WHERE' for format. =item COL Columns to return and order, separated by ','. Example: col => 'city' # Return only the column city. col => 'city,state' # Return the column city and state in this order. col => '>ID' # Return the max ID. col => '<ID' # Return the min ID. =item LIMIT Limit of return or/and start of returns. Example: limit => '10' # Make the limit of returns to 10. limit => '10,2' # Make the limit of returns to 10 and the returns will start from 2. limit => '0,2' # Returns will start from 2. =item SORT Column to use for sort (order). If > or < is used in the beggin set the ascending or descending sort. Example: sort => 'ID' # Sort by ID in the ascending order. sort => '>ID' # Sort by ID in the ascending order. sort => '<ID' # Sort by ID in the descending order. =item GROUP Column(s) to group. Example: group => 'city' # Group only the col city group => 'city , state' # Group the col city and state. =item CACHE Turn on/off the cache of sth and col names. =item RETURN The return type. See the topic L</RETURN> for format. =back =head1 insert ( table , data ) Insert data inside a table. You can call it sending the data by column order or hash (by column name): # Cols of table users: name , email , id $HDB->insert( 'users' , 'joe' , 'joe@mail.com' , 1 ); # Or with a hash: $HDB->insert( 'users' , { 'name' => 'joe' , 'email' => 'joe@mail.com' , 'id' => 1 , } ); =head1 update ( table , where , data ) Update a table. The data need to be a HASH or a ref to a HASH: $HDB->update( 'users' , 'user == joe' , { name => 'Joe Tribiany' , email => 'foo@mail.com' , } ); # Or: $HDB->update( 'users' , 'user == joe' , name => 'Joe Tribiany' , email => 'foo@mail.com' ); =head1 delete ( table , where ) Delete entrys of a table: $HDB->delete( 'users' , 'user == joe' ); =head1 create ( table , columns ) Create a new tables. You send the columns in the order that they will be in the table, and the TYPES are based in the size: $HDB->create( 'users' , user => 100 , # A col for strings, with the max size 100. name => 150 , # A col for strings, with the max size 150. more => 4096 , # A col for strings, with the max size 4Kb. more2 => 1048576 # A col for strings, with the max size 1Mb. more3 => '' # A col for strings. age => 'int(200)' , # A col for numbers, with the max number 200. numb => 'float' , # A floating point with normal precision. numb1 => 'double' , # A floating point with big precision. numb2 => 'float(10)' , # A floating point with precision 10. numb3 => '+float(10,4)' , # for floating points. This will be unsigned (only positive values). # 10 is the max digit size (including decimal). # 4 is the precision (number digits after decimal point). adm => bool , # For boolean entrys. ); FLOAT is not enable in any database, and can be changed to INTEGER. The precision and UNSIGNED options are not enabled for all too. Use FLOAT for normal precision, and DOUBLE for big precision for portable way. In MySQL the cols type will be: $HDB->create( 'users' , user => 100 , # VARCHAR(100) name => 150 , # VARCHAR(150) more => 4096 , # TEXT more2 => 1048576 # MEDIUMTEXT more3 => '' # TEXT age => 'int(200)' , # SMALLINT numb => 'float' , # FLOAT numb1 => 'double' , # DOUBLE numb2 => 'float(10)' , # FLOAT(10) numb3 => '+float(10,4)' , # FLOAT(10,4) UNSIGNED adm => bool , # BOOLEAN ); In SQLite the cols type will be: $HDB->create( 'users' , user => 100 , # VARCHAR(100) name => 150 , # VARCHAR(150) more => 4096 , # TEXT more2 => 1048576 # TEXT more3 => '' # TEXT age => 'int(200)' , # INTEGER numb => 'float' , # FLOAT numb1 => 'double' , # FLOAT numb2 => 'float(10)' , # FLOAT numb3 => '+float(10,4)' , # FLOAT adm => bool , # BOOLEAN ); B<** Note that the column ID will be always created and will be AUTOINCREMENT, unless you set the type by your self.> You can use predefined col names (templates) for the columns. This is good if you don't want to think in the size that the type of data can have: $HDB->create( 'users' , user => 100 , ['email'] , # The predefined col name. Same as: email => 50 name => 150 , ); =head1 drop ( table ) Drop (remove) a table: $HDB->drop( 'users' ); =head1 cmd ( SQL , RETURN ) Send a SQL query to the database. The return will be in the format of the argument RETURN: my @sel = $HDB->cmd('select * from users','@%'); =head1 dump_table Return a string with the table dumped. =head1 tables Return an ARRAY with tables of the database. =head1 table_exists ( TABLE ) Return TRUE if TABLE exists. =head1 tables_hash Same as tables(), but return a HASH, with the tables as keys and 1 as values. Good if you want to make: if ($tables{users}) {...} =head1 table_columns Return a HASH with the columns and respective type (based in the DB type). =head1 names Return an ARRAY with the names of the columns in the table, with the respective order. =head1 sql Return the last SQL command sent to the DB. =head1 flush_cache Clean the HDB cache (in the HDB object, not in the database). =head1 flush_table_cache Clean the HDB cache of a table (in the HDB object, not in the database). =head1 get_type Convert the HDB type to the database type: my $db_col_type = $HDB->get_type( 1000 ); ... my $db_col_type = $HDB->get_type( 'int(200)' ); =head1 default_types Return a list of the default types of HDB. =head1 predefined_columns Return a HASH with the predefined columns and sets. =head1 default_mod Return a HASH with the HDB::MOD installed by default in this version. The HASH: keys => full name. values => id for HDB. =head1 RETURN Commands like select has a return argument, that will tell how to format the results and the type of the variable. The return has 2 parts. First, the type of the variable (@\|$): @ >> Will return an array. $ >> Will return the first line of the results (row), or the parsed reference of the 2nd part. ** If the first part is omitted, @ will be used. Second, the format ($\|@\|%): $ >> The rows will have the columns separated by '::', like: joe::joe@mail.com::1 @ >> The cols of each row will be inside an ARRAY. % >> The cols of each row will be inside a HASH. Examples: return => '@$' # Will return an ARRAY, with the cols in each line of the array separated by '::'. return => '@@' # Will return an ARRAY of ARRAYS (with the cols in the SUB-ARRAY). return => '@%' # Will return an ARRAY of HASHES (with the cols in the HASH). return => '$$' # Will return the cols of the first result (row) separated by '::'. (return a sinlge SCALAR) return => '$@' # Will return the cols of the first result (row) inside an ARRAY. (return a sinlge ARRAY) return => '$%' # Will return the cols of the first result (row) inside a HASH. (return a sinlge HASH) return => '$$@' # Special case: Parse the encoded ref of the first col in the first row. See HDB::Encode. return => '$$%' # Same as $$@. return => '<$>' # Special: Parse sth row by row, returning a SCALAR, with the columns separated by '::'. return => '<@>' # Special: Parse sth row by row, returning a ARRAY with the values of the columns. return => '<%>' # Special: Parse sth row by row, returning a HASH of columns and values. return => '$' # Like @$ return => '@' # Like @@ return => '%' # Like @% return => '%%' # Like $% If you want the list of columns returned, put NAMES in the begin of return: return => 'NAMES,@@' # Will return the reference to an ARRAY with the columns names and the ARRAY of ARRAYS. ## USAGE: my ($cols_names , @sel) = $HDB->select('users','NAMES,@%') ; my @cols_names = @$cols_names ; The best way to think in the I<RETURN> type is to think in what variable type will receive the result, and in what type you want the informations inside the result. ## For an ARRAY receiveing and for informations in HASH type: @% my @sel = $HDB->select('users','@%') ; print "$sel[0]{name}\n" ; ## For a SCALAR receiveing and for informations in ARRAY type: $@ my $name = $HDB->select('users', col => 'name' , '$@') ; ## For a HASH receiveing and for informations in HASH type: %% my %user = $HDB->select('users', "id == 1" '%%') ; ## return only 1 row! print "$user{name}\n" ; =head2 RETURN USAGE (Code Examples): my @sel = $HDB->select( table => users , return => '@$' ); foreach my $sel_i ( @sel ) { my @cols = split("::" , $sel_i) ; ... } ########################################################## my @sel = $HDB->select( table => users , return => '@@' ); foreach my $sel_i ( @sel ) { my @cols = @$sel_i ; ... } ########################################################## my @sel = $HDB->select( table => users , return => '@%' ); foreach my $sel_i ( @sel ) { my %cols = %$sel_i ; ... } ########################################################## my ($names,@sel) = $HDB->select( table => users , return => 'NAMES,@%' ); my @names = @$names ; foreach my $sel_i ( @sel ) { my %cols = %$sel_i ; ... } ########################################################## my %hash = $HDB->select( table => users , col => 'encoded' , return => '$$@' ); foreach my $Key ( keys %hash ) { my $Value = $hash{$Key} ; print "$Key = $Value\n" ; } ########################################################## my $hdbhandle = $HDB->select( table => users , return => '<$>' ); while( my $row = <$hdbhandle> ) { my @cols = split("::" , $row) ; ... } ########################################################## my $hdbhandle = $HDB->select( table => users , return => '<@>' ); while( my @cols = <$hdbhandle> ) { ... } ########################################################## my $hdbhandle = $HDB->select( table => users , return => '<%>' ); while( my %cols = <$hdbhandle> ) { foreach my $Key ( keys %cols ) { print "$Key = $cols{$Key}\n" ;} ... } ########################################################## my $sel_row_0 = $HDB->select( table => users , return => '$$' ); my @cols = split("::" , $sel_row_0) ; ########################################################## my @cols = $HDB->select( table => users , return => '$@' ); ## Return ROW 0. ########################################################## my %cols = $HDB->select( table => users , return => '$%' ); ## Return ROW 0. =head1 SEE ALSO L<HDB>, L<HDB::Encode>, L<HDB::sqlite>, L<HDB::mysql>. =head1 AUTHOR Graciliano M. P. <gm@virtuasites.com.br> =head1 COPYRIGHT This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut

| ver. 1.4 | Github | . | PHP 8.3.31 | Generation time: 0 | proxy | phpinfo | Settings