package DBIx::Array;
use strict;
use warnings;
use DBI;

our $VERSION='0.25';
our $PACKAGE=__PACKAGE__;

=head1 NAME

DBIx::Array - This module is a wrapper around DBI with array interfaces

=head1 SYNOPSIS

  use DBIx::Array;
  my $dbx=DBIx::Array->new;
  $dbx->connect($connection, $user, $pass, \%opt); #passed to DBI
  my @array=$dbx->sqlarray($sql, @params);

With a connected database handle

  use DBIx::Array;
  my $dbx=DBIx::Array->new(dbh=>$dbh);

With stored connection information from a File

  use DBIx::Array::Connect;
  my $dbx=DBIx::Array::Connect->new(file=>"my.ini")->connect("mydatabase");

=head1 DESCRIPTION

This module is for people who truly understand SQL and who understand Perl data structures.  If you understand how to modify your SQL to meet your data requirements then this module is for you.  In the example below, only one line of code is needed to generate an entire HTML table.

  print &tablename($dba->sqlarrayarrayname(&sql, 15)), "\n";

  sub tablename {
    use CGI; my $html=CGI->new(""); #you would pass this reference
    return $html->table($html->Tr([map {$html->td($_)} @_]));
  }
   
  sub sql { #Oracle SQL
    return q{SELECT LEVEL AS "Number",
                    TRIM(TO_CHAR(LEVEL, 'rn')) as "Roman Numeral"
               FROM DUAL CONNECT BY LEVEL <= ? ORDER BY LEVEL};
  }

This module is used to connect to both Oracle 10g and 11g using L<DBD::Oracle> on both Linux and Win32, MySQL 4 and 5 using L<DBD::mysql> on Linux, and Microsoft SQL Server using L<DBD::Sybase> on Linux and using L<DBD::ODBC> on Win32 systems in a 24x7 production environment.  The tests are written against L<DBD::CSV> and L<DBD::XBase>.

=head1 USAGE

=head1 CONSTRUCTOR

=head2 new

  my $dbx=DBIx::Array->new();
  $dbx->connect(...); #connect to database, sets and returns dbh

  my $dbx=DBIx::Array->new(dbh=>$dbh); #already have a handle

=cut

sub new {
  my $this=shift;
  my $class=ref($this) || $this;
  my $self={};
  bless $self, $class;
  $self->initialize(@_);
  return $self;
}

=head1 METHODS

=head2 initialize

=cut

sub initialize {
  my $self=shift;
  %$self=@_;
}

=head1 METHODS (Properties)

=head2 name

Sets or returns a user friendly identification string for this database connection

  my $name=$dbx->name;
  my $name=$dbx->name($string);

=cut

sub name {
  my $self=shift;
  $self->{'name'}=shift if @_;
  return $self->{'name'};
}

=head1 METHODS (DBI Wrappers)

=head2 connect

Connects to the database and returns the database handle.

  $dbx->connect($connection, $user, $pass, \%opt);

Pass through to DBI->connect;

Examples: 

  $dbx->connect("DBI:mysql:database=mydb;host=myhost", "user", "pass", {AutoCommit=>1, RaiseError=>1});

  $dbx->connect("DBI:Sybase:server=myhost;datasbase=mydb", "user", "pass", {AutoCommit=>1, RaiseError=>1}); #Microsoft SQL Server API is same as Sybase API

  $dbx->connect("DBI:Oracle:TNSNAME", "user", "pass", {AutoCommit=>1, RaiseError=>1});

=cut

sub connect {
  my $self=shift;
  my $dbh=DBI->connect(@_);
  return $self->dbh($dbh);
}

=head2 disconnect

Calls $dbh->disconnect

  $dbx->disconnect;

Pass through to dbh->disconnect

=cut

sub disconnect {
  my $self=shift;
  return $self->dbh->disconnect
}

=head2 commit

Pass through to dbh->commit

  $dbx->commit;

=cut

