DBD-LDAP-0.20/0000755000175000001440000000000011274677065012360 5ustar turnerjwusersDBD-LDAP-0.20/lib/0000755000175000001440000000000011274677065013126 5ustar turnerjwusersDBD-LDAP-0.20/lib/DBD/0000755000175000001440000000000011274677065013517 5ustar turnerjwusersDBD-LDAP-0.20/lib/DBD/LDAP.pm0000644000175000001440000010411111274675062014566 0ustar turnerjwusers=head1 NAME DBD::LDAP - Perl extension for DBI, providing an SQL/Perl DBI interface to Ldap databases. LDAP stands for the "Lightweight Directory Access Protocol". For more information, see: http://www.ogre.com/ldap/docs.html =head1 AUTHOR This module is Copyright (C) 2000-2009 by Jim Turner Email: turnerjw784 .att. yahoo.com All rights reserved Without Prejudice. You may distribute this module under the same terms as Perl itself. =head1 PREREQUISITES Convert::ANS1 (required by Net::LDAP) Net::LDAP DBI - an LDAP database to connect to. =head1 SYNOPSIS use DBI; $dbh = DBI->connect("DBI:LDAP:ldapdb",'user','password') #USER LOGIN. or die "Cannot connect as user: " . $DBI::errstr; $dbh = DBI->connect("DBI:LDAP:ldapdb") #ANONYMOUS LOGIN (Read-only). or die "Cannot connect as guest (readonly): " . $DBI::errstr; $sth = $dbh->prepare("select * from people where (cn like 'Smith%')") or die "Cannot prepare: " . $dbh->errstr(); $sth->execute() or die "Cannot execute: " . $sth->errstr(); while ((@results) = $sth->fetchrow_array) { print "--------------------------------------------------------\n"; ++$cnt; while (@results) { print "------>".join('|',split(/\0/, shift(@results)))."\n"; } } $sth->finish(); $dbh->disconnect(); =head1 DESCRIPTION DBD::LDAP is a DBI extension module adding an SQL database interface to standard LDAP databases to Perl's database-independent database interface. You will need access to an existing LDAP database or set up your own using an LDAP server, ie. "OpenLDAP", see (http://www.openldap.org). The main advantage of DBD::LDAP is the ability to query LDAP databases via standard SQL queries in leu of cryptic LDAP "filters". LDAP is optimized for quick lookup of existing data, but DBD::LDAP does support entry inserts, updates, and deletes with commit/rollback via the standard SQL commands! LDAP databases are "heirarchical" in structure, whereas other DBD-supported databases are "relational" and there is no LDAP-equivalent to SQL "tables", so DBD::LDAP maps a "table" interface over the LDAP "tree" via a configuration file you must set up. Each "table" is mapped to a common "base DN". For example, consider a typical LDAP database of employees within different departments within a company. You might have a "company" names "Acme" and the root "dn" of "dc=Acme, dc=com" (Acme.com). Below the company level, are divisions, ie. "Widgets", and "Blivets". Each division would have an entry with a "dn" of "ou=Widgets, dc=Acme, dc=com". Employees within each division could have a "dn" of "cn=John Doe, ou=Widgets, dc=Acme, dc=com". With DBD::LDAP, we could create tables to access these different levels, ie. "top", which would have a "DN" of "dc=Acme, dc=com", "WidgetDivision" for "dc=Acme, dc=com". Tables can also be constained by additional attribute specifications (filters), ie constraining by "objectclass", ie. "(objectclass=person)". Then, doing a "select * from WidgetDivision" would display all "person"s with a "dn" containing ""ou=Widgets, dc=Acme, dc=com". =head1 INSTALLATION Installing this module (and the prerequisites from above) is quite simple. You just fetch the archive, extract it with gzip -cd DBD-LDAP-####.tar.gz | tar xf - -or- tar -xzvf DBD-LDAP-####.tar.gz (this is for Unix users, Windows users would prefer WinZip or something similar) and then enter the following: cd DBD-LDAP-#.### perl Makefile.PL make make test If any tests fail, let me know. Otherwise go on with make install Note that you almost definitely need root or administrator permissions. If you don't have them, read the ExtUtils::MakeMaker man page for details on installing in your own directories. =head1 GETTING STARTED: 1) Create a "database", ie. "foo" by creating a text file "foo.ldb". The general format of this file is: ---------------------------------------------------------- hostname[;port][:[root-dn][:[loginrule]]] tablename1:[basedn]:[basefilter]:dnattrs:[visableattrs]:[insertattrs]:[ldap_options] tablename2:[basedn]:[basefilter]:dnattrs:[visableattrs]:[insertattrs]:[ldap_options] ... ---------------------------------------------------------- represents the ldap server host name. represents the server's port, default is 389. if specified, is appended to the end of each tablename's base-dn. if specified, converts single word "usernames" to the appropriate DN, ie: "cn=*," would convert user name "foo" to "cn=foo, " and append the "" onto that. The asterisk is converted to the user-name specified in the "connect" method. If not specified, the username specified in the "connect" method must be a full DN. If the "" is not specified, then the "" would need to be a full DN. tablename - represents the name to be used in SQL statements for a given set of entries which make up a virtual "table". basedn - if specified, is appended to the "" to make up the common base DN for all entries in this table. If "" is not specified, then a full DN must be specified; otherwise, the default is the root-dn. basefilter - if specified, specifies a filter to be used if no "where"- clause is specified in SQL queries. If a "where"-clause is specified, the resulting filter is "and"-ed with this one. The default is "(objectclass=*)". dnattrs - specifies which attributes that values for which are to be appended to the left of the basedn to create DNs for new entries being inserted into the table. visableattrs - if specified, one or more attributes separated by commas which will be sought when the SQL statement does not specify attributes, ie. "select * from tablename". If not specified, the attributes of the first matching entry are returned and used for all entries matching a given query. insertattrs - if specified, one or more attribute/value combinations to be added to any new entry inserted into the table, usually needed for objectclass values. The attributes and values usually correspond to those specivied in the "". The general format is: attr1=value1[|value2...],attr2=value1...,... These attributes and values will be joined with any user-specified values for these attributes. ldap_options - if specified, can be any one or more of the following: ldap_sizelimit - Limit the number of entries fetch by a query to this number (0 = no limit) - default: 0. ldap_timelimit - Limit the search to this number of seconds per query. (0 = no limit) - default: 0. ldap_scope - specify the "scope" of the search. Values are: "base", "one", and "sub", see Net::LDAP docs. Default is "one", meaning the set of records one level below the basedn. "base" means search only the basedn, and "sub" means the union of entries at the "base" level and "one" level below. ldap_inseparator - specify the separator character/string to be used in queries to separate multiple values being specified for a given attribute. Default is "|". ldap_outseparator - specify the separator character/string to be used in queryies to separate multiple values displayed as a result of a query. Default is "|". ldap_firstonly - only display the 1st value fetched for each attribute per entry. This makes "ldap_outseparator" unnecessary. 2) write your script to use DBI, ie: #!/usr/bin/perl use DBI; $dbh = DBI->connect('DBD:LDAP:mydb','me','mypassword') || die "Could not connect (".$DBI->err.':'.$DBI->errstr.")!"; ... #CREATE A TABLE, INSERT SOME RECORDS, HAVE SOME FUN! 3) get your application working. =head1 INSERTING, FETCHING AND MODIFYING DATA 1st, we'll create a database called "ldapdb" with the tables previously mentioned in the example in the DESCRIPTION section: ----------------- file "ldapdb.ldb" ---------------- ldapserver:dc=Acme, dc=com:cn=*, top:::dc WidgetDivision:ou=Widgets, :&(objectclass=top)(objectclass=person):cn:cn,sn,ou,title,telephonenumber,description,objectclass,dn:objectclass=top|person|organizationalPerson:ldap_outseparator => ":" ---------------------------------------------------- The following examples insert some data in a table and fetch it back: First all data in the string: $dbh->do(<do("INSERT INTO WidgetDivision (cn,sn,title,telephonenumber) VALUES (?, ?, ?, ?)", 'John Doe','DoeJ','Manager','123-1111'); END_SQL $dbh->commit(); NOTE: Unlike most other DBD modules which support transactions, changes made do NOT show up until the "commit" function is called, unless "AutoCommit" is set. This is due to the fact that fetches are done from the LDAP server and changes do not take effect there until the Net::LDAP "update" function is called, which is called by "commit". NOTE: The "dn" field is generated automatically from the base "dn" and the dn component fields specified by "dnattrs", If you try to insert a value directly into it, it will be ignored. Also, if not specified, any attribute/value combinations specified in the "insertattrs" option will be added automatically. To retrieve data, you can use the following: my($query) = "SELECT * FROM WidgetDivision WHERE cn like 'John%' ORDER BY cn"; my($sth) = $dbh->prepare($query); $sth->execute(); while (my $entry = $sth->fetchrow_hashref) { print("Found result record: cn = ", $entry->{'cn'}, ", phone = ", $row->{'telephonenumber'}); } $sth->finish(); The SQL "SELECT" statement above (combined with the table information in the "ldapdb.ldb" database file would generate and execute the following equivalent LDAP Search: base => 'ou=Widgets, dc=Acme, dc=com', filter => '(&(&(objectclass=top)(objectclass=person))(cn=John*))', scope => 'one', attrs => 'cn,sn,ou,title,telephonenumber,description,objectclass,dn' See the DBI(3) manpage for details on these methods. See the Data rows are modified with the UPDATE statement: $dbh->do("UPDATE WidgetDivision SET description = 'Outstanding Employee' WHERE cn = 'John Doe'"); NOTE: You can NOT change the "dn" field directly - direct changes will be ignored. You change the "rdn" component of the "dn" field by changing the value of the other field(s) which are appended to the base "dn". Also, if not specified, any attribute/value combinations specified in the "insertattrs" option will be added automatically. Likewise you use the DELETE statement for removing entries: $dbh->do("DELETE FROM WidgetDivision WHERE description = 'Outstanding Employee'"); =head1 METADATA The following attributes are handled by DBI itself and not by DBD::LDAP, thus they should all work as expected. PrintError RaiseError Warn The following DBI attributes are handled by DBD::LDAP: AutoCommit Works NUM_OF_FIELDS Valid after '$sth->execute' NUM_OF_PARAMS Valid after '$sth->prepare' NAME Valid after '$sth->execute'; undef for Non-Select statements. NULLABLE Not really working. Always returns an array ref of one's, as DBD::LDAP always allows NULL (handled as an empty string). Valid after `$sth->execute'. LongReadLen Should work LongTruncOk Should work These attributes and methods are not supported: bind_param_inout CursorName In addition to the DBI attributes, you can use the following dbh attributes. These attributes are read-only after "connect". ldap_dbuser Current database user. ldap_HOME Environment variable specifying a path to search for LDAP databases (*.sdb) files. =head1 DRIVER PRIVATE METHODS DBI->data_sources() The `data_sources' method returns a list of "databases" (.ldb files) found in the current directory and, if specified, the path in the ldap_HOME environment variable. $dbh->tables() This method returns a list of table names specified in the current database. Example: my($dbh) = DBI->connect("DBI:LDAP:mydatabase",'me','mypswd'); my(@list) = $dbh->func('tables'); =head1 OTHER SUPPORTING UTILITIES =head1 RESTRICTIONS DBD::LDAP currently treats all data as strings and all fields as VARCHAR(255). Currently, you must define tables manually in the ".ldb" file using your favorite text editor. I hope to add support for the SQL "Create Table", "Alter Table", and "Drop Table" functions to handle this eventually. =head1 TODO "Create Table", "Alter Table", and "Drop Table" SQL functions for creating, altering, and deleting the tables defined in the ".ldb" file. Some kind of datatype support, ie. numeric (for sorting), CHAR for padding, Long/Blob - for >255 chars per field, etc. =head1 KNOWN BUGS none - (yet). =head1 SEE ALSO Net::LDAP(3), DBI(3), perl(1) =cut require DBI; package DBD::LDAP; use strict; #use vars qw($VERSION @ISA @EXPORT @EXPORT_OK); use vars qw($VERSION $err $errstr $state $sqlstate $drh $i $j $dbcnt); no warnings qw (uninitialized); #require Exporter; #@ISA = qw(Exporter AutoLoader); # Items to export into callers namespace by default. Note: do not export # names by default without a very good reason. Use EXPORT_OK instead. # Do not simply export all your public functions/methods/constants. #@EXPORT = qw( #); $VERSION = '0.20'; # Preloaded methods go here. $err = 0; # holds error code for DBI::err $errstr = ''; # holds error string for DBI::errstr $sqlstate = ''; $drh = undef; # holds driver handle once initialised sub driver{ return $drh if $drh; my($class, $attr) = @_; $class .= "::dr"; # not a 'my' since we use it above to prevent multiple drivers $drh = DBI::_new_drh($class, { 'Name' => 'LDAP', 'Version' => $VERSION, 'Err' => \$DBD::LDAP::err, 'Errstr' => \$DBD::LDAP::errstr, 'State' => \$DBD::LDAP::state, 'Attribution' => 'DBD::LDAP by Shishir Gurdavaram & Jim Turner', }); $drh; } #sub AUTOLOAD { # print "***** AUTOLOAD CALLED! *****\n"; #} 1; package DBD::LDAP::dr; # ====== DRIVER ====== use strict; use vars qw($imp_data_size); $DBD::LDAP::dr::imp_data_size = 0; sub connect { my($drh, $dbname, $dbuser, $dbpswd, $attr, $old_driver, $connect_meth) = @_; my($i, $j); # Avoid warnings for undefined values $dbuser ||= ''; $dbpswd ||= ''; $ENV{LDAP_HOME} ||= ''; unless (open(DBFILE, "<$ENV{LDAP_HOME}/${dbname}.ldb")) { unless (open(DBFILE, "<${dbname}.ldb")) { unless (open(DBFILE, "<$ENV{HOME}/${dbname}.ldb")) { $_ = "No such database ($dbname)!"; DBI::set_err($drh, -1, $_); warn $_ if ($attr->{PrintError}); $_ = '-1:'.$_; return undef; } } } do { $_ = ; chomp; } while (/^\#/o); s#^(\w+)\:\/\/#$1\x02\/\/#o; #PROTECT COLON IN PROTOCOLS (ADDED ON) s#\:(\d+)#\x02$1#go; #PROTECT COLON BEFORE PORT#S (ADDED ON) my ($ldap_hostname, $ldap_root, $ldap_loginrule) = split(/\:/o); $ldap_hostname =~ s/\x02/\:/go; my %ldap_tables; my %ldap_ops; my ($tablename,$basedn,$dnattbs,$inseparator,$outseparator); while () { chomp; next if (/^\#/o); my ($tablename,$basedn,$objclass,$dnattbs,$allattbs,$alwaysinsert,$dbdattbs) = split(/\:/o, $_,7); if ($ldap_root && $basedn !~ /\i/o) { $basedn .= ',' unless ($basedn !~ /\S/o || $basedn =~ /\,\s*$/o); $basedn .= $ldap_root; } $ldap_tables{$tablename} = "$basedn:$objclass:$dnattbs:$allattbs:$alwaysinsert" if ($tablename); $ldap_tables{$tablename} =~ s/\/$ldap_root/i; eval "\$ldap_ops{$tablename} = \{$dbdattbs\};"; } #CREATE A 'BLANK' DBH if ($dbuser && $ldap_loginrule =~ /\*/o) { $ldap_loginrule =~ s/\/$ldap_root/gi; $_ = $dbuser; $dbuser = $ldap_loginrule; $dbuser =~ s/\*/$_/g; } my ($privateattr) = { 'Name' => $ldap_hostname, 'user' => $dbuser, 'dbpswd' => $dbpswd }; my $this = DBI::_new_dbh($drh, { 'Name' => $ldap_hostname, #LDAP URL! 'USER' => $dbuser, #OPTIONAL, '' = ANONYMOUS! 'CURRENT_USER' => $dbuser, } ); unless ($this) { $_ = "Could not get new dbh handle on \"$ldap_hostname\" (".$@.")!"; DBI::set_err($drh, -1, $_); warn $_ if ($attr->{PrintError}); $_ = '-1:'.$_; return undef; } my $ldap_hostport = 389; $ldap_hostport = $1 if ($ldap_hostname =~ s/\;(.*)$//o); my $ldap; my @connectArgs = ($ldap_hostname); push (@connectArgs, 'port', $ldap_hostport) unless ($ldap_hostname =~ /\:\d+$/o); if ($ldap_hostname =~ /^ldaps/o) { unless (defined($attr->{ldaps_capath}) && -d $attr->{ldaps_capath}) { $_ = "Must specify valid path for \"ldaps_capath\" attribute when using ldaps!"; DBI::set_err($drh, -1, $_); warn $_ if ($attr->{PrintError}); $_ = '-1:'.$_; return undef; } push (@connectArgs, 'verify', 'require', 'capath', $attr->{ldaps_capath}); } $ldap = Net::LDAP->new(@connectArgs); unless ($ldap) { $_ = "Could not connect to \"$ldap_hostname\" (".$@.")!"; DBI::set_err($drh, -1, $_); warn $_ if ($attr->{PrintError}); $_ = '-1:'.$_; return undef; } my $mesg; if ($dbpswd) { $mesg = $ldap->bind($dbuser, password => $dbpswd); } elsif ($dbuser) { $mesg = $ldap->bind($dbuser); } else { $mesg = $ldap->bind(); } unless ($mesg) { $_ = "Could not bind - \"$ldap_hostname\" (".$mesg->code().':'.$mesg->error().")!"; DBI::set_err($drh, ($mesg->code()||-1), $_); warn $_ if ($attr->{PrintError}); $_ = $mesg->code().':'.$_; return undef; } if ($mesg->code()) { $_ = "Could not bind to \"$ldap_hostname\" (".$mesg->code().':'.$mesg->error().")!"; DBI::set_err($drh, ($mesg->code()||-1), $_); warn $_ if ($attr->{PrintError}); $_ = $mesg->code().':'.$_; return undef; } #POPULATE INTERNAL HANDLE DATA. ++$DBD::LDAP::dbcnt; my (@commitqueue) = (); $this->STORE('ldap_commitqueue', \@commitqueue); $this->STORE('ldap_ldap', $ldap); $this->STORE('ldap_mesg', $mesg); $this->STORE('ldap_dbname',$dbname); $this->STORE('ldap_dbuser',$dbuser); $this->STORE('ldap_dbpswd',$dbpswd); $this->STORE('ldap_autocommit', 0); $this->STORE('ldap_attrhref', $attr); $this->STORE('ldap_hostname', $ldap_hostname); $this->STORE('ldap_tables', \%ldap_tables); $this->STORE('ldap_tablenames', [keys(%ldap_tables)]); $this->STORE('ldap_ops', \%ldap_ops); $this->STORE('AutoCommit', ($attr->{AutoCommit} || 0)); return $this; } sub data_sources { my ($self) = shift; my (@dsources) = (); my $path; if (defined $ENV{LDAP_HOME}) { $path = "$ENV{LDAP_HOME}/*.ldb"; my $code = "while (my \$i = <$path>)\n"; $code .= <<'END_CODE'; { chomp ($i); push (@dsources,"DBI:LDAP:$1") if ($i =~ m#([^\/\.]+)\.ldb$#); } END_CODE eval $code; $code =~ s/\.ldb([\>\$])/\.LDB$1/g; #HANDLE WINDOWSEY FILENAMES :( eval $code; } $path = '*.ldb'; my $code = "while (my \$i = <$path>)\n"; $code .= <<'END_CODE'; { chomp ($i); push (@dsources,"DBI:LDAP:$1") if ($i =~ m#([^\/\.]+)\.ldb$#); } END_CODE eval $code; $code =~ s/\.ldb([\>\$])/\.LDB$1/g; #HANDLE WINDOWSEY FILENAMES :( eval $code; unless (@dsources) { if (defined $ENV{HOME}) { $path = "$ENV{HOME}/*.ldb"; my $code = "while (my \$i = <$path>)\n"; $code .= <<'END_CODE'; { chomp ($i); push (@dsources,"DBI:LDAP:$1") if ($i =~ m#([^\/\.]+)\.ldb$#); } END_CODE eval $code; $code =~ s/\.ldb([\>\$])/\.LDB$1/g; #HANDLE WINDOWSEY FILENAMES :( eval $code; } } return (@dsources); } sub DESTROY { my($drh) = shift; $drh = undef; return undef; } sub disconnect_all { } sub admin { #I HAVE NO IDEA WHAT THIS DOES! my($drh) = shift; my($command) = shift; my($dbname) = ($command eq 'createdb' || $command eq 'dropdb') ? shift : ''; my($host, $port) = DBD::LDAP->_OdbcParseHost(shift(@_) || ''); my($user) = shift || ''; my($password) = shift || ''; $drh->func(undef, $command, $dbname || '', $host || '', $port || '', $user, $password, '_admin_internal'); } 1; package DBD::LDAP::db; # ====== DATABASE ====== use strict; use Net::LDAP; use JLdap; $DBD::LDAP::db::imp_data_size = 0; use vars qw($imp_data_size); sub prepare { my ($resptr, $sqlstr, $attribs) = @_; local ($_); $sqlstr =~ s/\n/ /go; DBI::set_err($resptr, undef); my $csr = DBI::_new_sth($resptr, { 'Statement' => $sqlstr, }); my $myldapref = new JLdap; $csr->STORE('ldap_ldapdb', $myldapref); $csr->STORE('ldap_fetchcnt', 0); $csr->STORE('ldap_reslinev',''); #NEXT 4 LINES ADDED 20010829! $myldapref->{CaseTableNames} = $resptr->{ldap_attrhref}->{ldap_CaseTableNames}; $myldapref->{ldap_firstonly} = $resptr->{ldap_attrhref}->{ldap_firstonly}; $myldapref->{ldap_inseparator} = $resptr->{ldap_attrhref}->{ldap_inseparator} if ($resptr->{ldap_attrhref}->{ldap_inseparator}); $myldapref->{ldap_outseparator} = $resptr->{ldap_attrhref}->{ldap_outseparator} if ($resptr->{ldap_attrhref}->{ldap_outseparator}); $myldapref->{ldap_appendbase2ins} = $resptr->{ldap_attrhref}->{ldap_appendbase2ins} ? $resptr->{ldap_attrhref}->{ldap_appendbase2ins} : 0; $sqlstr =~ /(into|from|update|table|primary_key_info)\s+(\w+)/gio; my ($tablename) = $2; $csr->STORE('ldap_base', $tablename); #NEXT 5 LINES ADDED 20091105 TO MAKE primary_key_info() FUNCTION WORK: my $tablehash = $resptr->FETCH('ldap_tables'); my $keyfields; (undef, undef, $keyfields) = split(/\:/o, $tablehash->{$tablename}); $myldapref->{'table'} = $tablename; $myldapref->{'key_fields'} = $keyfields; $myldapref->{ldap_dbh} = $resptr; my ($ldap_ops) = $resptr->FETCH('ldap_ops'); foreach my $i (keys %{$ldap_ops->{$tablename}}) { $myldapref->{$i} = $ldap_ops->{$tablename}->{$i} if ($i =~ /^ldap_/o); } foreach my $i (qw(ldap_sizelimit ldap_timelimit ldap_scope deref typesonly callback)) { $myldapref->{$i} = $attribs->{$i} if (defined $attribs->{$i}); } #SET UP STMT. PARAMETERS. unless (defined $tablehash->{$tablename}) { DBI::set_err($resptr, -1, "..Could not prepare query - no such table ($tablename)!"); return undef; } my ($ldap) = $resptr->FETCH('ldap_ldap'); $csr->STORE('ldap_ldap', $ldap); $csr->STORE('ldap_params', []); $sqlstr =~ s/([\'\"])([^$1]*?)\?([^$1]*?$1)/$1$2\x02$3/g; #PROTECT ? IN QUOTES (DATA)! my $num_of_params = ($sqlstr =~ tr/?//); $sqlstr =~ s/\x02/\?/go; $csr->STORE('NUM_OF_PARAMS', $num_of_params); $csr->STORE('ldap_dbh', $resptr); return ($csr); } sub commit { my ($dB) = shift; my ($status, $res); if ($dB->FETCH('AutoCommit')) { if ($dB->FETCH('Warn')) { warn ('Commit ineffective while AutoCommit is ON!'); return 0; } } else { my ($commitqueue) = $dB->FETCH('ldap_commitqueue'); my ($entry, $ldap); while (@{$commitqueue}) { $entry = shift(@{$commitqueue}); $ldap = shift(@{$commitqueue}); $res = ${$entry}->update($$ldap); if ($res->is_error) { DBI::set_err($dB, ($res->code||-1), ("Could not commit - " . $res->code . ': ' . $res->error . '!')); return (undef); } if ($commitqueue->[0] =~ /^dn\=(.+)/o) { my $newdn = $1; shift(@{$commitqueue}); $res = ${$ldap}->moddn($$entry, newrdn => $newdn); if ($res->is_error) { DBI::set_err($dB, ($res->code||-1), ("Could not commit new dn - " . $res->code . ': ' . $res->error . '!')); return (undef); } } } } return 1; } sub rollback { my ($dB) = shift; if ($dB->FETCH('AutoCommit')) { if ($dB->FETCH('AutoCommit') && $dB->FETCH('Warn')) { warn ('Rollback ineffective while AutoCommit is ON!'); return 0; } } else { my ($commitqueue) = $dB->FETCH('ldap_commitqueue'); @{$commitqueue} = (); } return 1; } sub STORE { my($dbh, $attr, $val) = @_; if ($attr eq 'AutoCommit') { # AutoCommit is currently the only standard attribute we have # to consider. $dbh->commit() if ($val == 1 && !$dbh->FETCH('AutoCommit')); $dbh->{AutoCommit} = $val; return 1; } if ($attr =~ /^ldap/o) { # Handle only our private attributes here # Note that we could trigger arbitrary actions. # Ideally we should catch unknown attributes. $dbh->{$attr} = $val; # Yes, we are allowed to do this, return 1; # but only for our private attributes } # Else pass up to DBI to handle for us $dbh->SUPER::STORE($attr, $val); } sub FETCH { my($dbh, $attr) = @_; if ($attr eq 'AutoCommit') { return $dbh->{AutoCommit}; } if ($attr =~ /^ldap_/o) { # Handle only our private attributes here # Note that we could trigger arbitrary actions. return $dbh->{$attr}; # Yes, we are allowed to do this, # but only for our private attributes return $dbh->{$attr}; } # Else pass up to DBI to handle $dbh->SUPER::FETCH($attr); } sub disconnect { my ($db) = shift; my ($ldap) = $db->FETCH('ldap_ldap'); $ldap->unbind() if ($ldap); DBI::set_err($db, undef); return (1); #20000114: MAKE WORK LIKE DBI! } sub do { my ($dB, $sqlstr, $attr, @bind_values) = @_; my ($csr) = $dB->prepare($sqlstr, $attr) or return undef; DBI::set_err($dB, undef); return ($csr->execute(@bind_values) or undef); } sub table_info { my($dbh) = @_; # XXX add qualification my $sth = $dbh->prepare('select tables') or return undef; $sth->execute or return undef; $sth; } sub primary_key_info #ADDED 20091105 TO SUPPORT DBI primary_key/primary_key_info FUNCTIONS! { my ($dbh, $cat, $schema, $tablename) = @_; my $sth = $dbh->prepare("PRIMARY_KEY_INFO $tablename") or return undef; $sth->execute() or return undef; return $sth; } sub type_info_all #ADDED 20010312, BORROWED FROM "Oracle.pm". { my ($dbh) = @_; my $names = { TYPE_NAME => 0, DATA_TYPE => 1, COLUMN_SIZE => 2, LITERAL_PREFIX => 3, LITERAL_SUFFIX => 4, CREATE_PARAMS => 5, NULLABLE => 6, CASE_SENSITIVE => 7, SEARCHABLE => 8, UNSIGNED_ATTRIBUTE => 9, FIXED_PREC_SCALE =>10, AUTO_UNIQUE_VALUE =>11, LOCAL_TYPE_NAME =>12, MINIMUM_SCALE =>13, MAXIMUM_SCALE =>14, } ; # Based on the values from Oracle 8.0.4 ODBC driver my $ti = [ $names, [ 'VARCHAR', 12, 255, '\'', '\'', 'max length', 1, '0', 3, undef, '0', '0', undef, undef, undef ] ]; return $ti; } sub tables #CONVENIENCE METHOD FOR FETCHING LIST OF TABLES IN THE DATABASE. { my($dbh) = @_; # XXX add qualification my ($tables) = $dbh->FETCH('ldap_tablenames'); my (@tables) = @{$tables}; return undef unless ($#tables >= 0); return (@tables); } sub rows { return $DBI::rows; } sub DESTROY { my($drh) = shift; my ($ldap) = $drh->FETCH('ldap_ldap'); if ($drh->FETCH('AutoCommit') != 1) { $drh->rollback(); #ROLL BACK ANYTHING UNCOMMITTED IF AUTOCOMMIT OFF! } $drh->disconnect(); $drh = undef; return undef; } 1; package DBD::LDAP::st; # ====== STATEMENT ====== use strict; my (%typehash) = ( 'LONG RAW' => -4, 'RAW' => -3, 'LONG' => -1, 'CHAR' => 1, 'NUMBER' => 3, 'DOUBLE' => 8, 'DATE' => 11, 'VARCHAR' => 12, 'BOOLEAN' => -7, #ADDED 20000308! ); $DBD::LDAP::st::imp_data_size = 0; use vars qw($imp_data_size *fetch); sub bind_param { my($sth, $pNum, $val, $attr) = @_; my $type = (ref $attr) ? $attr->{TYPE} : $attr; if ($type) { my $dbh = $sth->{Database}; $val = $dbh->quote($sth, $type); } my $params = $sth->FETCH('ldap_params'); $params->[$pNum-1] = $val; ${$sth->{bindvars}}[($pNum-1)] = $val; #FOR LDAP. $sth->STORE('ldap_params', $params); return 1; } sub execute { my ($sth, @bind_values) = @_; #print STDERR "-execute1($sth,".join(',',@bind_values).")\n"; my $params = (@bind_values) ? \@bind_values : $sth->FETCH('ldap_params'); for (my $i=0;$i<=$#{$params};$i++) #ADDED 20000303 FIX QUOTE PROBLEM WITH BINDS. { $params->[$i] =~ s/\'/\'\'/go; } my $numParam = $sth->FETCH('NUM_OF_PARAMS'); if ($params && scalar(@$params) != $numParam) #CHECK FOR RIGHT # PARAMS. { DBI::set_err($sth, (scalar(@$params)-$numParam), "..execute: Wrong number of bind variables (".(scalar(@$params)-$numParam)." too many!)"); return undef; } my $sqlstr = $sth->{'Statement'}; #NEXT 8 LINES ADDED 20010911 TO FIX BUG WHEN QUOTED VALUES CONTAIN "?"s. $sqlstr =~ s/\\\'/\x03/go; #PROTECT ESCAPED DOUBLE-QUOTES. $sqlstr =~ s/\'\'/\x04/go; #PROTECT DOUBLED DOUBLE-QUOTES. $sqlstr =~ s/\'([^\']*?)\'/ my ($str) = $1; $str =~ s|\?|\x02|go; #PROTECT QUESTION-MARKS WITHIN QUOTES. "'$str'"/eg; $sqlstr =~ s/\x04/\'\'/go; #UNPROTECT DOUBLED DOUBLE-QUOTES. $sqlstr =~ s/\x03/\\\'/go; #UNPROTECT ESCAPED DOUBLE-QUOTES. #CONVERT REMAINING QUESTION-MARKS TO BOUND VALUES. for (my $i = 0; $i < $numParam; $i++) { $params->[$i] =~ s/\?/\x02\^2jSpR1tE\x02/gs; #ADDED 20091030 TO FIX BUG WHEN PARAMETER OTHER THAN LAST CONTAINS A "?"! $sqlstr =~ s/\?/"'".$params->[$i]."'"/e; } $sqlstr =~ s/\x02\^2jSpR1tE\x02/\?/gs; #ADDED 20091030! - UNPROTECT PROTECTED "?"s. my ($ldapref) = $sth->FETCH('ldap_ldapdb'); #CALL JLDAP TO DO THE SQL! my (@resv) = $ldapref->sql($sth, $sqlstr); my $saveAT = $@; #print STDERR "-execute4 at=$@\n"; #!!! HANDLE LDAP ERRORS HERE (SEE LDAP.PM)!!! my ($retval) = undef; if ($#resv < 0) #GENERAL ERROR! { DBI::set_err($sth, ($ldapref->{lasterror} || -601), ($ldapref->{lastmsg} || 'Unknown Error!')); $@ ||= $saveAT; return $retval; } elsif ($resv[0]) #NORMAL ACTION IF NON SELECT OR >0 ROWS SELECTED. { $retval = $resv[0]; my $dB = $sth->{Database}; # if ($dB->FETCH('AutoCommit') == 1 && $sth->FETCH('Statement') !~ /^\s*select/i) #CHGD. TO NEXT 20091105: if ($dB->FETCH('AutoCommit') == 1 && $sth->FETCH('Statement') !~ /^\s*(?:select|primary_key_info)/io) { #print STDERR "!!!!!!!!!!!! clearing Autocommit drh=$dB= !!!!!!!!!!!!!\n"; $dB->STORE('AutoCommit',0); #ADDED 20010911 AS PER SPRITE TO MAKE AUTOCOMMIT WORK. $dB->commit(); #ADDED 20010911 AS PER SPRITE TO MAKE AUTOCOMMIT WORK. $dB->STORE('AutoCommit',1); #COMMIT DONE HERE! } } else #SELECT SELECTED ZERO RECORDS. { if ($ldapref->{lasterror}) { DBI::set_err($sth, $ldapref->{lasterror}, $ldapref->{lastmsg}); $@ ||= $saveAT; $retval = undef; } $retval = '0E0'; # $resv[0] = $ldapref->{lastmsg}; # DBI::set_err($sth, ($ldapref->{lasterror} || -402), # ($ldapref->{lastmsg} || 'No matching records found/modified!')); # $retval = '0E0'; } #EVERYTHING WORKED, SO SAVE LDAP RESULT (# ROWS) AND FETCH FIELD INFO. $sth->{'driver_rows'} = $resv[0]; # number of rows $sth->{'ldap_rows'} = $resv[0]; # number of rows #ADDED 20050416 PER PACH BY jmorano #### NOTE #### IF THIS FAILS, IT PROBABLY NEEDS TO BE "ldap_rows"? shift @resv; #REMOVE 1ST COLUMN FROM DATA RETURNED (THE LDAP RESULT). my @l = split(/,/o, $ldapref->{use_fields}); $sth->STORE('NUM_OF_FIELDS',($#l+1)); unless ($ldapref->{TYPE}) { @{$ldapref->{NAME}} = @l; for my $i (0..$#l) { ${$ldapref->{TYPE}}[$i] = $typehash{${$ldapref->{types}}{$l[$i]}} || $typehash{'VARCHAR'}; ${$ldapref->{PRECISION}}[$i] = ${$ldapref->{lengths}}{$l[$i]} || 255; ${$ldapref->{SCALE}}[$i] = ${$ldapref->{scales}}{$l[$i]} || 0; ${$ldapref->{NULLABLE}}[$i] = 1; #${$ldapref->{TYPE}}[$i] = 12; #VARCHAR ##${$ldapref->{TYPE}}[$i] = -1; #VARCHAR #NEXT 4 REPLACED BY 1ST 4 PER REQUEST BY jmorano. ##${$ldapref->{PRECISION}}[$i] = 255; ##${$ldapref->{SCALE}}[$i] = 0; ##${$ldapref->{NULLABLE}}[$i] = 1; } } #TRANSFER LDAP'S FIELD DATA TO DBI. $sth->{'driver_data'} = \@resv; $sth->STORE('ldap_data', \@resv); $sth->STORE('ldap_rows', ($#resv+1)); # number of rows $sth->{'TYPE'} = \@{$ldapref->{TYPE}}; $sth->{'NAME'} = \@{$ldapref->{NAME}}; $sth->{'PRECISION'} = \@{$ldapref->{PRECISION}}; $sth->{'SCALE'} = \@{$ldapref->{SCALE}}; $sth->{'NULLABLE'} = \@{$ldapref->{NULLABLE}}; $sth->STORE('ldap_resv',\@resv); $@ ||= $saveAT; return $retval if ($retval); return '0E0' if (defined $retval); return undef; } sub fetchrow_arrayref { my($sth) = @_; my $data = $sth->FETCH('driver_data'); my $row = shift @$data; return undef if (!$row); my ($longreadlen) = $sth->{Database}->FETCH('LongReadLen'); if ($longreadlen > 0) { if ($sth->FETCH('ChopBlanks')) { for (my $i=0;$i<=$#{$row};$i++) { if (${$sth->{TYPE}}[$i] < 0) #LONG, LONG RAW, etc. { my ($t) = substr($row->[$i],0,$longreadlen); return undef unless (($row->[$i] eq $t) || $sth->{Database}->FETCH('LongTruncOk')); $row->[$i] = $t; } } map { $_ =~ s/\s+$//o; } @$row; } } else { if ($sth->FETCH('ChopBlanks')) { map { $_ =~ s/\s+$//o; } @$row; } } return $sth->_set_fbav($row); } *fetch = \&fetchrow_arrayref; # required alias for fetchrow_arrayref sub rows { my($sth) = @_; $sth->FETCH('driver_rows'); } #### NOTE #### IF THIS FAILS, IT PROBABLY NEEDS TO BE "ldap_rows"? sub STORE { my($dbh, $attr, $val) = @_; if ($attr eq 'AutoCommit') { # AutoCommit is currently the only standard attribute we have # to consider. #if (!$val) { die "Can't disable AutoCommit"; } $dbh->{AutoCommit} = $val; return 1; } if ($attr =~ /^ldap/o) { # Handle only our private attributes here # Note that we could trigger arbitrary actions. # Ideally we should catch unknown attributes. $dbh->{$attr} = $val; # Yes, we are allowed to do this, return 1; # but only for our private attributes } # Else pass up to DBI to handle for us eval {$dbh->SUPER::STORE($attr, $val);}; } sub FETCH { my($dbh, $attr) = @_; if ($attr eq 'AutoCommit') { return $dbh->{AutoCommit}; } if ($attr =~ /^ldap_/o) { # Handle only our private attributes here # Note that we could trigger arbitrary actions. return $dbh->{$attr}; # Yes, we are allowed to do this, # but only for our private attributes return $dbh->{$attr}; } # Else pass up to DBI to handle $dbh->SUPER::FETCH($attr); } 1; package DBD::LDAP; # ====== HAD TO HAVE TO PREVENT MAKE ERROR! ====== 1; __END__ DBD-LDAP-0.20/lib/JLdap.pm0000644000175000001440000010255611274675702014463 0ustar turnerjwusers#!/usr/bin/perl package JLdap; require 5.002; use Net::LDAP::Entry; use vars qw($VERSION); no warnings qw (uninitialized); #use Fcntl; ##++ ## Global Variables. Declare lock constants manually, instead of ## importing them from Fcntl. ## use vars qw ($VERSION); ##-- $JLdap::VERSION = '0.20'; #my $NUMERICTYPES = '^(NUMBER|FLOAT|DOUBLE|INT|INTEGER|NUM)$'; #20000224 #my $STRINGTYPES = '^(VARCHAR|CHAR|VARCHAR|DATE|LONG|BLOB|MEMO)$'; ##++ ## Public Methods and Constructor ##-- sub new { my $class = shift; my $self; $self = { commands => 'select|update|delete|alter|insert|create|drop|primary_key_info', column => '[A-Za-z0-9\~\x80-\xFF][\w\x80-\xFF]+', _select => '[\w\x80-\xFF\*,\s\~]+', path => '[\w\x80-\xFF\-\/\.\:\~\\\\]+', table => '', timestamp => 0, fields => {}, use_fields => '', key_fields => '', order => [], types => {}, lengths => {}, scales => {}, defaults => {}, records => [], errors => {}, lasterror => 0, #JWT: ADDED FOR ERROR-CONTROL lastmsg => '', CaseTableNames => 0, #JWT: 19990991 TABLE-NAME CASE-SENSITIVITY? LongTruncOk => 0, #JWT: 19991104: ERROR OR NOT IF TRUNCATION. RaiseError => 0, #JWT: 20000114: ADDED DBI RAISEERROR HANDLING. silent => 0, ldap_dbh => 0, ldap_sizelimit => 0, #JWT: LIMIT #RECORDS FETCHED, IF SET. ldap_timelimit => 0, #JWT: LIMIT #RECORDS FETCHED, IF SET. ldap_deref => 0, #JWT: LIMIT #RECORDS FETCHED, IF SET. ldap_typesonly => 0, ldap_callback => 0, ldap_scope => 0, ldap_inseparator => '|', ldap_outseparator => '|', ldap_firstonly => 0, ldap_nullsearchvalue => ' ', #ADDED 20040330 TO FOR BACKWARD COMPATABILITY. ldap_appendbase2ins => 0, #ADDED 20060719 FOR BACKWARD COMPAT. - 0.08+ NO LONGER APPENDS BASE TO ALWAYSINSERT PER REQUEST. dirty => 0, #JWT: 20000229: PREVENT NEEDLESS RECOMMITS. tindx => 0 #REPLACES GLOBAL VARIABLE. }; bless $self, $class; for (my $i=0;$i{$_[$i]} = $_[$i+1]; } $self->initialize; return $self; } sub initialize { my $self = shift; $self->define_errors; } sub sql { my ($self, $csr, $query) = @_; my ($command, $status, $base, $fields); #print STDERR "-sql1($command,$status,$base,$fields)"; return wantarray ? () : -514 unless ($query); $self->{lasterror} = 0; $self->{lastmsg} = ''; $query =~ s/\n/ /gso; $query =~ s/^\s*(.*?)\s*$/$1/; $query = 'select tables' if ($query =~ /^show\s+tables$/i); $query = 'select tables' if ($query =~ /^select\s+TABLE_NAME\s+from\s+USER_TABLES$/i); #ORACLE-COMPATABILITY. $command = ''; if ($query =~ /^($self->{commands})/io) { $command = $1; $command =~ tr/A-Z/a-z/; #ADDED 19991202! $status = $self->$command ($csr, $query); if (!defined($status)) #NEXT 5 ADDED PER PATCH REQUEST 20091101: { $self->display_error(-599); return wantarray ? () : -599; } elsif (ref ($status) eq 'ARRAY') #SELECT RETURNED OK (LIST OF RECORDS). { return wantarray ? @$status : $status; } else { if ($status < 0) { #SQL RETURNED AN ERROR! #print STDERR "-sql6 status=$status=\n"; $self->display_error ($status); #return ($status); return wantarray ? () : $status; } else { #SQL RETURNED OK. #print STDERR "-sql7 status=$status= at=$@= cash=$_= bang=$!= query=$?=\n"; return wantarray ? ($status) : $status; } } } else { return wantarray ? () : -514; } } sub select { my ($self, $csr, $query) = @_; my (@ordercols) = (); $regex = $self->{_select}; $path = $self->{path}; my (@rtnvals) = (); my $distinct; $distinct = 1 if ($query =~ s/select\s+distinct(\s+\w|\s*\(|\s+\*)/select $1/i); my ($dbh) = $csr->FETCH('ldap_dbh'); my ($tablehash); if ($query =~ /^select tables$/io) { $tablehash = $dbh->FETCH('ldap_tablenames'); $self->{use_fields} = 'TABLE_NAME'; #ADDED 20000224 FOR DBI! $values_or_error = []; for ($i=0;$i<=$#{$tablehash};$i++) { push (@$values_or_error,[$tablehash->[$i]]); } unshift (@$values_or_error, ($#{$tablehash}+1)); return $values_or_error; } elsif ($query =~ /^select\s+ # Keyword ($regex)\s+ # Columns from\s+ # 'from' ($path)(.*)$/iox) { ($attbs, $table, $extra) = ($1, $2, $3); $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! $self->{file} = $table; if ($extra =~ s/([\s|\)]+)order\s+by\s*(.*)/$1/i) { $orderclause = $2; @ordercols = split(/,/,$orderclause); $descorder = ($ordercols[$#ordercols] =~ s/(\w+\W+)desc(?:end|ending)?$/$1/i); #MODIFIED 20000721 TO ALLOW "desc|descend|descending"! for $i (0..$#ordercols) { $ordercols[$i] =~ s/\s//igo; #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano $ordercols[$i] =~ s/[\(\)]+//igo; } } $tablehash = $dbh->FETCH('ldap_tables'); return (-524) unless ($tablehash->{$table}); my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/o ,$tablehash->{$table}); $attbs = $allattbs if ($allattbs && $attbs =~ s/\*//o); $attbs =~ s/\s//go; $attbs =~ tr/A-Z/a-z/; @{$self->{order}} = split(/,/o, $attbs) unless ($attbs eq '*'); my $fieldnamehash = (); my $attbcnt = 0; foreach my $i (@{$self->{order}}) { $fieldnamehash{$i} = $attbcnt++; } my ($ldap) = $csr->FETCH('ldap_ldap'); $objfilter ||= 'objectclass=*'; $objfilter = "($objfilter)" unless ($objfilter =~ /^\(/o); #print "
-where=$extra=\n"; if ($extra =~ /^\s+where\s*(.+)$/io) { $filter = $self->parse_expression($1); $filter = '('.$filter.')' unless ($filter =~ /^\(/o); $filter = "(&$objfilter$filter)"; } else { $filter = $objfilter; } #print "
-filter =$filter=\n"; my $data; my (@searchops) = ( 'base' => $base, 'filter' => $filter, 'attrs' => [split(/\,/o, $attbs)] ); foreach my $i (qw(ldap_sizelimit ldap_timelimit deref typesonly callback)) { $j = $i; $j =~ s/^ldap_//o; push (@searchops, ($j, $self->{$i})) if ($self->{$i}); } push (@searchops, ('scope', ($self->{ldap_scope} || 'one'))); #print "--- ATTBS =$attbs=\n"; #print "--- SEARCH OPS =".join('|',@searchops)."=\n"; $data = $ldap->search(@searchops) or return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); #print "--- data=$data=\n"; my ($j) = 0; my (@varlist) = (); while (my $entry = $data->shift_entry()) { $dn = $entry->dn(); next unless ($dn =~ /$base$/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano @attributes = $entry->attributes; unless ($attbcnt) { $attbs = join(',',@attributes); $attbcnt = 0; @{$self->{order}} = @attributes; foreach my $i (@{$self->{order}}) { $fieldnamehash{$i} = $attbcnt++; } } $varlist[$j] = []; for (my $i=0;$i<$attbcnt;$i++) { $varlist[$j][$i] = ''; } $i = 0; foreach my $attr (@{$self->{order}}) { # $valuesref = $entry->get($attr); #CHGD. TO NEXT PER PATCH REQUEST 20091101: $valuesref = $entry->get_value($attr, asref => 1); if ($self->{ldap_firstonly} && $self->{ldap_firstonly} <= scalar (@{$valuesref})) { #$varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, $valuesref->[0]); #CHGD. 20010829 TO NEXT. $varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, @{$valuesref}[0..($self->{ldap_firstonly}-1)]); } else { $varlist[$j][$fieldnamehash{$attr}] = join($self->{ldap_outseparator}, @$valuesref) || ''; } unless ($valuesref[0]) { $varlist[$j][$fieldnamehash{dn}] = $dn if ($attr eq 'dn'); } $i++; } ++$j; } $self->{use_fields} = $attbs; if ($distinct) #THIS MAKES "DISTINCT" WORK. { my (%disthash); for (my $i=0;$i<=$#varlist;$i++) { ++$disthash{join("\x02",@{$varlist[$i]})}; } @varlist = (); foreach my $i (keys(%disthash)) { push (@varlist, [split(/\x02/o, $i, -1)]); } } if ($#ordercols >= 0) #SORT 'EM! { my @SV; for (my $i=0;$i<=$#varlist;$i++) { $SV[$i] = ''; foreach my $j (@ordercols) { $SV[$i] .= $varlist[$i][$fieldnamehash{$j}] . "\x01"; } } @sortvector = &sort_elements(\@SV); @sortvector = reverse(@sortvector) if ($descorder); @SV = (); while (@sortvector) { push (@SV, $varlist[shift(@sortvector)]); } @varlist = @SV; @SV = (); } return [($#attributes+1), @varlist]; } else #INVALID SELECT STATEMENT! { return (-503); } } sub sort_elements { my (@elements, $line, @sortlist, @sortedlist, $j, $t, $argcnt, $linedata, $vectorid, @sortvector); my ($lo) = 0; my ($hi) = 0; $lo = shift unless (ref($_[0])); $hi = shift unless (ref($_[0])); if ($lo || $hi) { for ($j=0;$j<=$#{$_[0]};$j++) { $sortvector[$j] = $j; } } $hi ||= $#{$_[0]}; $argcnt = scalar(@_); for (my $i=$lo;$i<=$hi;$i++) { $line = $_[0][$i]; for ($j=1;$j<$argcnt;$j++) { $line .= "\x02" . $_[$j][$i]; } $line .= "\x04".$i; push (@sortlist, $line); } @sortedlist = sort @sortlist; $i = $lo; foreach $line (@sortedlist) { ($linedata,$vectorid) = split(/\x04/o, $line); (@elements) = split(/\x02/o, $linedata); $t = $#elements unless $t; for ($j=$t;$j>=1;$j--) { #push (@{$_[$j]}, $elements[$j]); ${$_[$j]}[$i] = $elements[$j]; } $sortvector[$i] = $vectorid; $elements[0] =~ s/\s+//go; ${$_[0]}[$i] = $elements[$j]; ++$i; } return @sortvector; } sub ldap_error { my ($self,$errcode,$errmsg,$warn) = @_; $err = $errcode || -1; $errdetails = $errmsg; $err = -1 * $err if ($err > 0); return ($err) unless (defined($warn) && $warn); # print "Content-type: text/html\nWindow-target: _parent", "\n\n" # if (defined($warn) && $warn == 1); return ($self->display_error($errcode)); } sub display_error { my ($self, $error) = @_; $other = $@ || $! || 'None'; print STDERR <{silent}); Oops! The following error occurred when processing your request: $self->{errors}->{$error} ($errdetails) Here's some more information to help you: file: $self->{file} $other Error_Message #JWT: ADDED FOR ERROR-CONTROL. $self->{lasterror} = $error; $self->{lastmsg} = "$error:" . $self->{errors}->{$error}; $self->{lastmsg} .= '('.$errdetails.')' if ($errdetails); #20000114 $errdetails = ''; #20000114 die $self->{lastmsg} if ($self->{RaiseError}); #20000114. #return (1); return ($error); } sub commit { my ($self) = @_; my ($status) = 1; my ($dbh) = $self->FETCH('ldap_dbh'); my ($autocommit) = $dbh->FETCH('AutoCommit'); $status = $dbh->commit() unless ($autocommit); $self->{dirty} = 0 if ($status > 0); return undef if ($status <= 0); #ADDED 20000103 return $status; } ##++ ## Private Methods ##-- sub define_errors { my $self = shift; my $errors; $errors = {}; $errors->{'-501'} = 'Could not open specified database.'; $errors->{'-502'} = 'Specified column(s) not found.'; $errors->{'-503'} = 'Incorrect format in [select] statement.'; $errors->{'-504'} = 'Incorrect format in [update] statement.'; $errors->{'-505'} = 'Incorrect format in [delete] statement.'; $errors->{'-506'} = 'Incorrect format in [add/drop column] statement.'; $errors->{'-507'} = 'Incorrect format in [alter table] statement.'; $errors->{'-508'} = 'Incorrect format in [insert] command.'; $errors->{'-509'} = 'The no. of columns does not match no. of values.'; $errors->{'-510'} = 'A severe error! Check your query carefully.'; $errors->{'-511'} = 'Cannot write the database to output file.'; $errors->{'-512'} = 'Unmatched quote in expression.'; $errors->{'-513'} = 'Need to open the database first!'; $errors->{'-514'} = 'Please specify a valid query.'; # $errors->{'-515'} = 'Cannot get lock on database file.'; # $errors->{'-516'} = 'Cannot delete temp. lock file.'; $errors->{'-517'} = "Built-in function failed ($@)."; $errors->{'-518'} = "Unique Key Constraint violated."; #JWT. $errors->{'-519'} = "Field would have to be truncated."; #JWT. $errors->{'-520'} = "Can not create existing table (drop first!)."; #20000225 JWT. $errors->{'-521'} = "Can not change datatype on non-empty table."; #20000323 JWT. $errors->{'-522'} = "Can not decrease field-size on non-empty table."; #20000323 JWT. $errors->{'-523'} = "Update Failed to commit changes."; #20000323 JWT. $errors->{'-524'} = "No such table."; #20000323 JWT. $errors->{'-599'} = 'General error.'; $self->{errors} = $errors; return (1); } sub parse_expression { my ($self, $s) = @_; $s =~ s/\s+$//o; #STRIP OFF LEADING AND TRAILING WHITESPACE. $s =~ s/^\s+//o; return unless ($s); my $relop = '(?:<|=|>|<=|>=|!=|like|not\s+like|is\s+not|is)'; my %boolopsym = ('and' => '&', 'or' => '|'); my $indx = 0; my @P = (); my @T3 = (); #PROTECTS MULTI-WAY RELOP EXPRESSIONS, IE. (A AND B AND C) my $t3indx = 0; @T = (); my @QS = (); $s=~s|\\\'|\x04|go; #PROTECT "\'" IN QUOTES. $s=~s|\\\"|\x02|go; #PROTECT "\"" IN QUOTES. #THIS NEXT LOOP STRIPS OUT AND SAVES ALL QUOTED STRING LITERALS #TO PREVENT THEM FROM INTERFEARING WITH OTHER REGICES, IE. DON'T #WANT OPERATORS IN STRINGS TO BE TREATED AS OPERATORS! $indx++ while ($s =~ s/([\'\"])([^\1]*?)\1/ $QS[$indx] = $2; "\$QS\[$indx]"/e); for (my $i=0;$i<=$#QS;$i++) #ESCAPE LDAP SPECIAL-CHARACTERS. { $QS[$i] =~ s/\\x([\da-fA-F][\da-fA-F])/\x05$1/g; #PROTECT PERL HEX TO LDAP HEX (\X## => \##). #$QS[$i] =~ s/([\*\(\)\+\\\<\>])/\\$1/g; #CHGD. TO NEXT. 20020409! $QS[$i] =~ s/([\*\(\)\\])/"\\".unpack('H2',$1)/eg; #$QS[$i] =~ s/\\x(\d\d)/\\$1/g; #CONVERT PERL HEX TO LDAP HEX (\X## => \##). $QS[$i] =~ s/\x05([\da-fA-F][\da-fA-F])/\\$1/go; #CONVERT PERL HEX TO LDAP HEX (\X## => \##). } #print STDERR "-parse_expression: QS list=".join('|',@QS)."= SSSS=$s=\n"; $indx = 0; #I TRIED TO ALLOWING ATTRIBUTES TO BE COMPARED W/OTHER ATTRIBUTES, BUT #(20020409), BUT APPARENTLY LDAP ONLY ALLOWS STRING CONSTANTS ON RHS OF OPERATORS! # $indx++ while ($s =~ s/(\w+)\s*($relop)\s*(\$QS\[\d*\]|\w+)/ #THIS WAS TRIED TO COMPARE ATTRIBUTES WITH ATTRIBUTES, BUT APPARENTLY DOESN'T WORK IN LDAP! $indx++ while ($s =~ s/(\w+)\s*($relop)\s*(\$QS\[\d*\])/ my ($one, $two, $three) = ($1, $2, $3); my ($regex) = 0; my ($opr) = $two; #CONVERT "NOT LIKE" AND "IS NOT" TO "!( = ). if ($two =~ m!(?:not\s+like|is\s+not)!io) { $two = '='; $regex = 2; } elsif ($two =~ m!(?:like|is)!io) #CONVERT "LIKE" AND "IS" TO "=". { $two = '='; $regex = 1; } $P[$indx] = $one.$two.$three; #SAVE EXPRESSION. #CONVERT SQL WILDCARDS INTO LDAP WILDCARDS IN OPERAND. my ($qsindx); if ($three =~ m!\$QS\[(\d+)\]!) { $qsindx = $1; if ($regex > 0) { if ($opr !~ m!is!io) { $QS[$qsindx] =~ s!\%!\*!go; #FIX WILDCARD. NOTE - NO FIX FOR "_"! } } $QS[$qsindx] = $self->{ldap_nullsearchvalue} unless (length($QS[$qsindx])); } $P[$indx] = "!($P[$indx])" if ($regex == 2 || $opr eq '!=' || ($opr eq '=' && !length($QS[$qsindx]))); #INVERT EXPRESSION IF "NOT"! $P[$indx] =~ s!\!\=!\=!o; #AFTER INVERSION, FIX "!=" (NOT VALID IN LDAP!) "\$P\[$indx]"; /ei); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano $self->{tindx} = 0; $s = &parseParins($self, $s); for (my $i=0;$i<=$#T;$i++) { # 1 while ($T[$i] =~ s/(.+?)\s*\band\b\s*(.+)/\&\($1\)\($2\)/i); 1 while ($T[$i] =~ s/([^\(\)]+)\s*\band\b\s*([^\(\)]+)(?:and|or)?/\&\($1\)\($2\)/i); 1 while ($T[$i] =~ s/([^\(\)]+)\s*\bor\b\s*([^\(\)]+)(?:and|or)?/\|\($1\)\($2\)/i); } $s =~ s/AND/and/igo; $s =~ s/OR/or/igo; # 1 while ($s =~ s/(.+?)\s*\band\b\s*(.+)/\(\&\($1\)\($2\)\)/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 1 while ($s =~ s/([^\(\)]+)\s*\band\b\s*([^\(\)]+)(?:and|or)?/\&\($1\)\($2\)/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 1 while ($s =~ s/([^\(\)]+)\s*\bor\b\s*([^\(\)]+)(?:and|or)?/\|\($1\)\($2\)/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano 1 while ($s =~ s/\bnot\b\s*([^\s\)]+)?/\!\($1\)/); 1 while ($s =~ s/\$T\[(\d+)\]/$T[$1]/g); $s =~ s/(\w+)\s+is\s+not\s+null?/$1\=\*/gi; $s =~ s/(\w+)\s+is\s+null?/\!\($1\=\*\)/gi; #CONVERT SQL WILDCARDS TO PERL REGICES. 1 while ($s =~ s/\$P\[(\d+)\]/$P[$1]/g); $s =~ s/ +//go; 1 while ($s =~ s/\$QS\[(\d+)\]/$QS[$1]/g); $s =~ s/\x04/\'/go; #UNPROTECT AND UNESCAPE QUOTES WITHIN QUOTES. $s = '(' . $s . ')' unless ($s =~ /^\(/o); return $s; } sub parseParins { my $self = shift; my $s = shift; $self->{tindx}++ while ($s =~ s/\(([^\(\)]+)\)/ $T[$self->{tindx}] = &parseParins($self, $1); "\$T\[$self->{tindx}]" /e); return $s; } sub rollback { my ($self) = @_; my ($status) = 1; my ($dbh) = $self->FETCH('ldap_dbh'); my ($autocommit) = $dbh->FETCH('AutoCommit'); $status = $dbh->rollback() unless ($autocommit); $self->{dirty} = 0 if ($status > 0); return $status; } sub update { my ($self, $csr, $query) = @_; my ($i, $path, $regex, $table, $extra, @attblist, $filter, $all_columns); my $status = 0; my ($psuedocols) = "CURVAL|NEXTVAL|ROWNUM"; #print STDERR "-update10 sql=$query=\n"; ##++ ## Hack to allow parenthesis to be escaped! ##-- $query =~ s/\\([()])/sprintf ("%%\0%d: ", ord ($1))/ge; $path = $self->{path}; $regex = $self->{column}; if ($query =~ /^update\s+($path)\s+set\s+(.+)$/i) { ($table, $extra) = ($1, $2); #print STDERR "-update20: table=$table= extra=$extra=\n"; #ADDED IF-STMT 20010418 TO CATCH #PARENTHESIZED SET-CLAUSES (ILLEGAL IN ORACLE & CAUSE WIERD PARSING ERRORS!) if ($extra =~ /^\(.+\)\s*where/io) { $errdetails = 'parenthesis around SET clause?'; return (-504); } $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! $self->{file} = $table; my ($dbh) = $csr->FETCH('ldap_dbh'); my ($ldap) = $csr->FETCH('ldap_ldap'); my ($tablehash) = $dbh->FETCH('ldap_tables'); return (-524) unless ($tablehash->{$table}); my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table}); $all_columns = {}; $extra =~ s/\\\\/\x02/go; #PROTECT "\\" #1$extra =~ s/\'\'/\x03\x03/go; #PROTECT '', AND \'. $extra =~ s/\\\'/\x03/go; #PROTECT '', AND \'. $extra =~ s/^\s+//o; #STRIP OFF SURROUNDING SPACES. $extra =~ s/\s+$//o; #NOW TEMPORARILY PROTECT COMMAS WITHIN (), IE. FN(ARG1,ARG2). $column = $self->{column}; $extra =~ s/($column\s*\=\s*)\'(.*?)\'(,|$)/ my ($one,$two,$three) = ($1,$2,$3); $two =~ s|\,|\x05|go; $two =~ s|\(|\x06|go; $two =~ s|\)|\x07|go; $one."'".$two."'".$three; /eg; 1 while ($extra =~ s/\(([^\(\)]*)\)/ my ($args) = $1; $args =~ s|\,|\x05|go; "\x06$args\x07"; /eg); @expns = split(',',$extra); #print STDERR "-update50: extra=$extra= expns=".join('|',@expns)."=\n"; for ($i=0;$i<=$#expns;$i++) #PROTECT "WHERE" IN QUOTED VALUES. { $expns[$i] =~ s/\x05/\,/go; $expns[$i] =~ s/\x06/\(/go; $expns[$i] =~ s/\x07/\)/go; $expns[$i] =~ s/\=\s*'([^']*?)where([^']*?)'/\='$1\x05$2'/gi; $expns[$i] =~ s/\'(.*?)\'/my ($j)=$1; $j=~s|where|\x05|gio; "'$j'" /eg; } $extra = $expns[$#expns]; #EXTRACT WHERE-CLAUSE, IF ANY. $filter = ($extra =~ s/(.*)where(.+)$/where$1/i) ? $2 : ''; $filter =~ s/\s+//o; $expns[$#expns] =~ s/\s*where(.+)$//io; #20000108 REP. PREV. LINE 2FIX BUG IF LAST COLUMN CONTAINS SINGLE QUOTES. $column = $self->{column}; $objfilter ||= 'objectclass=*'; $objfilter = "($objfilter)" unless ($objfilter =~ /^\(/o); if ($filter) { #print STDERR "--update: BEF parse_expn: filter=$filter=\n"; $filter = $self->parse_expression ($filter); #print STDERR "--update: AFT parse_expn: filter=$filter= objfilter=$objfilter=\n"; $filter = '('.$filter.')' unless ($filter =~ /^\(/o); $filter = "(&$objfilter$filter)"; } else { $filter = "$objfilter"; } $filter =~ s/\x03/\\\'/go; #UNPROTECT '', AND \'. #NEXT 2 ADDED 20091101: $filter =~ s/\x02/\\\\/go; #UNPROTECT "\\". # $alwaysinsert .= ',' . $base; #CHGD TO NEXT 200780719 PER REQUEST. $alwaysinsert .= ',' . $base if ($self->{ldap_appendbase2ins}); $alwaysinsert =~ s/\\\\/\x02/go; #PROTECT "\\" $alwaysinsert =~ s/\\\,/\x03/go; #PROTECT "\," $alwaysinsert =~ s/\\\=/\x04/go; #PROTECT "\=" my ($i1, $col, $vals, $j, @l); for ($i=0;$i<=$#expns;$i++) #EXTRACT FIELD NAMES AND #VALUES FROM EACH EXPRESSION. { $expns[$i] =~ s/\x03/\\\'/go; #UNPROTECT '', AND \'. $expns[$i] =~ s/\x02/\\\\/go; #UNPROTECT "\\". $expns[$i] =~ s!\s*($column)\s*=\s*(.+)$! my ($var) = $1; my ($val) = $2; $val = &pscolfn($self,$val) if ($val =~ "$column\.$psuedocols"); $var =~ tr/A-Z/a-z/; $val =~ s|%\0(\d+): |pack("C",$1)|ge; $val =~ s/^\'//o; #NEXT 2 ADDED 20010530 TO STRIP EXCESS QUOTES. $val =~ s/([^\\\'])\'$/$1/; $val =~ s/\'$//o; $all_columns->{$var} = $val; @_ = split(/\,\s*/o, $alwaysinsert); while (@_) { ($col, $vals) = split(/\=/o, shift); next unless ($col eq $var); $vals =~ s/\x04/\\\=/go; #UNPROTECT "\=" $vals =~ s/\x03/\\\,/go; #UNPROTECT "\," $vals =~ s/\x02/\\\\/go; #UNPROTECT "\\" @l = split(/\Q$self->{ldap_inseparator}\E/, $vals); VALUE: for (my $j=0;$j<=$#l;$j++) { next if ($all_columns->{$var} =~ /\b$l[$j]\b/); $all_columns->{$var} .= $self->{ldap_inseparator} if ($all_columns->{$var}); $all_columns->{$var} .= $l[$j]; } } $all_columns->{$var} =~ s/\x02/\\\\/go; # $all_columns->{$var} =~ s/\x03/\'/go; #20091030: REPL. W.NEXT LINE TO KEEP ESCAPE SLASH "\" - RETAIN ORIG. COMMENT: $all_columns->{$var} =~ s/\x03/\\\'/go; #20000108 REPL. PREV. LINE - NO NEED TO DOUBLE QUOTES (WE ESCAPE THEM) - THIS AIN'T ORACLE. !e; } delete $all_columns->{dn}; #DO NOT ALLOW DN TO BE CHANGED DIRECTLY! #foreach my $xxx (sort keys %{$all_columns}) { print STDERR "---data($xxx)=".$all_columns->{$xxx}."=\n"; }; my ($data); my (@searchops) = ( 'base' => $base, 'filter' => $filter, ); foreach my $i (qw(ldap_sizelimit ldap_timelimit deref typesonly callback)) { $j = $i; $j =~ s/^ldap_//o; push (@searchops, ($j, $self->{$i})) if ($self->{$i}); } push (@searchops, ('scope', ($self->{ldap_scope} || 'one'))); #print STDERR "-update: filter=$filter= searchops=".join('|',@searchops)."=\n"; $data = $ldap->search(@searchops) or return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); #print STDERR "-update: got thru search; data=$data=\n"; my (@varlist) = (); $dbh = $csr->FETCH('ldap_dbh'); my ($autocommit) = $dbh->FETCH('AutoCommit'); my ($commitqueue) = $dbh->FETCH('ldap_commitqueue') unless ($autocommit); my (@dnattbs) = split(/\,/o, $dnattbs); my ($changedn); #print STDERR "-update: going into loop!\n"; while (my $entry = $data->shift_entry()) { #print STDERR "----update: in loop entry=$entry=\n"; $dn = $entry->dn(); $dn =~ s/\\/\x02/go; #PROTECT "\"; $dn =~ s/\\\,/\x03/go; #PROTECT "\,"; $changedn = 0; I: foreach my $i (@dnattbs) { foreach my $j (keys %$all_columns) { if ($i eq $j) { $dn =~ s/(\b$i\=)([^\,]+)/$1$all_columns->{$j}/; $changedn = 1; next I; } } } $dn =~ s/(?:\,\s*)$base$//; $dn =~ s/\x03/\\\,/go; #UNPROTECT "\,"; $dn =~ s/\x02/\\/go; #UNPROTECT "\"; foreach my $i (keys %$all_columns) { $all_columns->{$i} =~ s/(?:\\|\')\'/\'/go; #1UNESCAPE QUOTES IN VALUES. @_ = split(/\Q$self->{ldap_inseparator}\E/, $all_columns->{$i}); if (!@_) { push (@attblist, ($i, '')); } elsif (@_ == 1) { push (@attblist, ($i, shift)); } else { push (@attblist, ($i, [@_])); } } $r1 = $entry->replace(@attblist); #print STDERR "-update: r1=$r1= attblist=".join('|',@attblist)."=\n"; if ($r1 > 0) { if ($autocommit) { $r2 = $entry->update($ldap); #COMMIT!!! if ($r2->is_error) { $errdetails = $r2->code . ': ' . $r2->error; return (-523); } if ($changedn) { $r2 = $ldap->moddn($entry, newrdn => $dn); if ($r2->is_error) { $errdetails = "Could not change dn - " . $r2->code . ': ' . $r2->error . '!'; return (-523); } } } else { push (@{$commitqueue}, (\$entry, \$ldap)); push (@{$commitqueue}, "dn=$dn") if ($changedn); } ++$status; } else { #return($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); $errdetails = $data->code . ': ' . $data->error; return (-523); } } return ($status); } else { return (-504); } } sub delete { my ($self, $csr, $query) = @_; my ($path, $table, $filter, $wherepart); my $status = 0; $path = $self->{path}; if ($query =~ /^delete\s+from\s+($path)(?:\s+where\s+(.+))?$/io) { $table = $1; $wherepart = $2; $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! $self->{file} = $table; my ($dbh) = $csr->FETCH('ldap_dbh'); my ($ldap) = $csr->FETCH('ldap_ldap'); my ($tablehash) = $dbh->FETCH('ldap_tables'); return (-524) unless ($tablehash->{$table}); my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table}); $objfilter ||= 'objectclass=*'; $objfilter = "($objfilter)" unless ($objfilter =~ /^\(/o); if ($wherepart =~ /\S/o) { $filter = $self->parse_expression ($wherepart); $filter = '('.$filter.')' unless ($filter =~ /^\(/o); $filter = "(&$objfilter$filter)"; } else { $filter = "$objfilter"; } $filter = '('.$filter.')' unless ($filter =~ /^\(/o); $data = $ldap->search( base => $base, filter => $filter, ) or return ($self->ldap_error($@,"Search failed to return object: filter=$filter (".$data->error().")")); my ($j) = 0; my (@varlist) = (); $dbh = $csr->FETCH('ldap_dbh'); my ($autocommit) = $dbh->FETCH('AutoCommit'); my ($commitqueue) = $dbh->FETCH('ldap_commitqueue') unless ($autocommit); while (my $entry = $data->shift_entry()) { $dn = $entry->dn(); next unless ($dn =~ /$base$/i); #CASE-INSENSITIVITY ADDED NEXT 2: 20050416 PER PATCH BY jmorano $r1 = $entry->delete(); if ($autocommit) { $r2 = $entry->update($ldap); #COMMIT!!! if ($r2->is_error) { $errdetails = $r2->code . ': ' . $r2->error; return (-523); } } else { push (@{$commitqueue}, (\$entry, \$ldap)); } ++$status; } return $status; } else { return (-505); } } sub primary_key_info { my ($self, $csr, $query) = @_; my $table = $query; $table =~ s/^.*\s+(\w+)$/$1/; $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! $self->{file} = $table; my ($dbh) = $csr->FETCH('ldap_dbh'); my $tablehash = $dbh->FETCH('ldap_tables'); return -524 unless ($tablehash->{$table}); undef %{ $self->{types} }; undef %{ $self->{lengths} }; $self->{use_fields} = 'CAT,SCHEMA,TABLE_NAME,PRIMARY_KEY'; $self->{order} = [ 'CAT', 'SCHEMA', 'TABLE_NAME', 'PRIMARY_KEY' ]; $self->{fields}->{CAT} = 1; $self->{fields}->{SCHEMA} = 1; $self->{fields}->{TABLE_NAME} = 1; $self->{fields}->{PRIMARY_KEY} = 1; undef @{ $self->{records} }; my (@keyfields) = split(/\,\s*/o, $self->{key_fields}); #JWT: PREVENT DUP. KEYS. ${$self->{types}}{CAT} = 'VARCHAR'; ${$self->{types}}{SCHEMA} = 'VARCHAR'; ${$self->{types}}{TABLE_NAME} = 'VARCHAR'; ${$self->{types}}{PRIMARY_KEY} = 'VARCHAR'; ${$self->{lengths}}{CAT} = 50; ${$self->{lengths}}{SCHEMA} = 50; ${$self->{lengths}}{TABLE_NAME} = 50; ${$self->{lengths}}{PRIMARY_KEY} = 50; ${$self->{defaults}}{CAT} = undef; ${$self->{defaults}}{SCHEMA} = undef; ${$self->{defaults}}{TABLE_NAME} = undef; ${$self->{defaults}}{PRIMARY_KEY} = undef; ${$self->{scales}}{PRIMARY_KEY} = 50; ${$self->{scales}}{PRIMARY_KEY} = 50; ${$self->{scales}}{PRIMARY_KEY} = 50; ${$self->{scales}}{PRIMARY_KEY} = 50; my $results; my $keycnt = scalar(@keyfields); while (@keyfields) { push (@{$results}, [0, 0, $table, shift(@keyfields)]); } unshift (@$results, $keycnt); return $results; } sub alter #SQL COMMAND NOT IMPLEMENTED. { $@ = 'SQL "alter" command is not (yet) implemented!'; return 0; } sub insert { #my ($self, $query) = @_; my ($self, $csr, $query) = @_; my ($i, $path, $table, $columns, $values, $status); $path = $self->{path}; if ($query =~ /^insert\s+into\s+ # Keyword ($path)\s* # Table (?:\((.+?)\)\s*)? # Keys values\s* # 'values' \((.+)\)$/ixo) { #JWT: MAKE COLUMN LIST OPTIONAL! ($table, $columns, $values) = ($1, $2, $3); my ($dbh) = $csr->FETCH('ldap_dbh'); my ($tablehash) = $dbh->FETCH('ldap_tables'); $table =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! $self->{file} = $table; return (-524) unless ($tablehash->{$table}); my ($base, $objfilter, $dnattbs, $allattbs, $alwaysinsert) = split(/\:/,$tablehash->{$table}); $columns =~ s/\s//go; $columns ||= $allattbs; $columns = join(',', @{ $self->{order} }) unless ($columns =~ /\S/o); #JWT unless ($columns =~ /\S/o) { return ($self->display_error (-509)); } $values =~ s/\\\\/\x02/go; #PROTECT "\\" $values =~ s/\\\'/\x03/go; #PROTECT '', AND \'. $values =~ s/\'(.*?)\'/ my ($j)=$1; $j=~s|,|\x04|go; #PROTECT "," IN QUOTES. "'$j'" /eg; @values = split(/,/o, $values); $values = ''; for $i (0..$#values) { $values[$i] =~ s/^\s+//o; #STRIP LEADING & TRAILING SPACES. $values[$i] =~ s/\s+$//o; $values[$i] =~ s/\x03/\'/go; #RESTORE PROTECTED SINGLE QUOTES HERE. $values[$i] =~ s/\x02/\\/go; #RESTORE PROTECTED SLATS HERE. $values[$i] =~ s/\x04/,/go; #RESTORE PROTECTED COMMAS HERE. } chop($values); $status = $self->insert_data ($csr, $base, $dnattbs, $alwaysinsert, $columns, @values); return $status; } else { return (-508); } } sub insert_data { my ($self, $csr, $base, $dnattbs, $alwaysinsert, $column_string, @values) = @_; my (@columns, @attblist, $loop, $column, $j, $k); $column_string =~ tr/A-Z/a-z/; $dnattbs =~ tr/A-Z/a-z/; @columns = split (/\,/o, $column_string); if ($#columns = $#values) { my $dn = ''; my @t = split(/,/o, $dnattbs); while (@t) { $j = shift (@t); J1: for (my $i=0;$i<=$#columns;$i++) { if ($columns[$i] eq $j) { $dn .= $columns[$i] . '='; if ($values[$i] =~ /\Q$self->{ldap_inseparator}\E/) { $dn .= (split(/\Q$self->{ldap_inseparator}\E/,$values[$i]))[0]; } else { $dn .= $values[$i]; } $dn .= ', '; last J1; } } } $dn =~ s/\'//go; $dn .= $base; for (my $i=0;$i<=$#columns;$i++) { @l = split(/\Q$self->{ldap_inseparator}\E/,$values[$i]); while (@l) { $j = shift(@l); $j =~ s/^\'//o; $j =~ s/([^\\\'])\'$/$1/; unless (!length($j) || $j eq "'" || $columns[$i] eq 'dn') { $j = "'" if ($j eq "''"); push (@attblist, $columns[$i]); push (@attblist, $j); } } } # $alwaysinsert .= ',' . $base; #CHGD TO NEXT 200780719 PER REQUEST. $alwaysinsert .= ',' . $base if ($self->{ldap_appendbase2ins}); my ($i1, $found, $col, $vals, $j); @_ = split(/\,\s*/o, $alwaysinsert); while (@_) { ($col, $vals) = split(/\=/o, shift); @l = split(/\Q$self->{ldap_inseparator}\E/, $vals); VALUE: for (my $i=0;$i<=$#l;$i++) { for ($j=0;$j<=$#attblist;$j+=2) { if ($attblist[$j] eq $col) { next VALUE if ($attblist[$j+1] eq $l[$i]); } } push (@attblist, $col); push (@attblist, $l[$i]); } } my ($ldap) = $csr->FETCH('ldap_ldap'); my $entry = Net::LDAP::Entry->new; $entry->dn($dn); my $result = $entry->add(@attblist); $_ = $entry->dn(); my ($dbh) = $csr->FETCH('ldap_dbh'); my ($autocommit) = $dbh->FETCH('AutoCommit'); if ($autocommit) { $r2 = $entry->update($ldap); #COMMIT!!! if ($r2->is_error) { $errdetails = $r2->code . ': ' . $r2->error; return (-523); } } else { my ($commitqueue) = $dbh->FETCH('ldap_commitqueue'); push (@{$commitqueue}, (\$entry, \$ldap)); } return (1); } else { $errdetails = "$#columns != $#values"; #20000114 return (-509); } } sub create #SQL COMMAND NOT IMPLEMENTED. { $@ = 'SQL "create" command is not (yet) implemented!'; return 0; } sub drop #SQL COMMAND NOT IMPLEMENTED. { $@ = 'SQL "drop" command is not (yet) implemented!'; return 0; } sub pscolfn { my ($self,$id) = @_; return $id unless ($id =~ /CURVAL|NEXTVAL|ROWNUM/); my ($value) = ''; my ($seq_file,$col) = split(/\./o, $id); $seq_file = $self->get_path_info($seq_file) . '.seq'; $seq_file =~ tr/A-Z/a-z/ unless ($self->{CaseTableNames}); #JWT:TABLE-NAMES ARE NOW CASE-INSENSITIVE! open (FILE, "<$seq_file") || return (-511); $x = ; #chomp($x); $x =~ s/\s+$//o; #20000113 ($incval, $startval) = split(/\,/o, $x); close (FILE); if ($id =~ /NEXTVAL/o) { open (FILE, ">$seq_file") || return (-511); $incval += ($startval || 1); print FILE "$incval,$startval\n"; close (FILE); } $value = $incval; return $value; } sub SYSTIME { return time; } sub NUM { return shift; } sub NULL { return ''; } 1; DBD-LDAP-0.20/DBDLdap.htm0000644000175000001440000004540710463732362014265 0ustar turnerjwusers DBD::LDAP - Perl extension for DBI, providing an SQL/Perl DBI interface to LDAP databases. LDAP stands for the "Lightweight Directory Access Protocol". For more information, see: http://www.ogre.com/ldap/docs.html

