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
  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 database_exists
  64 {
  65     # Martin A. Hansen, May 2008.
  66
  67     # Checks if a given database exists. Returns 1 if so,
  68     # otherwise 0.
  69
  70     my ( $database,   # MySQL database
  71          $user,       # MySQL username
  72          $pass,       # MySQL password
  73        ) = @_;
  74
  75     # Return boolean.
  76
  77     my ( @databases );
  78
  79     @databases = list_databases( $user, $pass );
  80
  81     if ( grep /^$database$/i, @databases ) {
  82         return 1;
  83     } else {
  84         return 0;
  85     }
  86 }
  87
  88
  89 sub list_databases
  90 {
  91     # Martin A. Hansen, May 2008.
  92
  93     # Returns a list of databases available.
  94
  95     my ( $user,   # MySQL username
  96          $pass,   # MySQL password
  97        ) = @_;
  98
  99     # Returns a list.
 100
 101     my ( @databases );
 102
 103     @databases = Maasha::Common::run_and_return( "mysqlshow", "--user=$user --password=$pass" );
 104
 105     splice @databases, 0, 3;
 106
 107     pop @databases;
 108
 109     map { s/^\|\s+([^\s]+)\s+\|$/$1/ } @databases;
 110
 111     return wantarray ? @databases : \@databases;
 112 }
 113
 114
 115 sub request
 116 {
 117     my ( $dbh,
 118          $sql,
 119        ) = @_;
 120
 121     my ( $sth, $errstr );
 122
 123     if ( not $sth = $dbh->prepare( $sql ) )
 124     {
 125             $errstr = $DBI::errstr;
 126
 127             disconnect( $dbh );
 128             die qq(ERROR: $errstr, "SQL PREPARE ERROR" );
 129     }
 130
 131     if ( not $sth->execute )
 132     {
 133             $errstr = $DBI::errstr;
 134
 135             disconnect( $dbh );
 136             die qq(ERROR: $errstr, "SQL EXECUTE ERROR" );
 137     }
 138
 139     return;
 140 }
 141
 142
 143 sub query_hash
 144 {
 145     # Niels Larsen, April 2003.
 146
 147     # Executes a given sql query and returns the result as a hash
 148     # or hash reference. The keys are set to the values of the given
 149     # key.
 150
 151     my ( $dbh,   # Database handle
 152          $sql,   # SQL string
 153          $key,   # Key string, like "id", "name", ..
 154        ) = @_;
 155
 156     # Returns a hash.
 157
 158     my ( $sth, $hash, $errstr );
 159
 160     if ( not $sth = $dbh->prepare( $sql ) )
 161     {
 162             $errstr = $DBI::errstr;
 163
 164             disconnect( $dbh );
 165             die qq(ERROR: $errstr, "SQL PREPARE ERROR" );
 166     }
 167
 168     if ( not $sth->execute )
 169     {
 170             $errstr = $DBI::errstr;
 171
 172             disconnect( $dbh );
 173             die qq(ERROR: $errstr, "SQL EXECUTE ERROR" );
 174     }
 175
 176     if ( $hash = $sth->fetchall_hashref( $key ) )
 177     {
 178             return wantarray ? %{ $hash } : $hash;
 179     }
 180     else
 181     {
 182             $errstr = $DBI::errstr;
 183
 184             disconnect( $dbh );
 185             die qq(ERROR: $errstr, "DATABASE RETRIEVE ERROR" );
 186     }
 187
 188     return;
 189 }
 190
 191
 192 sub query_array
 193 {
 194     # Niels Larsen, April 2003.
 195
 196     # Executes a given sql query and returns the result as a table
 197     # or table reference.
 198
 199     my ( $dbh,   # Database handle
 200          $sql,   # SQL string
 201          $out,   # Output specification, see DBI documentation.
 202          ) = @_;
 203
 204     # Returns a list.
 205
 206     my ( $sth, $table, $errstr, @status );
 207
 208     if ( not $sth = $dbh->prepare( $sql ) )
 209     {
 210             $errstr = $DBI::errstr;
 211
 212             disconnect( $dbh );
 213             die qq(ERROR: $errstr, "SQL PREPARE ERROR" );
 214     }
 215
 216     if ( not $sth->execute )
 217     {
 218             $errstr = $DBI::errstr;
 219
 220             disconnect( $dbh );
 221             die qq(ERROR: $errstr, "SQL EXECUTE ERROR" );
 222     }
 223
 224     if ( $table = $sth->fetchall_arrayref( $out ) )
 225     {
 226             return wantarray ? @{ $table } : $table;
 227     }
 228     else
 229     {
 230             $errstr = $DBI::errstr;
 231
 232             disconnect( $dbh );
 233             die qq(ERROR: $errstr, "DATABASE RETRIEVE ERROR" );
 234     }
 235 }
 236
 237
 238 sub query_hashref_list
 239 {
 240     # Martin A. Hansen, May 2008.
 241
 242     # Executes a SQL query and return the result
 243     # as a list of hashrefs.
 244
 245     my ( $dbh,   # database handle
 246          $sql,   # sql query
 247        ) = @_;
 248
 249     # Returns datastructure.
 250
 251     my $table = $dbh->selectall_arrayref( $sql, { Slice => {} } );
 252
 253     return wantarray ? @{ $table } : $table;
 254 }
 255
 256
 257 sub delete_table
 258 {
 259     my ( $dbh,
 260          $table,
 261          ) = @_;
 262
 263     request( $dbh, "drop table $table" );
 264 }
 265
 266
 267 sub list_tables
 268 {
 269     my ( $dbh,
 270          ) = @_;
 271
 272     my ( @list );
 273
 274     @list = query_array( $dbh, "show tables" );
 275
 276     if ( @list ) {
 277         @list = map { $_->[0] } @list;
 278     } else {
 279         @list = ();
 280     }
 281
 282     return wantarray ? @list : \@list;
 283 }
 284
 285
 286 sub table_exists
 287 {
 288     my ( $dbh,
 289          $name,
 290          ) = @_;
 291
 292     if ( grep /^$name$/, list_tables( $dbh ) ) {
 293         return 1;
 294     } else {
 295         return;
 296     }
 297 }
 298
 299
 300 sub connect
 301 {
 302     # Martin A. Hansen, May 2008.
 303
 304     # Given a database, user and password,
 305     # obtains a database handle if the databse exists.
 306
 307     my ( $database,   # MySQL database
 308          $user,       # MySQL user
 309          $pass,       # MySQL password
 310          ) = @_;
 311
 312     # Returns object.
 313
 314     my ( $dbh );
 315
 316     Maasha::Common::error( qq(Database "$database" does not exist) ) if not database_exists( $database, $user, $pass );
 317
 318     $dbh = DBI->connect(
 319         "dbi:mysql:$database",
 320         $user,
 321         $pass,
 322         {
 323             RaiseError => 0,
 324             PrintError => 0,
 325             AutoCommit => 0,
 326             ShowErrorStatement => 1,
 327         }
 328     );
 329
 330     if ( $dbh ) {
 331         return $dbh;
 332     } else {
 333         Maasha::Common::error( qq($DBI::errstr) );
 334     }
 335 }
 336
 337
 338 sub disconnect
 339 {
 340     my ( $dbh,
 341          ) = @_;
 342
 343     if ( not $dbh->disconnect )
 344     {
 345         die qq(ERROR: $DBI::errstr );
 346     }
 347 }
 348
 349
 350 sub update_field
 351 {
 352     # Martin A. Hansen, April 2003.
 353
 354     # updates the content of a single table cell
 355
 356     my ( $dbh,     # database handle
 357          $table,   # table name
 358          $column,  # column where updating
 359          $old_val, # the old cell content
 360          $new_val, # the new cell content
 361        ) = @_;
 362
 363     my ( $sql, $count, $count_sql );
 364
 365     $count_sql = qq( SELECT $column FROM $table WHERE $column="$old_val"; );
 366
 367     $count = scalar query_array( $dbh, $count_sql );
 368
 369     if ( $count > 1 )
 370     {
 371         warn qq(WARNING: More than one entry found "$count_sql"\n);
 372     }
 373     elsif ( $count == 0 )
 374     {
 375         disconnect( $dbh );
 376         die qq(ERROR: entry not found "$count_sql"\n);
 377     }
 378     else
 379     {
 380         $sql = qq( UPDATE $table SET $column="$new_val" WHERE $column="$old_val"; );
 381         request( $dbh, $sql );
 382     }
 383
 384     return;
 385 }
 386
 387
 388 sub delete_row
 389 {
 390     # Martin A. Hansen, April 2003.
 391
 392     # deletes a record form a table
 393
 394     my ( $dbh,     # database handle
 395          $table,   # table name
 396          $field,   # field e.g. rec no
 397          $pattern, # specific pattern
 398        ) = @_;
 399
 400     my $sql;
 401
 402     $sql = qq(DELETE FROM $table WHERE $field = "$pattern";);
 403
 404     request( $dbh, $sql );
 405
 406     return;
 407 }
 408
 409
 410 sub add_row
 411 {
 412     # Martin A. Hansen, April 2003.
 413
 414     # adds a record to a table;
 415
 416     my ( $dbh,    # database handle
 417          $table,  # table name
 418          $fields, # row to be inserted
 419        ) = @_;
 420
 421     my ( $sql, $field, @fields, $quote_sql );
 422
 423     foreach $field ( @{ $fields } )
 424     {
 425         if ( $field eq "NULL" or $field eq '' ) {
 426             push @fields, "NULL";
 427         } else {
 428             push @fields, $dbh->quote( $field );
 429         }
 430     }
 431
 432     $sql = "INSERT INTO $table VALUES ( " . join( ", ", @fields ) . " );";
 433
 434     request( $dbh, $sql );
 435
 436     return;
 437 }
 438
 439
 440 sub add_column
 441 {
 442     # Martin A. Hansen, April 2003.
 443
 444     # inserts a column in a table
 445
 446     my ( $dbh,    # database handle
 447          $table,  # table name
 448          $column, # name of column
 449          $type,   # variable type
 450          $index,  # enable index
 451        ) = @_;
 452
 453     my $sql;
 454
 455     if ( $index ) {
 456         $sql = "ALTER TABLE $table ADD COLUMN ( $column $type, INDEX $column" . "_index ( $column ) );";
 457     } else {
 458         $sql = "ALTER TABLE $table ADD COLUMN ( $column $type );";
 459     }
 460
 461     request( $dbh, $sql );
 462
 463     return;
 464 }
 465
 466
 467 sub del_column
 468 {
 469     # Martin A. Hansen, April 2003.
 470
 471     # deletes a column from a table
 472
 473     my ( $dbh,    # databse handle
 474          $table,  # table name
 475          $column, # column to be deleted
 476     ) = @_;
 477
 478     my $sql;
 479
 480     $sql = "ALTER TABLE $table DROP COLUMN $column;";
 481
 482     request( $dbh, $sql );
 483
 484     return;
 485 }
 486
 487
 488 sub load_sql_file
 489 {
 490     # Martin A. Hansen, January 2004.
 491
 492     # loads , seperated file in to sql table
 493
 494     my ( $dbh,       # database handle object
 495          $path,      # filename with path
 496          $table,     # table to load data into
 497          $delimiter, # column delimiter - OPTIONAL
 498        ) = @_;
 499
 500     # returns database handle object
 501
 502     my $sql;
 503
 504     $delimiter ||= "\t";
 505
 506     $sql = qq( LOAD DATA LOCAL INFILE "$path" INTO TABLE $table FIELDS TERMINATED BY '$delimiter' );
 507
 508     SQL::request( $dbh, $sql );
 509 }
 510
 511
 512 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<