sub commit {
  my $self=shift;
  return $self->dbh->commit;
}

=head2 rollback

Pass through to dbh->rollback

  $dbx->rollback;

=cut

sub rollback {
  my $self=shift;
  return $self->dbh->rollback;
}

=head2 AutoCommit

Pass through to  dbh->{'AutoCommit'} or dbh->{'AutoCommit'}=shift;

  $dbx->AutoCommit(1);
  &doSomething if $dbx->AutoCommit;

For transactions that must complete together, I recommend

  { #block to keep local... well... local.
    local $dbx->dbh->{"AutoCommit"}=0;
    $dbx->insert($sql1, @bind1);
    $dbx->update($sql2, @bind2);
    $dbx->insert($sql3, @bind3);
  } #What is AutoCommit now?  Do you care?

If AutoCommit reverts to true at the end of the block then DBI commits.  Else AutoCommit is still false and still not committed.  This allows higher layers to determine commit functionality.

=cut

sub AutoCommit {
  my $self=shift;
  if (@_) {
    $self->dbh->{'AutoCommit'}=shift;
  }
  return $self->dbh->{'AutoCommit'};
}

=head2 RaiseError

Pass through to  dbh->{'RaiseError'} or dbh->{'RaiseError'}=shift;

  $dbx->RaiseError(1);
  &doSomething if $dbx->RaiseError;

  { #local block
    local $dbx->dbh->{"RaiseError"}=0;
    $dbx->insert($sql, @bind); #do not die
  }

=cut

sub RaiseError {
  my $self=shift;
  if (@_) {
    $self->dbh->{'RaiseError'}=shift;
  }
  return $self->dbh->{'RaiseError'};
}

=head2 errstr

Returns $DBI::errstr

  $dbx->errstr;

=cut

sub errstr {$DBI::errstr};

=head2 dbh

Sets or returns the database handle object.

  $dbx->dbh;
  $dbx->dbh($dbh);  #if you already have a connection

=cut

sub dbh {
  my $self=shift;
  if (@_) {
    $self->{'dbh'}=shift;
    $self->{"_prepared"}=undef; #clear cache if we switch handles
  }
  return $self->{'dbh'};
}

=head1 METHODS (Read)

=head2 sqlcursor

Returns the prepared and executed SQL cursor so that you can use the cursor elsewhere.  Every method in this package uses this single method to generate a sqlcursor.

  my $sth=$dbx->sqlcursor($sql,  @param); #binds are ? values are positional
  my $sth=$dbx->sqlcursor($sql, \@param); #binds are ? values are positional
  my $sth=$dbx->sqlcursor($sql, \%param); #binds are :key

Note: In true Perl fashion extra hash binds are ignored.

  my @foo=$dbx->sqlarray("select :foo, :bar from dual",
                         {foo=>"a", bar=>1, baz=>"buz"}); #returns ("a", 1)

  my $one=$dbx->sqlscalar("select ? from dual", ["one"]); #returns "one"

  my $two=$dbx->sqlscalar("select ? from dual", "two");   #returns "two"

Scalar references are passed in and out with a hash bind.

  my $inout=3;
  $dbx->execute("BEGIN :inout := :inout * 2; END;", {inout=>\$inout});
  print "$inout\n";  #$inout is 6

Direct Plug-in for L<SQL::Abstract> but no column alias support.

  my $sabs=SQL::Abstract->new;
  my $sth=$dbx->sqlcursor($sabs->select($table, \@fields, \%where, \@sort));

=cut