NAME

     DBD::LDAP - Perl extension for DBI, providing an SQL/Perl DBI interface 
     to LDAP databases.  LDAP stands for the "Lightweight Directory Access 
     Protocol".  For more information, see:  http://www.ogre.com/ldap/docs.html

AUTHOR

    This module is Copyright (C) 2000-2004 by
                Jim Turner


        Email:  turnerjw@wwol.com
    All rights reserved Without Prejudice.
    You may distribute this module under the terms of either the GNU General
    Public License or the Artistic License, as specified in the Perl README
    file.

PREREQUISITES

        Convert::ANS1   (required by Net::LDAP)
        Net::LDAP
        DBI
        - an LDAP database to connect to.

SYNOPSIS

     use DBI;
     $dbh = DBI->connect("DBI:LDAP:ldapdb",'user','password')  #USER LOGIN.
         or die "Cannot connect as user: " . $DBI::errstr;
     $dbh = DBI->connect("DBI:LDAP:ldapdb")  #ANONYMOUS LOGIN (Read-only).
         or die "Cannot connect as guest (readonly): " . $DBI::errstr;
     $sth = $dbh->prepare("select * from people where (cn like 'Smith%')")
         or die "Cannot prepare: " . $dbh->errstr();
     $sth->execute() or die "Cannot execute: " . $sth->errstr();
         while ((@results) = $sth->fetchrow_array)
         {
                 print "--------------------------------------------------------\n";
                 ++$cnt;
                 while (@results)
                 {
                         print "------>".join('|',split(/\0/, shift(@results)))."\n";
                 }
         }
     $sth->finish();
     $dbh->disconnect();

