code_perl/Maasha/SQL.pm

   1 package Maasha::SQL;
   2
   3 # Copyright (C) 2006 Martin A. Hansen.
   4
   5 # This program is free software; you can redistribute it and/or
   6 # modify it under the terms of the GNU General Public License
   7 # as published by the Free Software Foundation; either version 2
   8 # of the License, or (at your option) any later version.
   9
  10 # This program is distributed in the hope that it will be useful,
  11 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 # GNU General Public License for more details.
  14
  15 # You should have received a copy of the GNU General Public License
  16 # along with this program; if not, write to the Free Software
  17 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
  18
  19 # http://www.gnu.org/copyleft/gpl.html
  20
  21
  22 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>> DESCRIPTION <<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  23
  24
  25 # Routines for manipulation of MySQL via the DBI module.
  26
  27
  28 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  29
  30
  31 use warnings;
  32 use strict;
  33 use warnings;
  34
  35 use DBI;
  36 use Data::Dumper;
  37 use Time::HiRes;
  38 use Maasha::Common;
  39
  40 use vars qw( @ISA @EXPORT );
  41 use Exporter;
  42
  43 @ISA = qw( Exporter );
  44
  45
  46 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<
  47
  48
  49 sub create_database
  50 {
  51     my ( $database,
  52          $user,
  53          $password,
  54        ) = @_;
  55
  56     system( "mysqladmin create $database --user=$user --password=$password" ) == 0 or
  57     die qq(ERROR: Could not create database "$database"!\n);
  58
  59     return;
  60 }
  61
  62
  63 sub delete_database
  64 {
  65     my ( $database,
  66          $user,
  67          $password,
  68        ) = @_;
  69
  70     die qq(ERROR: Protected database: "$database!\n" ) if $database =~/^(mysql|information_schema)$/i;
  71     system( "mysqladmin drop $database --force --user=$user --password=$password > /dev/null 2>&1"  ) == 0 or
  72     die qq(ERROR: Could not drop database "$database"!\n);
  73
  74     return;
  75 }
  76
  77
  78 sub database_exists
  79 {
  80     # Martin A. Hansen, May 2008.
  81
  82     # Checks if a given database exists. Returns 1 if so,
  83     # otherwise 0.
  84
  85     my ( $database,   # MySQL database
  86          $user,       # MySQL username
  87          $pass,       # MySQL password
  88        ) = @_;
  89
  90     # Return boolean.
  91
  92     my ( @databases );
  93
  94     @databases = list_databases( $user, $pass );
  95
  96     if ( grep /^$database$/i, @databases ) {
  97         return 1;
  98     } else {
  99         return 0;
 100     }
 101 }
 102
 103
 104 sub list_databases
 105 {
 106     # Martin A. Hansen, May 2008.
 107
 108     # Returns a list of databases available.
 109
 110     my ( $user,   # MySQL username
 111          $pass,   # MySQL password
 112        ) = @_;
 113
 114     # Returns a list.
 115
 116     my ( @databases );
 117
 118     @databases = Maasha::Common::run_and_return( "mysqlshow", "--user=$user --password=$pass" );
 119
 120     splice @databases, 0, 3;
 121
 122     pop @databases;
 123
 124     map { s/^\|\s+([^\s]+)\s+\|$/$1/ } @databases;
 125
 126     return wantarray ? @databases : \@databases;
 127 }
 128
 129
 130 sub request
 131 {
 132     my ( $dbh,
 133          $sql,
 134        ) = @_;
 135
 136     my ( $sth, $errstr );
 137
 138     if ( not $sth = $dbh->prepare( $sql ) )
 139     {
 140             $errstr = $DBI::errstr;
 141
 142             disconnect( $dbh );
 143             die qq(ERROR: $errstr, "SQL PREPARE ERROR" );
 144     }
 145
 146     if ( not $sth->execute )
 147     {
 148             $errstr = $DBI::errstr;
 149
 150             disconnect( $dbh );
 151             die qq(ERROR: $errstr, "SQL EXECUTE ERROR" );
 152     }
 153
 154     return;
 155 }
 156
 157
 158 sub query_hash
 159 {
 160     # Niels Larsen, April 2003.
 161
 162     # Executes a given sql query and returns the result as a hash
 163     # or hash reference. The keys are set to the values of the given
 164     # key.
 165
 166     my ( $dbh,   # Database handle
 167          $sql,   # SQL string
 168          $key,   # Key string, like "id", "name", ..
 169        ) = @_;
 170
 171     # Returns a hash.
 172
 173     my ( $sth, $hash, $errstr );
 174
 175     if ( not $sth = $dbh->prepare( $sql ) )
 176     {
 177             $errstr = $DBI::errstr;
 178
 179             disconnect( $dbh );
 180             die qq(ERROR: $errstr, "SQL PREPARE ERROR" );
 181     }
 182
 183     if ( not $sth->execute )
 184     {
 185             $errstr = $DBI::errstr;
 186
 187             disconnect( $dbh );
 188             die qq(ERROR: $errstr, "SQL EXECUTE ERROR" );
 189     }
 190
 191     if ( $hash = $sth->fetchall_hashref( $key ) )
 192     {
 193             return wantarray ? %{ $hash } : $hash;
 194     }
 195     else
 196     {
 197             $errstr = $DBI::errstr;
 198
 199             disconnect( $dbh );
 200             die qq(ERROR: $errstr, "DATABASE RETRIEVE ERROR" );
 201     }
 202
 203     return;
 204 }
 205
 206
 207 sub query_array
 208 {
 209     # Niels Larsen, April 2003.
 210
 211     # Executes a given sql query and returns the result as a table
 212     # or table reference.
 213
 214     my ( $dbh,   # Database handle
 215          $sql,   # SQL string
 216          $out,   # Output specification, see DBI documentation.
 217          ) = @_;
 218
 219     # Returns a list.
 220
 221     my ( $sth, $table, $errstr, @status );
 222     if ( not $sth = $dbh->prepare( $sql ) )
 223     {
 224             $errstr = $DBI::errstr;
 225
 226             disconnect( $dbh );
 227             die qq(ERROR: $errstr, "SQL PREPARE ERROR" );
 228     }
 229
 230     if ( not $sth->execute )
 231     {
 232             $errstr = $DBI::errstr;
 233
 234             disconnect( $dbh );
 235             die qq(ERROR: $errstr, "SQL EXECUTE ERROR" );
 236     }
 237
 238     if ( $table = $sth->fetchall_arrayref( $out ) )
 239     {
 240             return wantarray ? @{ $table } : $table;
 241     }
 242     else
 243     {
 244             $errstr = $DBI::errstr;
 245
 246             disconnect( $dbh );
 247             die qq(ERROR: $errstr, "DATABASE RETRIEVE ERROR" );
 248     }
 249 }
 250
 251
 252 sub query_hashref_list
 253 {
 254     # Martin A. Hansen, May 2008.
 255
 256     # Executes a SQL query and return the result
 257     # as a list of hashrefs.
 258
 259     my ( $dbh,   # database handle
 260          $sql,   # sql query
 261        ) = @_;
 262
 263     # Returns datastructure.
 264
 265     my $table = $dbh->selectall_arrayref( $sql, { Slice => {} } );
 266
 267     return wantarray ? @{ $table } : $table;
 268 }
 269
 270
 271 sub delete_table
 272 {
 273     my ( $dbh,
 274          $table,
 275          ) = @_;
 276
 277     request( $dbh, "drop table $table" );
 278 }
 279
 280
 281 sub list_tables
 282 {
 283     my ( $dbh,
 284          ) = @_;
 285
 286     my ( @list );
 287
 288     @list = query_array( $dbh, "show tables" );
 289
 290     if ( @list ) {
 291         @list = map { $_->[0] } @list;
 292     } else {
 293         @list = ();
 294     }
 295
 296     return wantarray ? @list : \@list;
 297 }
 298
 299
 300 sub table_exists
 301 {
 302     my ( $dbh,
 303          $name,
 304          ) = @_;
 305
 306     if ( grep /^$name$/, list_tables( $dbh ) ) {
 307         return 1;
 308     } else {
 309         return;
 310     }
 311 }
 312
 313
 314 sub connect
 315 {
 316     # Martin A. Hansen, May 2008.
 317
 318     # Given a database, user and password,
 319     # obtains a database handle if the databse exists.
 320
 321     my ( $database,   # MySQL database
 322          $user,       # MySQL user
 323          $pass,       # MySQL password
 324          ) = @_;
 325
 326     # Returns object.
 327
 328     my ( $dbh );
 329
 330     Maasha::Common::error( qq(Database "$database" does not exist) ) if not database_exists( $database, $user, $pass );
 331
 332     $dbh = DBI->connect(
 333         "dbi:mysql:$database",
 334         $user,
 335         $pass,
 336         {
 337             RaiseError => 0,
 338             PrintError => 0,
 339             AutoCommit => 0,
 340             ShowErrorStatement => 1,
 341         }
 342     );
 343
 344     if ( $dbh ) {
 345         return $dbh;
 346     } else {
 347         Maasha::Common::error( qq($DBI::errstr) );
 348     }
 349 }
 350
 351
 352 sub disconnect
 353 {
 354     my ( $dbh,
 355          ) = @_;
 356
 357     if ( not $dbh->disconnect )
 358     {
 359         die qq(ERROR: $DBI::errstr );
 360     }
 361 }
 362
 363
 364 sub update_field
 365 {
 366     # Martin A. Hansen, April 2003.
 367
 368     # updates the content of a single table cell
 369
 370     my ( $dbh,     # database handle
 371          $table,   # table name
 372          $column,  # column where updating
 373          $old_val, # the old cell content
 374          $new_val, # the new cell content
 375        ) = @_;
 376
 377     my ( $sql, $count, $count_sql );
 378
 379     $count_sql = qq( SELECT $column FROM $table WHERE $column="$old_val"; );
 380
 381     $count = scalar query_array( $dbh, $count_sql );
 382
 383     if ( $count > 1 )
 384     {
 385         warn qq(WARNING: More than one entry found "$count_sql"\n);
 386     }
 387     elsif ( $count == 0 )
 388     {
 389         disconnect( $dbh );
 390         die qq(ERROR: entry not found "$count_sql"\n);
 391     }
 392     else
 393     {
 394         $sql = qq( UPDATE $table SET $column="$new_val" WHERE $column="$old_val"; );
 395         request( $dbh, $sql );
 396     }
 397
 398     return;
 399 }
 400
 401
 402 sub delete_row
 403 {
 404     # Martin A. Hansen, April 2003.
 405
 406     # deletes a record form a table
 407
 408     my ( $dbh,     # database handle
 409          $table,   # table name
 410          $field,   # field e.g. rec no
 411          $pattern, # specific pattern
 412        ) = @_;
 413
 414     my $sql;
 415
 416     $sql = qq(DELETE FROM $table WHERE $field = "$pattern";);
 417
 418     request( $dbh, $sql );
 419
 420     return;
 421 }
 422
 423
 424 sub add_row
 425 {
 426     # Martin A. Hansen, April 2003.
 427
 428     # adds a record to a table;
 429
 430     my ( $dbh,    # database handle
 431          $table,  # table name
 432          $fields, # row to be inserted
 433        ) = @_;
 434
 435     my ( $sql, $field, @fields, $quote_sql );
 436
 437     foreach $field ( @{ $fields } )
 438     {
 439         if ( $field eq "NULL" or $field eq '' ) {
 440             push @fields, "NULL";
 441         } else {
 442             push @fields, $dbh->quote( $field );
 443         }
 444     }
 445
 446     $sql = "INSERT INTO $table VALUES ( " . join( ", ", @fields ) . " );";
 447
 448     request( $dbh, $sql );
 449
 450     return;
 451 }
 452
 453
 454 sub add_column
 455 {
 456     # Martin A. Hansen, April 2003.
 457
 458     # inserts a column in a table
 459
 460     my ( $dbh,    # database handle
 461          $table,  # table name
 462          $column, # name of column
 463          $type,   # variable type
 464          $index,  # enable index
 465        ) = @_;
 466
 467     my $sql;
 468
 469     if ( $index ) {
 470         $sql = "ALTER TABLE $table ADD COLUMN ( $column $type, INDEX $column" . "_index ( $column ) );";
 471     } else {
 472         $sql = "ALTER TABLE $table ADD COLUMN ( $column $type );";
 473     }
 474
 475     request( $dbh, $sql );
 476
 477     return;
 478 }
 479
 480
 481 sub del_column
 482 {
 483     # Martin A. Hansen, April 2003.
 484
 485     # deletes a column from a table
 486
 487     my ( $dbh,    # databse handle
 488          $table,  # table name
 489          $column, # column to be deleted
 490     ) = @_;
 491
 492     my $sql;
 493
 494     $sql = "ALTER TABLE $table DROP COLUMN $column;";
 495
 496     request( $dbh, $sql );
 497
 498     return;
 499 }
 500
 501
 502 sub bulk_load_file
 503 {
 504     # Martin A. Hansen, January 2004.
 505
 506     # loads , seperated file in to sql table
 507
 508     my ( $dbh,       # database handle object
 509          $path,      # filename with path
 510          $table,     # table to load data into
 511          $delimiter, # column delimiter - OPTIONAL
 512        ) = @_;
 513
 514     # returns database handle object
 515
 516     my $sql;
 517
 518     $delimiter ||= "\t";
 519
 520     $sql = qq( LOAD DATA LOCAL INFILE "$path" INTO TABLE $table FIELDS TERMINATED BY '$delimiter' );
 521
 522     request( $dbh, $sql );
 523 }
 524
 525
 526 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<