sub sqlcursor {
  my $self=shift;
  my $sql=shift;
  my $sth=$self->_prepared->{$sql};
  unless ($sth) {
    $sth=$self->dbh->prepare($sql)     or die($self->errstr);
    #clear cache if over limit
    $self->{"_prepared"}=undef if scalar(keys %{$self->_prepared}) > 16;
    $self->_prepared->{$sql}=$sth;
  }
  if (ref($_[0]) eq "ARRAY") {
    $sth->execute(@{$_[0]})            or die($self->errstr);
  } elsif (ref($_[0]) eq "HASH") {
    foreach my $key (keys %{$_[0]}) {
      next unless $sql=~m/:$key\b/;
      if (ref($_[0]->{$key}) eq "SCALAR") {
        $sth->bind_param_inout(":$key" => $_[0]->{$key}, 255);
      } else {
        $sth->bind_param(":$key" => $_[0]->{$key});
      }
    } 
    $sth->execute                      or die($self->errstr);
  } else {
    $sth->execute(@_)                  or die($self->errstr);
  }
  return $sth;
}

sub _prepared {
  my $self=shift;
  $self->{"_prepared"}={} unless ref($self->{"_prepared"}) eq "HASH";
  return $self->{"_prepared"};
}

=head2 sqlscalar

Returns the SQL result as a scalar.

This works great for selecting one value.

  my $scalar=$dbx->sqlscalar($sql,  @parameters); #returns $
  my $scalar=$dbx->sqlscalar($sql, \@parameters); #returns $
  my $scalar=$dbx->sqlscalar($sql, \%parameters); #returns $

=cut

sub sqlscalar {
  my $self=shift;
  my @data=$self->sqlarray(@_);
  return $data[0];
}

=head2 sqlarray

Returns the SQL result as an array or array reference.

This works great for selecting one column from a table or selecting one row from a table.

  my $array=$dbx->sqlarray($sql,  @parameters); #returns [$,$,$,...]
  my @array=$dbx->sqlarray($sql,  @parameters); #returns ($,$,$,...)
  my $array=$dbx->sqlarray($sql, \@parameters); #returns [$,$,$,...]
  my @array=$dbx->sqlarray($sql, \@parameters); #returns ($,$,$,...)
  my $array=$dbx->sqlarray($sql, \%parameters); #returns [$,$,$,...]
  my @array=$dbx->sqlarray($sql, \%parameters); #returns ($,$,$,...)

=cut

sub sqlarray {
  my $self=shift;
  my $rows=$self->sqlarrayarray(@_);
  my @rows=map {@$_} @$rows;
  return wantarray ? @rows : \@rows;
}

=head2 sqlhash

Returns the first two columns of the SQL result as a hash or hash reference {Key=>Value, Key=>Value, ...}

  my $hash=$dbx->sqlhash($sql,  @parameters); #returns {$=>$, $=>$, ...}
  my %hash=$dbx->sqlhash($sql,  @parameters); #returns ($=>$, $=>$, ...)
  my @hash=$dbx->sqlhash($sql,  @parameters); #this is ordered
  my @keys=grep {!($n++ % 2)} @hash;          #ordered keys

  my $hash=$dbx->sqlhash($sql, \@parameters); #returns {$=>$, $=>$, ...}
  my %hash=$dbx->sqlhash($sql, \@parameters); #returns ($=>$, $=>$, ...)
  my $hash=$dbx->sqlhash($sql, \%parameters); #returns {$=>$, $=>$, ...}
  my %hash=$dbx->sqlhash($sql, \%parameters); #returns ($=>$, $=>$, ...)

=cut

sub sqlhash {
  my $self=shift;
  my $rows=$self->sqlarrayarray(@_);
  my @rows=map {$_->[0], $_->[1]} @$rows;
  return wantarray ? @rows : {@rows};
}

=head2 sqlarrayarray

Returns the SQL result as an array or array ref of array references ([],[],...) or [[],[],...]

  my $array=$dbx->sqlarrayarray($sql,  @parameters); #returns [[$,$,...],[],[],...]
  my @array=$dbx->sqlarrayarray($sql,  @parameters); #returns ([$,$,...],[],[],...)
  my $array=$dbx->sqlarrayarray($sql, \@parameters); #returns [[$,$,...],[],[],...]
  my @array=$dbx->sqlarrayarray($sql, \@parameters); #returns ([$,$,...],[],[],...)
  my $array=$dbx->sqlarrayarray($sql, \%parameters); #returns [[$,$,...],[],[],...]
  my @array=$dbx->sqlarrayarray($sql, \%parameters); #returns ([$,$,...],[],[],...)