DESCRIPTION

DBD::LDAP is a DBI extension module adding an SQL database interface to standard LDAP databases to Perl's database-independent database interface. You will need access to an existing LDAP database or set up your own using an LDAP server, ie. ``OpenLDAP'', see (http://www.openldap.org).

JLdap.pm is included in this module as a separate file, and is required.

The main advantage of DBD::LDAP is the ability to query LDAP databases via standard SQL queries in leu of cryptic LDAP ``filters''. LDAP is optimized for quick lookup of existing data, but DBD::LDAP does support entry inserts, updates, and deletes with commit/rollback via the standard SQL commands!

LDAP databases are ``heirarchical'' in structure, whereas other DBD-supported databases are ``relational'' and there is no LDAP-equivalent to SQL ``tables'', so DBD::LDAP maps a ``table'' interface over the LDAP ``tree'' via a configuration file you must set up. Each ``table'' is mapped to a common ``base DN''. For example, consider a typical LDAP database of employees within different departments within a company. You might have a ``company'' names ``Acme'' and the root ``dn'' of ``dc=Acme, dc=com'' (Acme.com). Below the company level, are divisions, ie. ``Widgets'', and ``Blivets''. Each division would have an entry with a ``dn'' of ``ou=Widgets, dc=Acme, dc=com''. Employees within each division could have a ``dn'' of ``cn=John Doe, ou=Widgets, dc=Acme, dc=com''. With DBD::LDAP, we could create tables to access these different levels, ie. ``top'', which would have a ``DN'' of ``dc=Acme, dc=com'', ``WidgetDivision'' for ``dc=Acme, dc=com''. Tables can also be constained by additional attribute specifications (filters), ie constraining by ``objectclass'', ie. ``(objectclass=person)''. Then, doing a ``select * from WidgetDivision'' would display all ``person''s with a ``dn'' containing ``''ou=Widgets, dc=Acme, dc=com``.

