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