=cut

sub sqlarrayarray {
  my $self=shift;
  my $sql=shift;
  return $self->_sqlarrayarray(sql=>$sql, param=>[@_], name=>0);
}

=head2 sqlarrayarrayname

Returns the SQL result as an array or array ref of array references ([],[],...) or [[],[],...] where the first row contains an array reference to the column names

  my $array=$dbx->sqlarrayarrayname($sql,  @parameters); #returns [[$,$,...],[]...]
  my @array=$dbx->sqlarrayarrayname($sql,  @parameters); #returns ([$,$,...],[]...)
  my $array=$dbx->sqlarrayarrayname($sql, \@parameters); #returns [[$,$,...],[]...]
  my @array=$dbx->sqlarrayarrayname($sql, \@parameters); #returns ([$,$,...],[]...)
  my $array=$dbx->sqlarrayarrayname($sql, \%parameters); #returns [[$,$,...],[]...]
  my @array=$dbx->sqlarrayarrayname($sql, \%parameters); #returns ([$,$,...],[]...)

Create an HTML table with L<CGI>

  my $cgi=CGI->new;
  my $html=$cgi->table($cgi->Tr([map {$cgi->td($_)} $dbx->sqlarrayarrayname($sql, @param)]));

=cut

sub sqlarrayarrayname {
  my $self=shift;
  my $sql=shift;
  return $self->_sqlarrayarray(sql=>$sql, param=>[@_], name=>1);
}

# _sqlarrayarray
#
# my $array=$dbx->_sqlarrayarray(sql=>$sql, param=>[ @parameters], name=>1);
# my @array=$dbx->_sqlarrayarray(sql=>$sql, param=>[ @parameters], name=>1);
# my $array=$dbx->_sqlarrayarray(sql=>$sql, param=>[ @parameters], name=>0);
# my @array=$dbx->_sqlarrayarray(sql=>$sql, param=>[ @parameters], name=>0);
#
# my $array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\@parameters], name=>1);
# my @array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\@parameters], name=>1);
# my $array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\@parameters], name=>0);
# my @array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\@parameters], name=>0);
#
# my $array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\%parameters], name=>1);
# my @array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\%parameters], name=>1);
# my $array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\%parameters], name=>0);
# my @array=$dbx->_sqlarrayarray(sql=>$sql, param=>[\%parameters], name=>0);

sub _sqlarrayarray {
  my $self=shift;
  my %data=@_;
  my $sth=$self->sqlcursor($data{'sql'}, @{$data{'param'}}) or die($self->errstr);
  my $name=$sth->{'NAME'}; #DBD::mysql must store this first
  my $row=[];
  my @rows=();
  while ($row=$sth->fetchrow_arrayref()) {
    push @rows, [@$row];
  }
  unshift @rows, $name if $data{'name'};
  $sth->finish;
  return wantarray ? @rows : \@rows;
}

=head2 sqlarrayhash

Returns the SQL result as an array or array ref of hash references ({},{},...) or [{},{},...]

  my $array=$dbx->sqlarrayhash($sql,  @parameters); #returns [{},{},{},...]
  my @array=$dbx->sqlarrayhash($sql,  @parameters); #returns ({},{},{},...)
  my $array=$dbx->sqlarrayhash($sql, \@parameters); #returns [{},{},{},...]
  my @array=$dbx->sqlarrayhash($sql, \@parameters); #returns ({},{},{},...)
  my $array=$dbx->sqlarrayhash($sql, \%parameters); #returns [{},{},{},...]
  my @array=$dbx->sqlarrayhash($sql, \%parameters); #returns ({},{},{},...)