INSTALLATION

    Installing this module (and the prerequisites from above) is quite
    simple. You just fetch the archive, extract it with
        gzip -cd DBD-LDAP-0.1000.tar.gz | tar xf -
    (this is for Unix users, Windows users would prefer WinZip or something
    similar) and then enter the following:
        cd DBD-LDAP-#.###
        perl Makefile.PL
        make
        make test
    If any tests fail, let me know. Otherwise go on with
        make install
    Note that you almost definitely need root or administrator permissions.
    If you don't have them, read the ExtUtils::MakeMaker man page for
    details on installing in your own directories.

GETTING STARTED:

        1) Create a "database", ie. "foo" by creating a text file "foo.ldb".  The 
        general format of this file is:


----------------------------------------------------------
hostname[;port][:[root-dn][:[loginrule]]]
tablename1:[basedn]:[basefilter]:dnattrs:[visableattrs]:[insertattrs]:[ldap_options]
tablename2:[basedn]:[basefilter]:dnattrs:[visableattrs]:[insertattrs]:[ldap_options]
...
----------------------------------------------------------
        <hostname>              represents the ldap server host name.
        <port>                  represents the server's port, default is 389.
        <root-dn>                       if specified, is appended to the end of each tablename's 
                                base-dn.
        <loginrule>     if specified, converts single word "usernames" to the 
                                appropriate DN, ie:
                        "cn=*,<ROOT>" would convert user name "foo" to "cn=foo, " and 
                        append the "<root-dn>" onto that.  The asterisk is converted to 
                        the user-name specified in the "connect" method.  If not specified, 
                        the username specified in the "connect" method must be a full DN.
                        If the "<root-dn>" is not specified, then the "<loginrule>" would 
                        need to be a full DN.
        tablename       -       represents the name to be used in SQL statements for a given 
                        set of entries which make up a virtual "table".
        basedn - if specified, is appended to the "<root-dn>" to make up the 
                        common base DN for all entries in this table.  If "<root-dn>" is 
                        not specified, then a full DN must be specified; otherwise, the 
                        default is the root-dn.
        basefilter      - if specified, specifies a filter to be used if no "where"-
                        clause is specified in SQL queries.  If a "where"-clause is 
                        specified, the resulting filter is "and"-ed with this one.  The 
                        default is "(objectclass=*)".
        dnattrs - specifies which attributes that values for which are to be 
                        appended to the left of the basedn to create DNs for new entries 
                        being inserted into the table.
        visableattrs - if specified, one or more attributes separated by commas 
                        which will be sought when the SQL statement does not specify 
                        attributes, ie. "select * from tablename".  If not specified, the 
                        attributes of the first matching entry are returned and used for 
                        all entries matching a given query.
        insertattrs - if specified, one or more attribute/value combinations to be 
                        added to any new entry inserted into the table, usually needed for 
                        objectclass values.  The attributes and values usually correspond 
                        to those specivied in the "<basefilter>".  The general format is: 
                        attr1=value1[|value2...],attr2=value1...,...
                        These attributes and values will be joined with any user-specified 
                        values for these attributes.
        ldap_options - if specified, can be any one or more of the following:
                ldap_sizelimit - Limit the number of entries fetch by a query to this 
                                number (0 = no limit) - default:  0.
                ldap_timelimit - Limit the search to this number of seconds per query. 
                                (0 = no limit) - default:  0.
                ldap_scope - specify the "scope" of the search.  Values are:  "base", 
                                "one", and "sub", see Net::LDAP docs.  Default is "one", 
                                meaning the set of records one level below the basedn.  "base" 
                                means search only the basedn, and "sub" means the union 
                                of entries at the "base" level and "one" level below.
                ldap_inseparator - specify the separator character/string to be used 
                                in queries to separate multiple values being specified for 
                                a given attribute.  Default is "|".
                ldap_outseparator - specify the separator character/string to be used 
                                in queryies to separate multiple values displayed as a result 
                                of a query.  Default is "|".
                ldap_firstonly - only display the 1st value fetched for each attribute 
                                per entry.  This makes "ldap_outseparator" unnecessary.
        2) write your script to use DBI, ie:


                #!/usr/bin/perl
                use DBI;

                $dbh = DBI->connect('DBD:LDAP:mydb','me','mypassword') || 
                                die "Could not connect (".$DBI->err.':'.$DBI->errstr.")!";
                ...
                #CREATE A TABLE, INSERT SOME RECORDS, HAVE SOME FUN!

        3) get your application working.

