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 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
 223     if ( not $sth = $dbh->prepare( $sql ) )
 224     {
 225             $errstr = $DBI::errstr;
 226
 227             disconnect( $dbh );
 228             die qq(ERROR: $errstr, "SQL PREPARE ERROR" );
 229     }
 230
 231     if ( not $sth->execute )
 232     {
 233             $errstr = $DBI::errstr;
 234
 235             disconnect( $dbh );
 236             die qq(ERROR: $errstr, "SQL EXECUTE ERROR" );
 237     }
 238
 239     if ( $table = $sth->fetchall_arrayref( $out ) )
 240     {
 241             return wantarray ? @{ $table } : $table;
 242     }
 243     else
 244     {
 245             $errstr = $DBI::errstr;
 246
 247             disconnect( $dbh );
 248             die qq(ERROR: $errstr, "DATABASE RETRIEVE ERROR" );
 249     }
 250 }
 251
 252
 253 sub query_hashref_list
 254 {
 255     # Martin A. Hansen, May 2008.
 256
 257     # Executes a SQL query and return the result
 258     # as a list of hashrefs.
 259
 260     my ( $dbh,   # database handle
 261          $sql,   # sql query
 262        ) = @_;
 263
 264     # Returns datastructure.
 265
 266     my $table = $dbh->selectall_arrayref( $sql, { Slice => {} } );
 267
 268     return wantarray ? @{ $table } : $table;
 269 }
 270
 271
 272 sub delete_table
 273 {
 274     my ( $dbh,
 275          $table,
 276          ) = @_;
 277
 278     request( $dbh, "drop table $table" );
 279 }
 280
 281
 282 sub list_tables
 283 {
 284     my ( $dbh,
 285          ) = @_;
 286
 287     my ( @list );
 288
 289     @list = query_array( $dbh, "show tables" );
 290
 291     if ( @list ) {
 292         @list = map { $_->[0] } @list;
 293     } else {
 294         @list = ();
 295     }
 296
 297     return wantarray ? @list : \@list;
 298 }
 299
 300
 301 sub table_exists
 302 {
 303     my ( $dbh,
 304          $name,
 305          ) = @_;
 306
 307     if ( grep /^$name$/, list_tables( $dbh ) ) {
 308         return 1;
 309     } else {
 310         return;
 311     }
 312 }
 313
 314
 315 sub connect
 316 {
 317     # Martin A. Hansen, May 2008.
 318
 319     # Given a database, user and password,
 320     # obtains a database handle if the databse exists.
 321
 322     my ( $database,   # MySQL database
 323          $user,       # MySQL user
 324          $pass,       # MySQL password
 325          ) = @_;
 326
 327     # Returns object.
 328
 329     my ( $dbh );
 330
 331     Maasha::Common::error( qq(Database "$database" does not exist) ) if not database_exists( $database, $user, $pass );
 332
 333     $dbh = DBI->connect(
 334         "dbi:mysql:$database",
 335         $user,
 336         $pass,
 337         {
 338             RaiseError => 0,
 339             PrintError => 0,
 340             AutoCommit => 0,
 341             ShowErrorStatement => 1,
 342         }
 343     );
 344
 345     if ( $dbh ) {
 346         return $dbh;
 347     } else {
 348         Maasha::Common::error( qq($DBI::errstr) );
 349     }
 350 }
 351
 352
 353 sub disconnect
 354 {
 355     my ( $dbh,
 356          ) = @_;
 357
 358     if ( not $dbh->disconnect )
 359     {
 360         die qq(ERROR: $DBI::errstr );
 361     }
 362 }
 363
 364
 365 sub update_field
 366 {
 367     # Martin A. Hansen, April 2003.
 368
 369     # updates the content of a single table cell
 370
 371     my ( $dbh,     # database handle
 372          $table,   # table name
 373          $column,  # column where updating
 374          $old_val, # the old cell content
 375          $new_val, # the new cell content
 376        ) = @_;
 377
 378     my ( $sql, $count, $count_sql );
 379
 380     $count_sql = qq( SELECT $column FROM $table WHERE $column="$old_val"; );
 381
 382     $count = scalar query_array( $dbh, $count_sql );
 383
 384     if ( $count > 1 )
 385     {
 386         warn qq(WARNING: More than one entry found "$count_sql"\n);
 387     }
 388     elsif ( $count == 0 )
 389     {
 390         disconnect( $dbh );
 391         die qq(ERROR: entry not found "$count_sql"\n);
 392     }
 393     else
 394     {
 395         $sql = qq( UPDATE $table SET $column="$new_val" WHERE $column="$old_val"; );
 396         request( $dbh, $sql );
 397     }
 398
 399     return;
 400 }
 401
 402
 403 sub delete_row
 404 {
 405     # Martin A. Hansen, April 2003.
 406
 407     # deletes a record form a table
 408
 409     my ( $dbh,     # database handle
 410          $table,   # table name
 411          $field,   # field e.g. rec no
 412          $pattern, # specific pattern
 413        ) = @_;
 414
 415     my $sql;
 416
 417     $sql = qq(DELETE FROM $table WHERE $field = "$pattern";);
 418
 419     request( $dbh, $sql );
 420
 421     return;
 422 }
 423
 424
 425 sub add_row
 426 {
 427     # Martin A. Hansen, April 2003.
 428
 429     # adds a record to a table;
 430
 431     my ( $dbh,    # database handle
 432          $table,  # table name
 433          $fields, # row to be inserted
 434        ) = @_;
 435
 436     my ( $sql, $field, @fields, $quote_sql );
 437
 438     foreach $field ( @{ $fields } )
 439     {
 440         if ( $field eq "NULL" or $field eq '' ) {
 441             push @fields, "NULL";
 442         } else {
 443             push @fields, $dbh->quote( $field );
 444         }
 445     }
 446
 447     $sql = "INSERT INTO $table VALUES ( " . join( ", ", @fields ) . " );";
 448
 449     request( $dbh, $sql );
 450
 451     return;
 452 }
 453
 454
 455 sub add_column
 456 {
 457     # Martin A. Hansen, April 2003.
 458
 459     # inserts a column in a table
 460
 461     my ( $dbh,    # database handle
 462          $table,  # table name
 463          $column, # name of column
 464          $type,   # variable type
 465          $index,  # enable index
 466        ) = @_;
 467
 468     my $sql;
 469
 470     if ( $index ) {
 471         $sql = "ALTER TABLE $table ADD COLUMN ( $column $type, INDEX $column" . "_index ( $column ) );";
 472     } else {
 473         $sql = "ALTER TABLE $table ADD COLUMN ( $column $type );";
 474     }
 475
 476     request( $dbh, $sql );
 477
 478     return;
 479 }
 480
 481
 482 sub del_column
 483 {
 484     # Martin A. Hansen, April 2003.
 485
 486     # deletes a column from a table
 487
 488     my ( $dbh,    # databse handle
 489          $table,  # table name
 490          $column, # column to be deleted
 491     ) = @_;
 492
 493     my $sql;
 494
 495     $sql = "ALTER TABLE $table DROP COLUMN $column;";
 496
 497     request( $dbh, $sql );
 498
 499     return;
 500 }
 501
 502
 503 sub bulk_load_file
 504 {
 505     # Martin A. Hansen, January 2004.
 506
 507     # loads , seperated file in to sql table
 508
 509     my ( $dbh,       # database handle object
 510          $path,      # filename with path
 511          $table,     # table to load data into
 512          $delimiter, # column delimiter - OPTIONAL
 513        ) = @_;
 514
 515     # returns database handle object
 516
 517     my $sql;
 518
 519     $delimiter ||= "\t";
 520
 521     $sql = qq( LOAD DATA LOCAL INFILE "$path" INTO TABLE $table FIELDS TERMINATED BY '$delimiter' );
 522
 523     request( $dbh, $sql );
 524 }
 525
 526
 527 # >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>><<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<<