This method is best used to select a list of hashes out of the database to bless directly into a package.

  my $sql=q{SELECT COL1 AS "id", COL2 AS "name" FROM TABLE1};
  my @objects=map {bless $_, MyPackage} $dbx->sqlarrayhash($sql,  @parameters);
  my @objects=map {MyPackage->new(%$_)} $dbx->sqlarrayhash($sql,  @parameters);

The @objects array is now a list of blessed MyPackage objects.

=cut

sub sqlarrayhash {
  my $self=shift;
  my $sql=shift;
  return $self->_sqlarrayhash(sql=>$sql, param=>[@_], name=>0);
}

=head2 sqlarrayhashname

Returns the SQL result as an array or array ref of hash references ([],{},{},...) or [[],{},{},...] where the first row contains an array reference to the column names

  my $array=$dbx->sqlarrayhashname($sql,  @parameters); #returns [[],{},{},...]
  my @array=$dbx->sqlarrayhashname($sql,  @parameters); #returns ([],{},{},...)
  my $array=$dbx->sqlarrayhashname($sql, \@parameters); #returns [[],{},{},...]
  my @array=$dbx->sqlarrayhashname($sql, \@parameters); #returns ([],{},{},...)
  my $array=$dbx->sqlarrayhashname($sql, \%parameters); #returns [[],{},{},...]
  my @array=$dbx->sqlarrayhashname($sql, \%parameters); #returns ([],{},{},...)

=cut

sub sqlarrayhashname {
  my $self=shift;
  my $sql=shift;
  return $self->_sqlarrayhash(sql=>$sql, param=>[@_], name=>1);
}

# _sqlarrayhash
#
# Returns the SQL result as an array or array ref of hash references ({},{},...) or [{},{},...]
#
# my $array=$dbx->_sqlarrayhash(sql=>$sql, param=>\@parameters, name=>1);
# my @array=$dbx->_sqlarrayhash(sql=>$sql, param=>\@parameters, name=>1);
# my $array=$dbx->_sqlarrayhash(sql=>$sql, param=>\@parameters, name=>0);
# my @array=$dbx->_sqlarrayhash(sql=>$sql, param=>\@parameters, name=>0);

sub _sqlarrayhash {
  my $self=shift;
  my %data=@_;
  my $sth=$self->sqlcursor($data{'sql'}, @{$data{'param'}}) or die($self->errstr);
  my $name=$sth->{'NAME'}; #DBD::mysql must store this first
  my $row=[];
  my @rows=();
  while ($row=$sth->fetchrow_hashref()) {
    push @rows, {%$row};
  }
  unshift @rows, $name if $data{'name'};
  $sth->finish;
  return wantarray ? @rows : \@rows;
}

=head2 sqlsort (Oracle Specific?)

Returns the SQL statement with the correct ORDER BY clause given a SQL statement (without an ORDER BY clause) and a signed integer on which column to sort.

  my $sql=$dbx->sqlsort(qq{SELECT 1,'Z' FROM DUAL UNION SELECT 2,'A' FROM DUAL}, -2);

Returns

  SELECT 1,'Z' FROM DUAL UNION SELECT 2,'A' FROM DUAL ORDER BY 2 DESC

=cut 

sub sqlsort {
  my $self=shift;
  my $sql=shift;
  my $sort=shift;
  if (defined($sort) and $sort=int($sort)) {
    my $column=abs($sort);
    my $direction = $sort < 0 ? "DESC" : "ASC";
    return join " ", $sql, sprintf("ORDER BY %u %s", $column, $direction);  
  } else {
    return $sql;
  }
}

=head2 sqlarrayarraynamesort

Returns a sqlarrayarrayname for $sql sorted on column $n where n is an integer ascending for positive, descending for negative, and 0 for no sort.

  my $data=$dbx->sqlarrayarraynamesort($sql, $n,  @parameters);
  my $data=$dbx->sqlarrayarraynamesort($sql, $n, \@parameters);
  my $data=$dbx->sqlarrayarraynamesort($sql, $n, \%parameters);

Note: $sql must not have an "ORDER BY" clause in order for this function to work correctly.