INSERTING, FETCHING AND MODIFYING DATA

        1st, we'll create a database called "ldapdb" with the tables previously 
        mentioned in the example in the DESCRIPTION section:


----------------- file "ldapdb.ldb" ----------------
ldapserver:dc=Acme, dc=com:cn=*,<ROOT>
top:::dc
WidgetDivision:ou=Widgets, :&(objectclass=top)(objectclass=person):cn:cn,sn,ou,title,telephonenumber,description,objectclass,dn:objectclass=top|person|organizationalPerson:ldap_outseparator => ":"
----------------------------------------------------
    The following examples insert some data in a table and fetch it back:
    First all data in the string:
        $dbh->do(<<END_SQL);
        INSERT INTO top (ou, cn, objectclass)  
        VALUES ('Widgets', 'WidgetDivision', 'top|organizationalUnit')
END_SQL
    Next an example using parameters:
        $dbh->do("INSERT INTO WidgetDivision (cn,sn,title,telephonenumber) VALUES (?, ?, ?, ?)",
        'John Doe','DoeJ','Manager','123-1111');
END_SQL
        $dbh->commit();
        NOTE:  Unlike most other DBD modules which support transactions, changes 
                made do NOT show up until the "commit" function is called, unless 
                "AutoCommit" is set.  This is due to the fact that fetches are done 
                from the LDAP server and changes do not take effect there until the 
                Net::LDAP "update" function is called, which is called by "commit".
        NOTE: The "dn" field is generated automatically from the base "dn" and the 
                dn component fields specified by "dnattrs", If you try to insert a 
                value directly into it, it will be ignored.  Also, if not specified, 
                any attribute/value combinations specified in the "insertattrs" 
                option will be added automatically.
    To retrieve data, you can use the following:
        my($query) = "SELECT * FROM WidgetDivision WHERE cn like 'John%' ORDER BY cn";
        my($sth) = $dbh->prepare($query);
        $sth->execute();
        while (my $entry = $sth->fetchrow_hashref) {
            print("Found result record: cn = ", $entry->{'cn'},
                  ", phone = ", $row->{'telephonenumber'});
        }
        $sth->finish();
        The SQL "SELECT" statement above (combined with the table information 
        in the "ldapdb.ldb" database file would generate and execute the following 
        equivalent LDAP Search:
                base => 'ou=Widgets, dc=Acme, dc=com',
                filter => '(&(&(objectclass=top)(objectclass=person))(cn=John*))',
                scope => 'one',
                attrs => 'cn,sn,ou,title,telephonenumber,description,objectclass,dn'
    See the DBI(3) manpage for details on these methods. See the
    Data rows are modified with the UPDATE statement:
        $dbh->do("UPDATE WidgetDivision SET description = 'Outstanding Employee' WHERE cn = 'John Doe'");
        NOTE:  You can NOT change the "dn" field directly - direct changes will be 
                ignored.  You change the "rdn" component of the "dn" field by changing 
                the value of the other field(s) which are appended to the base "dn".
                Also, if not specified, any attribute/value combinations specified in 
                the "insertattrs" option will be added automatically.
    Likewise you use the DELETE statement for removing entries:
        $dbh->do("DELETE FROM WidgetDivision WHERE description = 'Outstanding Employee'");

METADATA

    The following attributes are handled by DBI itself and not by DBD::LDAP,
    thus they should all work as expected.
        PrintError
        RaiseError
        Warn
    The following DBI attributes are handled by DBD::LDAP:
    AutoCommit
        Works
    NUM_OF_FIELDS
        Valid after '$sth->execute'
    NUM_OF_PARAMS
        Valid after '$sth->prepare'
    NAME
        Valid after '$sth->execute'; undef for Non-Select statements.
    NULLABLE
        Not really working. Always returns an array ref of one's, as
        DBD::LDAP always allows NULL (handled as an empty string). 
        Valid after `$sth->execute'.
    LongReadLen
                Should work
    LongTruncOk
                Should work
    These attributes and methods are not supported:
        bind_param_inout
        CursorName
    In addition to the DBI attributes, you can use the following dbh
    attributes.  These attributes are read-only after "connect".
        ldap_dbuser
                Current database user.


        ldap_HOME
                Environment variable specifying a path to search for LDAP 
                databases (*.sdb) files.


=head1 DRIVER PRIVATE METHODS
    DBI->data_sources()
        The `data_sources' method returns a list of "databases" (.ldb files) 
        found in the current directory and, if specified, the path in 
        the ldap_HOME environment variable.


    $dbh->tables()
        This method returns a list of table names specified in the current 
        database.
        Example:
            my($dbh) = DBI->connect("DBI:LDAP:mydatabase",'me','mypswd');
            my(@list) = $dbh->func('tables');

OTHER SUPPORTING UTILITIES

RESTRICTIONS

        DBD::LDAP currently treats all data as strings and all fields as 
        VARCHAR(255).
        Currently, you must define tables manually in the "<database>.ldb" file 
        using your favorite text editor.  I hope to add support for the SQL 
        "Create Table", "Alter Table", and "Drop Table" functions to handle this 
        eventually.

TODO

        "Create Table", "Alter Table", and "Drop Table" SQL functions for 
        creating, altering, and deleting the tables defined in the 
        "<database>.ldb" file.
        Some kind of datatype support, ie. numeric (for sorting), CHAR for padding, 
        Long/Blob - for >255 chars per field, etc.

KNOWN BUGS

        none - (yet).


=head1 SEE ALSO
        Net::LDAP(3), DBI(3), perl(1)
DBD-LDAP-0.20/README0000644000175000001440000003264211251744771013241 0ustar turnerjwusersNAME DBD::LDAP - A DBI driver for LDAP databases. LDAP stands for the "Lightweight Directory Access Protocol". For more information, see: http://www.ogre.com/ldap/docs.html SYNOPSIS use DBI; $dbh = DBI->connect("DBI:LDAP:ldapdb",'user','password') #USER LOGIN. or die "Cannot connect as user: " . $DBI::errstr; $dbh = DBI->connect("DBI:LDAP:ldapdb") #ANONYMOUS LOGIN (Read-only). or die "Cannot connect as guest (readonly): " . $DBI::errstr; $sth = $dbh->prepare("select * from people where (cn like 'Smith%')") or die "Cannot prepare: " . $dbh->errstr(); $sth->execute() or die "Cannot execute: " . $sth->errstr(); while ((@results) = $sth->fetchrow_array) { print "--------------------------------------------------------\n"; ++$cnt; while (@results) { print "------>".join('|',split(/\0/, shift(@results)))."\n"; } } $sth->finish(); $dbh->disconnect(); DESCRIPTION DBD::LDAP is a DBI extension module adding an SQL database interface to standard LDAP databases to Perl's database-independent database interface. You will need access to an existing LDAP database or set up your own using an LDAP server, ie. "OpenLDAP", see (http://www.openldap.org). JLdap.pm is included in this module as a separate file, and is required. The main advantage of DBD::LDAP is the ability to query LDAP databases via standard SQL queries in leu of cryptic LDAP "filters". LDAP is optimized for quick lookup of existing data, but DBD::LDAP does support entry inserts, updates, and deletes with commit/rollback via the standard SQL commands! LDAP databases are "heirarchical" in structure, whereas other DBD-supported databases are "relational" and there is no Ldap-equivalent to SQL "tables", so DBD::LDAP maps a "table" interface over the LDAP "tree" via a configuration file you must set up. Each "table" is mapped to a common "base DN". For example, consider a typical LDAP database of employees within different departments within a company. You might have a "company" names "Acme" and the root "dn" of "dc=Acme, dc=com" (Acme.com). Below the company level, are divisions, ie. "Widgets", and "Blivets". Each division would have an entry with a "dn" of "ou=Widgets, dc=Acme, dc=com". Employees within each division could have a "dn" of "cn=John Doe, ou=Widgets, dc=Acme, dc=com". With DBD::LDAP, we could create tables to access these different levels, ie. "top", which would have a "DN" of "dc=Acme, dc=com", "WidgetDivision" for "ou=Widgets, dc=Acme, dc=com". Tables can also be constained by additional attribute specifications (filters), ie constraining by "objectclass", ie. "(objectclass=person)". Then, doing a "select * from WidgetDivision" would display all "person"s with a "dn" containing ""ou=Widgets, dc=Acme, dc=com". Prerequisites Convert::ANS1 (required by Net::LDAP) Net::LDAP DBI - an LDAP database to connect to. Installation Installing this module (and the prerequisites from above) is quite simple. You just fetch the archive, extract it with gzip -cd DBD-LDAP-####.tar.gz | tar xf - -or- tar -xzvf DBD-LDAP-####.tar.gz (this is for Unix users, Windows users would prefer WinZip or something similar) and then enter the following: cd DBD-LDAP-#.### perl Makefile.PL make make test If any tests fail, let me know. Otherwise go on with make install Note that you almost definitely need root or administrator permissions. If you don't have them, read the ExtUtils::MakeMaker man page for details on installing in your own directories. Getting started: 1) Create a "database", ie. "foo" by creating a text file "foo.ldb". The general format of this file is: ---------------------------------------------------------- hostname[;port][:[root-dn][:[loginrule]]] tablename1:[basedn]:[basefilter]:dnattrs:[visableattrs]:[insertattrs]:[ldap_options] tablename2:[basedn]:[basefilter]:dnattrs:[visableattrs]:[insertattrs]:[ldap_options] ... ---------------------------------------------------------- represents the ldap server host name. represents the server's port, default is 389. if specified, is appended to the end of each tablename's base-dn. if specified, converts single word "usernames" to the appropriate DN, ie: "cn=*," would convert user name "foo" to "cn=foo, " and append the "" onto that. The asterisk is converted to the user-name specified in the "connect" method. If not specified, the username specified in the "connect" method must be a full DN. If the "" is not specified, then the "" would need to be a full DN. tablename - represents the name to be used in SQL statements for a given set of entries which make up a virtual "table". basedn - if specified, is appended to the "" to make up the common base DN for all entries in this table. If "" is not specified, then a full DN must be specified; otherwise, the default is the root-dn. basefilter - if specified, specifies a filter to be used if no "where"- clause is specified in SQL queries. If a "where"-clause is specified, the resulting filter is "and"-ed with this one. The default is "(objectclass=*)". dnattrs - specifies which attributes that values for which are to be appended to the left of the basedn to create DNs for new entries being inserted into the table. visableattrs - if specified, one or more attributes separated by commas which will be sought when the SQL statement does not specify attributes, ie. "select * from tablename". If not specified, the attributes of the first matching entry are returned and used for all entries matching a given query. insertattrs - if specified, one or more attribute/value combinations to be added to any new entry inserted into the table, usually needed for objectclass values. The attributes and values usually correspond to those specivied in the "". The general format is: attr1=value1[|value2...],attr2=value1...,... These attributes and values will be joined with any user-specified values for these attributes. ldap_options - if specified, can be any one or more of the following: ldap_sizelimit - Limit the number of entries fetch by a query to this number (0 = no limit) - default: 0. ldap_timelimit - Limit the search to this number of seconds per query. (0 = no limit) - default: 0. ldap_scope - specify the "scope" of the search. Values are: "base", "one", and "sub", see Net::LDAP docs. Default is "one", meaning the set of records one level below the basedn. "base" means search only the basedn, and "sub" means the union of entries at the "base" level and "one" level below. ldap_inseparator - specify the separator character/string to be used in queries to separate multiple values being specified for a given attribute. Default is "|". ldap_outseparator - specify the separator character/string to be used in queryies to separate multiple values displayed as a result of a query. Default is "|". ldap_firstonly - only display the 1st value fetched for each attribute per entry. This makes "ldap_outseparator" unnecessary. 2) write your script to use DBI, ie: #!/usr/bin/perl use DBI; $dbh = DBI->connect('DBD:LDAP:mydb','me','mypassword') || die "Could not connect (".$DBI->err.':'.$DBI->errstr.")!"; ... #CREATE A TABLE, INSERT SOME RECORDS, HAVE SOME FUN! 3) get your application working. Inserting, fetching and modifying data 1st, we'll create a database called "ldapdb" with the tables previously mentioned in the example in the DESCRIPTION section: ----------------- file "ldapdb.ldb" ---------------- ldapserver:dc=Acme, dc=com:cn=*, top:::dc WidgetDivision:ou=Widgets, :&(objectclass=top)(objectclass=person):cn:cn,sn,ou,title,telephonenumber,description,objectclass,dn:objectclass=top|person|organizationalPerson:ldap_outseparator => ":" ---------------------------------------------------- The following examples insert some data in a table and fetch it back: First all data in the string: $dbh->do(<do("INSERT INTO WidgetDivision (cn,sn,title,telephonenumber) VALUES (?, ?, ?, ?)", 'John Doe','DoeJ','Manager','123-1111'); END_SQL $dbh->commit(); NOTE: Unlike most other DBD modules which support transactions, changes made do NOT show up until the "commit" function is called, unless "AutoCommit" is set. This is due to the fact that fetches are done from the LDAP server and changes do not take effect there until the Net::LDAP "update" function is called, which is called by "commit". NOTE: The "dn" field is generated automatically from the base "dn" and the dn component fields specified by "dnattrs", If you try to insert a value directly into it, it will be ignored. Also, if not specified, any attribute/value combinations specified in the "insertattrs" option will be added automatically. To retrieve data, you can use the following: my($query) = "SELECT * FROM WidgetDivision WHERE cn like 'John%' ORDER BY cn"; my($sth) = $dbh->prepare($query); $sth->execute(); while (my $entry = $sth->fetchrow_hashref) { print("Found result record: cn = ", $entry->{'cn'}, ", phone = ", $row->{'telephonenumber'}); } $sth->finish(); The SQL "SELECT" statement above (combined with the table information in the "ldapdb.ldb" database file would generate and execute the following equivalent LDAP Search: base => 'ou=Widgets, dc=Acme, dc=com', filter => '(&(&(objectclass=top)(objectclass=person))(cn=John*))', scope => 'one', attrs => 'cn,sn,ou,title,telephonenumber,description,objectclass,dn' See the DBI(3) manpage for details on these methods. See the Data rows are modified with the UPDATE statement: $dbh->do("UPDATE WidgetDivision SET description = 'Outstanding Employee' WHERE cn = 'John Doe'"); NOTE: You can NOT change the "dn" field directly - direct changes will be ignored. You change the "rdn" component of the "dn" field by changing the value of the other field(s) which are appended to the base "dn". Also, if not specified, any attribute/value combinations specified in the "insertattrs" option will be added automatically. Likewise you use the DELETE statement for removing entries: $dbh->do("DELETE FROM WidgetDivision WHERE description = 'Outstanding Employee'"); Metadata The following attributes are handled by DBI itself and not by DBD::LDAP, thus they should all work as expected. PrintError RaiseError Warn The following DBI attributes are handled by DBD::LDAP: AutoCommit Works NUM_OF_FIELDS Valid after `$sth->execute' NUM_OF_PARAMS Valid after `$sth->prepare' NAME Valid after `$sth->execute'; undef for Non-Select statements. NULLABLE Not really working. Always returns an array ref of one's, as DBD::LDAP always allows NULL (handled as an empty string). Valid after `$sth->execute'. LongReadLen Should work LongTruncOk Should work These attributes and methods are not supported: bind_param_inout CursorName In addition to the DBI attributes, you can use the following dbh attributes. These attributes are read-only after "connect". ldap_dbuser Current database user. ldap_HOME Environment variable specifying a path to search for LDAP databases (*.sdb) files. Driver private methods DBI->data_sources() The `data_sources' method returns a list of "databases" (.ldb files) found in the current directory and, if specified, the path in the ldap_HOME environment variable. $dbh->tables() This method returns a list of table names specified in the current database. Example: my($dbh) = DBI->connect("DBI:LDAP:mydatabase",'me','mypswd'); my(@list) = $dbh->func('tables'); Restrictions DBD::LDAP currently treats all data as strings and all fields as VARCHAR(255). Currently, you must define tables manually in the ".ldb" file using your favorite text editor. Someday, if I have too much time on my hands, I hope to add support for the SQL "Create Table", "Alter Table", and "Drop Table" functions to handle this eventually (Patches welcome!) TODO "Create Table", "Alter Table", and "Drop Table" SQL functions for creating, altering, and deleting the tables defined in the ".ldb" file. Some kind of datatype support, ie. numeric (for sorting), CHAR for padding, Long/Blob - for >255 chars per field, etc. KNOWN BUGS none - (yet). AUTHOR AND COPYRIGHT This module is Copyright (C) 2000-2004 by Jim Turner Email: turnerjw@wwol.com All rights reserved. You may distribute this module under the terms of either the GNU General Public License or the Artistic License, as specified in the Perl README file. CHANGES See Changes file. SEE ALSO Net::LDAP(3), DBI(3), perl(1) For general information on DBI see http://www.symbolstone.org/technology/perl/DBI DBD-LDAP-0.20/Changes0000644000175000001440000000654311274673455013662 0ustar turnerjwusersRevision history for Perl extension DBD::Ldap. 0.01 Fri Jun 06 13:00:55 2000 - original version; created by h2xs 1.18 0.02 Thu Jun 07 - Changed name from "DBD::Ldap" to "DBD::LDAP". 0.03 Tue Jun 12 - Fixed bug that produced error if last attribute was null for any of the records returned by a search. Removed lots of commented-out code. - Changed datatype from "VARCHAR" (12) to "LONG" (-1). - 1st release to CPAN! 0.04 Fri Aug 10 - Fixed bug involving autocommit on statements containing "select" in data. Caught by Simon Elliott, Thanks! 0.05 Mon Sep 17 - Fixed "ldap_..." attributes to work, ie. "ldap_firstonly" did not work. Also made "ldap_firstonly" to allow values > 1 to limit number of returned valued to that number. Previously, =1 ment 1 value, =0 ment all values. 0.06 Fri Jun 27 - Fixed Makefile.PL bug in Perl 5.8+ where make would fail with something like "Can't use string ("*.xsi") as a HASH ref...". Thanks to everyone who reported this. 0.07 Sun Mar 14 2004 - Add compatability with Class::DBI and Netscape LDAP Server (added patches by jmorano per bug#12269 and 12270 in rt.cpan.org). NOTE: Type VARCHAR is now 12 instead of -1. 0.08 Wed Jul 19 2006 - Stop appending base DN (2nd field in the table definition line) to the base insert attributes (5th field in the table definition line) per request / patch by R.K. Owen. The attribute "ldap_appendbase2ins" was added for backward compatablility. If set to 1, then pre-0.08 behaviour is used. I couldn't find a case where this was ever actually used, but if anyone needs it, then set this attribute in the "connect" call. Default is zero (new behavior - no append). 0.09 Tue Oct 24 2006 - Cause execute() to return "0E0" instead of raising a -402 error for "No matching Records" (which is not an error). This fix was made in DBD::Sprite many moons ago, but never made it here. Thanks to R. K. Owen for catching this. 0.10 Wed Sep 9 2009 - Fix bug that caused queries with 3 or more operands in a where clause without parenthesis to generate invalid filters, ie: "where a and b and c". Also added "o" option to numerous regices that do not contain variables to optimize for speed. 0.21 Thu Nov 5 2009 - Fix bug that prevented query field data from containing escaped single quotes. Note: Perl generally requires a double-backslash to preceed the quote in order to pas the escape on to LDAP. - Fix "warning" issue where "AutoCommit" was reported as not being implemented in the driver, particularly when "-w" (Perl warnings turned on). - Improved general error-message reporting, particulary by connect(), prepare(), and execute() functions. - Changed the call to Net::LDAP's get() function to get_value() per patch by Gab. Korsani. Thanks Gab, and also for providing me with a working LDAP server to test against! - Added DBI's "primary_key_info" query. - Fixed unimplemented, but valid SQL "create table", "alter table", and "drop table" calls to return zero instead of error. - Optimized many regices. - Fixed some minor issues with AutoCommit - when AutoCommit is OFF, and one exits without calling commit(), anything done since the previous commit() call should now be rolled back. - TYPE and PRECISION, etc. data are now properly returned (as VARCHAR(255)) for all fields. DBD-LDAP-0.20/test.pl0000444000175000001440000000123410463732362013661 0ustar turnerjwusersrequire DBI; # Before `make install' is performed this script should be runnable with # `make test'. After `make install' it should work as `perl test.pl' ######################### We start with some black magic to print on failure. # Change 1..1 below to 1..last_test_to_print . # (It may become useful if the test is moved to ./t subdirectory.) BEGIN { $| = 1; print "1..1\n"; } END {print "not ok 1\n" unless $loaded;} use DBD::LDAP; $loaded = 1; print "ok 1\n"; ######################### End of black magic. # Insert your test code below (better if it prints "ok 13" # (correspondingly "not ok 13") depending on the success of chunk 13 # of the test code): DBD-LDAP-0.20/Makefile.PL0000444000175000001440000000115510463732362014321 0ustar turnerjwusersuse DBI 1.03; use DBI::DBD; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. WriteMakefile( 'NAME' => 'DBD::LDAP', 'VERSION_FROM' => 'lib/DBD/LDAP.pm', # finds $VERSION 'INC' => $DBI_INC_DIR, 'dist' => { 'SUFFIX' => '.gz', 'COMPRESS' => 'gzip -9f' }, #'realclean' => '*.xsi', 'realclean' => {FILES => '*.xsi'}, PREREQ_PM => { 'Net::LDAP' => 0.01 }, ); package MY; sub postamble { "\n" . DBI::DBD::dbd_postamble(@_); } sub libscan { my ($self, $path) = @_; ($path =~ /\~$/) ? undef : $path; } DBD-LDAP-0.20/META.yml0000644000175000001440000000052411274677065013632 0ustar turnerjwusers# http://module-build.sourceforge.net/META-spec.html #XXXXXXX This is a prototype!!! It will change in the future!!! XXXXX# name: DBD-LDAP version: 0.20 version_from: lib/DBD/LDAP.pm installdirs: site requires: Net::LDAP: 0.01 distribution_type: module generated_by: ExtUtils::MakeMaker version 6.17 DBD-LDAP-0.20/MANIFEST0000644000175000001440000000024410463732362013500 0ustar turnerjwusersChanges MANIFEST README Makefile.PL lib/JLdap.pm lib/DBD/LDAP.pm test.pl DBDLdap.htm META.yml Module meta-data (added by MakeMaker)