=cut

sub sqlarrayarraynamesort {
  my $self=shift;
  my $sql=shift;
  my $sort=shift;
  return $self->sqlarrayarrayname($self->sqlsort($sql, $sort), @_);
} 

=head1 METHODS (Write)

Remember to commit or use AutoCommit

Note: It appears that some drivers do not support the count of rows.  

=head2 insert

Returns the number of rows inserted by the SQL statement.

  my $rows=$dbx->insert( $sql,   @parameters);
  my $rows=$dbx->insert( $sql,  \@parameters);
  my $rows=$dbx->insert( $sql,  \%parameters);

  my $sabs=SQL::Abstract->new;
  my $rows=$dbx->insert($sabs->insert($table, \%field));

=cut

*insert=\&update;

=head2 update

Returns the number of rows updated by the SQL statement.

  my $rows=$dbx->update( $sql,   @parameters);
  my $rows=$dbx->update( $sql,  \@parameters);
  my $rows=$dbx->update( $sql,  \%parameters);

  my $sabs=SQL::Abstract->new;
  my $rows=$dbx->update($sabs->update($table, \%field, \%where));

=cut

sub update {
  my $self=shift;
  my $sql=shift;
  my $sth=$self->sqlcursor($sql, @_) or die($self->errstr);
  my $rows=$sth->rows;
  $sth->finish;
  return $rows;
}

=head2 delete

Returns the number of rows deleted by the SQL statement.

  my $rows=$dbx->delete( $sql,   @parameters);
  my $rows=$dbx->delete( $sql,  \@parameters);
  my $rows=$dbx->delete( $sql,  \%parameters);

  my $sabs=SQL::Abstract->new;
  my $rows=$dbx->delete($sabs->delete($table, \%where));

Note: Some Oracle clients do not support row counts on delete instead the value appears to be a success code.

=cut

*delete=\&update;

=head2 execute, exec

Executes stored procedures.

  my $out;
  my $rows=$dbx->execute($sql, $in, \$out);            #pass in/out vars as scalar reference
  my $rows=$dbx->execute($sql, [$in, \$out]);
  my $rows=$dbx->execute($sql, {in=>$in, out=>\$out});

Note: Currently update, insert, delete, and execute all point to the same method.  This may change in the future if we need to change the behavior of one method.  So, please use the correct method name for your function.

=cut

*execute=\&update;
*exec=\&update;   #deprecated

=head1 Get Info Methods

=head2 dbms_name

Return the DBMS Name (e.g. Oracle)

=cut

sub dbms_name {shift->dbh->get_info(17)};

=head1 Session Helpers

These methods allow the setting of Oracle session features that are available in the v$session table.  If other databases support these features, please let me know.  But, as it stands, these method are non operational unless SQL_DBMS_NAME is Oracle.

=head2 module

Sets and returns the v$session.module (Oracle) value.

Note: Module is set for you by BDB::Oracle.  However you may set it however you'd like.  It should be set once after connection and left alone.

  $dbx->module("perl@host");      #normally set by DBD::Oracle
  $dbx->module($module, $action); #can set initial action too.
  my $module=$dbx->module();

=cut

sub module {
  my $self=shift;
  return unless $self->dbms_name eq 'Oracle';
  if (@_) {
    my $module=shift;
    my $action=shift;
    $self->execute($self->_set_module_sql, $module, $action);
  }
  if (defined wantarray) {
    return $self->sqlscalar($self->_sys_context_userenv_sql, 'MODULE');
  } else {
    return; #void context no need to hit the database
  }
}

sub _set_module_sql {
  return qq{
            --Script: $0
            --Package: $PACKAGE
            --Method: _set_module_action_sql
            BEGIN
              DBMS_APPLICATION_INFO.set_module(module_name => ?, action_name => ?);
            END;
           };
}

=head2 client_info

Sets and returns the v$session.client_info (Oracle) value.
 
  $dbx->client_info("Running From crontab");
  my $client_info=$dbx->client_info();

You may use this field for anything up to 64 characters!

  $dbx->client_info(join "~", (ver => 4, realm => "ldap", grp =>25)); #tilde is a fairly good separator
  my %client_info=split(/~/, $dbx->client_info());

=cut

sub client_info {
  my $self=shift;
  return unless $self->dbms_name eq 'Oracle';
  if (@_) {
    my $text=shift;
    $self->execute($self->_set_client_info_sql, $text);
  }
  if (defined wantarray) {
    return $self->sqlscalar($self->_sys_context_userenv_sql, 'CLIENT_INFO');
  } else {
    return; #void context no need to hit the database
  }
}

sub _set_client_info_sql {
  return qq{
            --Script: $0
            --Package: $PACKAGE
            --Method: _action_sql
            BEGIN
              DBMS_APPLICATION_INFO.set_client_info(client_info => ?);
            END;
           };
}

=head2 action

Sets and returns the v$session.action (Oracle) value.

  $dbx->action("We are Here");
  my $action=$dbx->action();

Note: This should be updated fairly often. Every loop if it runs for more than 5 seconds and may end up in V$SQL_MONITOR.

=cut

sub action {
  my $self=shift;
  return unless $self->dbms_name eq 'Oracle';
  if (@_) {
    my $text=shift;
    $self->execute($self->_set_action_sql, $text);
  }
  if (defined wantarray) {
    return $self->sqlscalar($self->_sys_context_userenv_sql, 'ACTION');
  } else {
    return; #void context no need to hit the database
  }
}

sub _set_action_sql {
  return qq{
            --Script: $0
            --Package: $PACKAGE
            --Method: _action_sql
            BEGIN
              DBMS_APPLICATION_INFO.set_action(action_name => ?);
            END;
           };
}

=head2 client_identifier

Sets and returns the v$session.client_identifier (Oracle) value.

  $dbx->client_identifier($login);
  my $client_identifier = $dbx->client_identifier();

Note: This should be updated based on the login of the authenticated end user.  I use the client_info->{"realm"} if you have more than one authentication realm.

For auditing add this a to an update trigger

  new.UPDATED_USER = sys_context('USERENV', 'CLIENT_IDENTIFIER');

=cut

sub client_identifier {
  my $self=shift;
  return unless $self->dbms_name eq 'Oracle';
  if (@_) {
    my $text=shift;
    $self->execute($self->_set_client_identifier_sql, $text);
  }
  if (defined wantarray) {
    return $self->sqlscalar($self->_sys_context_userenv_sql, 'CLIENT_IDENTIFIER');
  } else {
    return; #void context no need to hit the database
  }
}

sub _set_client_identifier_sql {
  return qq{
            --Script: $0
            --Package: $PACKAGE
            --Method: _client_identifier_sql
            BEGIN
              DBMS_SESSION.SET_IDENTIFIER(client_id => ?); 
            END;
           };
}

sub _sys_context_userenv_sql {
  return qq{
            --Script: $0
            --Package: $PACKAGE
            SELECT sys_context('USERENV',?)
              FROM SYS.DUAL
           };
}

=head1 TODO

Sort functions may not be portable.

=head1 BUGS

Send email to author and log on RT.

=head1 SUPPORT

DavisNetworks.com supports all Perl applications including this package.

=head1 AUTHOR

  Michael R. Davis
  CPAN ID: MRDVT
  STOP, LLC
  domain=>stopllc,tld=>com,account=>mdavis
  http://www.stopllc.com/

=head1 COPYRIGHT

This program is free software licensed under the...

  The BSD License

The full text of the license can be found in the LICENSE file included with this module.

=head1 SEE ALSO

=head2 The Competition

L<DBIx::DWIW>, L<DBIx::Wrapper>, L<DBIx::Simple>, L<Data::Table::fromSQL>, L<DBIx::Wrapper::VerySimple>

=head2 The Building Blocks

L<DBI>, L<SQL::Abstract>

=cut

1;
