sqlperl/README0000644000175000001440000001112310475715642013230 0ustar turnerjwusersSqlPerl Plus, by Jim Turner SqlPerlPlus is a Perl/Tk-based GUI tool for performing basic queries and SQL database table manipulation similar to "sa" or "Sql Plus", et. al. The biggest differences between this tool and others is: 1) It's graphical. 2) It can work with any database that Perl/DBI can talk to. 3) It is user-configurable via an ascii text file (sqlplcfg.txt) 4) It's free, opensource, and written in Perl/Tk. 5) Easy auto and manual formatting for report generation. 6) It can load table data into tables and write out table data in several formats, including delimited flatfiles (you choose field and record delimiters), columised (padded with spaces to desired widths), XML, and even MS-Excel (.xls). 7) When used to load data into a table in the formats mentioned in #5 above, it can generate a Perl script to automate this process. This is useful when needing to create a program to periodically load a table from a regularly-updated file on an ongoing basis. For additional information, visit the homepage at: http://home.mesh.net/turnerjw/jim/sqlperl.html SqlPerl is written completely in Perl, a modern, high-performance scripting language and runs under X or Windows using the Perl/Tk X-development library and should be usable on any Unix or Windows platform which supports Perl, Perl/Tk, and a DBI or ODBC-supported database package. SqlPerl provides easy user-interaction with the database with push- button SQL commands/queries and a text-box for typing in more complex commands. SqlPerl is great for database administrators who occassionally need to examine data, change specific fields, rows, or columns, load flat-files, generated quick formatted printable listings, etc. One can quickly look up data without having to remember table and field names and cryptic SQL commands. SqlPerl also allows one to both load data from and write data out to M$-Excel spreadsheets! When one loads formatted or delimited data into a table using SqlPerl, a Perl script is automatically generated which can then be used later to load or reload data in the same format into the same table. This allows one to test load data initially into a table, then have a ready-made cron-job to do all subsequent loads / reloads! This script is saved to the file "sqltemp.pl", which can easily be renamed. To install (Windows): Stop - download the self-extracting "sqlplsetup.exe" from my homepage (previously mentioned above) and run it. To install (Linux/Unix/MacOS): 1. Make sure Perl and Perl/Tk are installed on your system. 2. Make sure to obtain the following Perl modules are installed on your system: They are all available at my homepage and CPAN and are all single-file pure-Perl modules. Tk::JDialog Tk::JFileDialog Tk::JBrowseEntry Tk::JOptionmenu JCutCopyPaste 3. Copy "sql.pl", "sqlmake.pl", and "sqlplcfg.txt", "sqlpl.bin", and "sqlpl.dat" to the same directory somewhere in your path. 4. Edit the file "sqlpl.bin" with your favorate text editor, to add your user-name to give yourself access to tables. 5. Run "sqlmake.pl" to "compile" (encrypt) "sqlpl.bin" to "sqlpl.dat". 6. With a web-browser, view the file "sqlperl.html" for docs. 7. sql.pl & Documentation for setting up security using "sqlpl.bin" and "sqlmake.pl": SqlPerl prevents unauthorized access to database tables via an encrypted security file called "sqlpl.dat". It is built from a text-based configuration file called "sqlpl.bin" by "sqlmake.pl". Each line represents a list of user-ids and what they are allowed to access. Note: "user" refers to a user's system login (account) name. "dbuser" refers to a database's login usernames. The general syntax is: --,user1[,user2,user3...] Users in this list can access any table in any database. dbtype,user1[,user2,user3...] Users in this list can access any table in any database of this type, ie.: Oracle,oracleuser1,oracleuser2 dbname,user1[,user2,user3...] Users in this list can access any table in any database of this name, ie.: employee_database,payroll_user,accounting_user dbname:dbuser,user1[,user2,user3...] Users in this list can access any table in any database of this name under the database login name "dbuser". dbname:dbuser:table1,user1[,user2,user3...] Users in this list can access only table "table1" in any database of this name under the database login name "dbuser". dbtype:dbname:dbuser,user1[,user2,user3...] Users in this list can access any table the database of this name and type under. NOTE: As of v. 3.97, you must create a file in your home directory called ".sqlrw" (it can be empty). Otherwise, sql.pl operates in READONLY mode! sqlperl/sqlmake.pl0000755000175000001440000000151110463733277014346 0ustar turnerjwusers#!/usr/local/bin/perl -s &initialize; &doExit; #-------------------------------------------------------------------------- sub initialize { open(IN,'sqlpl.bin') || die " u:Could not open input file!"; while () { chomp; ($dbtable,@users) = split(/,/); push (@dbtables,$dbtable); $users = join(',',@users); push (@dbusers,$users); } close IN; } sub doExit { my ($u, @users); open (OUT,'>sqlpl.dat') || die " u:Could not open sqlpl.dat ($? $@)"; for (0..$#dbtables) { #$dbtables[$_] =~ s/\://; $salt = substr($dbtables[$_],0,2); @users = split(/,/,$dbusers[$_]); print "--table=$dbtables[$_]= salt=$salt=\n"; print OUT $dbtables[$_]; foreach $u (@users) { print "-------crypting user=$u="; print OUT ' ', crypt($u,$salt); print " str=", crypt($u,$salt),"=\n"; } print OUT "\n"; } exit(0); } sqlperl/sqlperl.html0000755000175000001440000010474410463733277014740 0ustar turnerjwusers The SqlPerl Home Page
The above advertising does not reflect the actual opinions of the owner(s) of this website nor do we endorse any products or services mentioned, in that the content of the adds is beyond our control, but are required by the company which hosts this site. Direct all comments or complaints to them (http://www.virtualave.com)

Updated: 8/18/99

The SqlPerl Home Page

SqlPerl - GUI interface to databases, by Jim Turner.

SqlPerl is a Sequel Graphical User Interface program for performing SQL commands and queries to databases. SqlPerl provides the following primary features:

SqlPerl is written completely in Perl, a modern, high-performance scripting language and runs under X or Windows using the Perl/Tk X-development library and should be usable on any Unix or Windows platform which supports Perl, Perl/Tk, and a DBI or ODBC-supported database package.

Click for System Requirements.

I) Graphical user-interface

The GUI provides easy user-interaction with the database with push- button SQL commands/queries and a text-box for typing in more complex commands. SqlPerl is great for database administrators who occassionally need to examine data, change specific fields, rows, or columns, load flat-files, generated quick formatted printable listings, etc. One can quickly look up data without having to remember table and field names and cryptic SQL commands.

Logging in

The user can invoke SqlPerl from the command line by simply typing:

sql.pl

at the Unix command-prompt. A small window will appear requesting the user to enter the desired database, user-name, and password. Clicking [Ok] or pressing [Enter] after typing in a password causes the user to be logged in. If the user is successfully logged in, the main screen will then be displayed. The main screen consists of the following elements from top to bottom and left to right:

1) File specification:

The user can type in a path and file name for uploading and downloading or click the [File:] button to browse and select an existing file. The radio-button just left of the [File:] button if checked, causes query results to be written (appended) to the specified file. This is how to generate delimited flat-files from data queries.

2) Delimiter:

Specify the delimiter string for use with flat-files and for displaying data. If doing a query and formatting is requested, the delimiter will be repeated to form a separator between the header and the data. Fields will be formatted into columns. If formatting is not requested, the delimiter will be used to separate the fields on the display. If File output is requested, the flat-file will be created using the delimiter string to separate fields. Records are always separated by a newline (\n). to specify a special character, ie. tab or dollar-sign, preceed it with a backslash, ie. \t or \x27. If data is being loaded from a flat-file, the delimiter used in the file should be specified as the delimiter here.

3) Header:

Click the button just left of "Header" to cause the first line displayed for queries to contain the field names. If creating a flat-file, the 1st record will contain the field-names. If uploading data from a flat- file whose first record is a header-record, click the Header button.

4) Prompt:

Check the radio-button here unless creating or uploading a flat-file or typing in sql-commands. When doing a query, the user may specify constraints (the arguments for an SQL "WHERE" clause) in the "SQL:" box below. The constraints should be separated by the delimiter character, ie. if "\t", then type in "field1='value1'\tfield2='value2'...". NOTE: Another way, which is normally easier when doing updates, is to use the "Order By" menu to specify the fields for the Where-clause, then you will be prompted to enter values for each field specified.

5) Values:

When doing a SELECT and formatted output, users can specify the number of lines (records) to be printed per page here. The default for n is 56. A form-feed followed by any header-information will follow each n-th line. If doing an INSERT, the user can specify a list of values to be inserted into the table separated by the delimiter character. NOTE: This line is also used to specify the number of lines to be displayed on a page when doing "SELECT" (see "Formatting").

NOTE: non-numeric values must be surrounded with quotes. Single or double-quotes are ok, but if a value is to contain quotes, then use the other type of quotes, ie. "John M'cBride". You can also leave this field blank and you will be prompted for the values.

6) SQL:

You can type in SQL commands directly here in this box. To execute the command you typed in, click the radio-button here and then click [SELECT]. If doing a SELECT, UPDATE, or DELETE, you can enter an entire WHERE-clause (minus the word "WHERE") here and select the "PROMPT" button and this will be used as the WHERE clause, IF no fields are specified in the WHERE list. Otherwise, this field is ignored.

It is also used when INSERTing data from a flat-file and using an Oracle SEQUENCE to spcify one or more sequence names separated by commas.

7) Table:

This listbox displays the list of all tables in the database. Click on a table to display it's fields in the "Field" box and to do SQL queries/commands on that table.

8) Field:

This listbox displays all of the fields in the selected table (see "Table") box above. Click on a field to add it to the "Order" box (or "Order By" box), depending on which one has the [Select] button checked. Double-click on a field to place its name in the "SQL:" line above. You select fields for the "Order" box in the order you wish to manipulate them. You can remove a field from the "Order" box by clicking on it there.

For example, if you were working with a table called "employee" and it has four fields: id, name, extension, and salary and you wanted to do something like: select name, extension, id from employee order by id -or- update employee set (name="Joe", entension="12345", id=3) where (id=2) then you would click "name", then "extension", then "id" from the "Field" box, then click the [Select] button under the "Order By" box, then click "id" again from the "Field" box.

NOTE: You do not have to click any field names if all fields are going to be used and in the same order that they appear in the "Field" box. You can now click [SELECT] or [INSERT], depending on which SQL statement you wish to do. If doing INSERT, you will be prompted for the current "id", enter 2. You are then prompted for the "name", "extension", then the new "id".

8) Order:

This box specifies the order in which fields are to be used as arguments in SQL commands. To add field names, click the [Select] button below the "Order" box, then click field names from the "Field" box. To remove a field-name, click that name. If no field names are in the "Order" box, then all field names are used in the order they appear in the "Field" box. If uploading from a delimited flatfile, use the "Order" box to specify the order that the field values appear in each line of the flat-file. To add field names, click the [Select] button below the "Order" box, then click field names from the "Field" box. To remove a field-name, click that name.

9) Where:

This box which fields to prompt for constraint values when doing a SELECT, UPDATE, or DELETE. It is ignored when doing an INSERT. You will not be prompted if the values corresponding to each field in the Where list are specified in the VALUES field separated by the field delimiter. No quotes are needed around string values in either case. To add field names, click the [Select] button below the "Where" box, then click field names from the "Field" box. To remove a field-name, click that name.

10) Order By:

This box specifies the order in which data records are to be sorted when doing a SELECT. (It represents the "ORDER BY" clause of the SELECT statement). When doing an update from a FILE, it represents which fields in the file contain constraint values rather than new data. tTo add field names, click the [Select] button below the "Order By" box, then click field names from the "Field" box. To remove a field-name, click that name.

10) Descend

Check this box, if records are to be sorted in descending order (when doing a SELECT.

11) SELECT

Click this button to execute a query or do an SQL command typed into the "SQL:" line. NOTE: Click the corresponding radio button ("File:", "Where:", or "SQL:". If "File:" or "Where:" is selected, a query will be done on the current table, using the fields specified in the "Order" and "Order By" boxes and results will be displayed in a window on the screen. If "File:" is checked, the results are appended to the specified file". If "SQL:" is checked, whatever sql command is typed into the text box will be performed without regard to any other boxes, fields, or selections.

12) Distinct

Check this checkbox to cause the [SELECT] button to do a SELECT DISTINCT query.

13) INSERT

Click this button to insert data into the current table.

If the "File:" radio-button is selected, the corresponding file is read in as a delimited flat-file and the data inserted into the current table. The records in the file must be delimited by the specified delimiter character(s) or in columns equal to those specified in the FORMAT box; and contain the correct number, datatype, and order of columns corresponding to what is specified in the "Order" box. If using Oracle or Sprite sequences for one or more fields, then headers and values for those fields should NOT be included in the flat-file or specified in the "Order" box, but the fields should be specified in the "Order By" box.

For example, if you were inserting a flat-file into a table called "employee" and it has four fields: id, name, extension, and salary and you wanted to do something like: insert name, extension, and salary, and use a system-generated sequence number for the "id" field; then you would click "name", then "extension", then "salary" from the "Field" box into the "Order" box, then click "id" into the "Order By" box, type in the Oracle sequence name into the "SQL" box - unless the sequence name is the same as the key field - i.e. "id", the click the [Insert] button.

If the "Where:" radio-button is checked, any values entered on the "Values:" line (separated with the user's chosen "Delimiter" character and without quotes) will be inserted into the current table ordered by the field names (if any) specified in the "Order" box. Otherwise, the user is prompted to enter a value for each field name appearing in the "Order" box.

If the "SQL:" radio-button is checked, whatever SQL command typed into the text box will be executed without regard to any other boxes, fields, or selections.

14) UPDATE

Click this button to update data in the current table.

If the "File:" radio-button is selected, the corresponding file is read in as a delimited flat-file and the data updated into the current table. The records in the file must be delimited by the specified delimiter character(s) and contain the correct number, datatype, and order of columns corresponding to what is specified in the "Order" box. Columns whose corresponding fields specified in the Order box, but not in the "Order By" box will have their values overridden by the corresponding values in the file. The values corresponding to the fields in the "Order By" box are used as constraints in a WHERE clause. For example, assuming a flat file "f" contained the following line: "a,b\n" and "f" was specified in the "File:" box, the "Order" box contained "F1,F2", and the "Order By" box contained "F2". Pressing "UPDATE" would execute the following sql:

If the "Where:" radio-button is checked, any values entered on the "Values:" line will be inserted into the current table ordered by the field names (if any) specified in the "Order" box. Otherwise, the user is prompted to enter a value for each field name appearing in the "Order" box. The user will first be prompted to specify the values for any fields specified in the "Where" box for use in generating a "Where" clause, if no values are specified on the "SQL:" box. The "SQL" box is taken as a WHERE clause minus the "where" keyword if no fields are specified in the "Where" box, otherwise, anything in the "SQL" box is taken as a list of constraint values (separated by the field delimiter).

If the "SQL:" radio-button is checked, whatever SQL command typed into the text box will be executed without regard to any other boxes, fields, or selections.

15) DELETE

Click this button to delete data in the current table. To specify a WHERE clause, either enter it on the "SQL:" box or select fields into the "WHERE" box. If field names are in the "WHERE" box, a list of values will be looked for in the "SQL" box, if none found, you will be prompted for values. If no where-clause is specified, a dialog box will appear asking the user if he wishes to delete the entire table. A "YES" answer deletes the whole table.

16) DESCRIBE

Click this button and a window pops up displaying all field names in the current table along with their Oracle datatypes and maximum lengths.

NOTE: The Precision values for numeric types are not shown.

17) Format:

Click this button to create formatted output for the current table or to insert records into the current table from a column-spaced input file. Click it again to clear any format information appearing on the "Format:" line. A series of format specifiers will appear in the box at right, one for each field name in the "Fields" box (or each field, if none selected). NOTE: The "Delimiter" character is changed to the default of "-" if formatting is toggled on and "," if toggled off. The format specifiers are Perl format specifiers in the general format:

@nj -OR- @n#.##

where @ is the "at-sign",

n represents a number of characters, and

j represents justification and is either "<" "#", "|", or ">".

n will be the maximum width of the field minus one (the @ sign represents the 1st character). "<" means left-justify the field, "|"=center, and ">"= right justify. "#.##" represents a right-justified decimal field (used only for "Packed Decimal" fields.

The user can then modify the format string to change column sizes, justification, as well as add other characters to print out amoung the data on each line.

NOTES:

A) Formatting only applies to output (either to the screen or to both the screen and a file, if the "File:" radio-button is checked.) OR to INSERTing records from a column-spaced input flat-file.

B) The "Delimiter" character is used to separate the header line from data lines, instead of separating fields, so the user should usually change the delimiter character from a field delimiter, such as a comma, or a tab, to either a dash or an "=" sign. The delimiter character will be repeated for each character of data line output, for example (Assume the delimiter character is the "=" sign: 

        ID   EMPLOYEE           EXTENSION      SALARY
        ===============================================
         1   Doe, John          11111          12235.00
         2   Smith, Jack        11211          14228.00 ...

C) By default, a form-feed character will be inserted after each 56th line of output (54 records) and the headers reprinted, if the "Headers" box is checked. To change this, enter a numeric value on the "Values:" line. If zero, headers will print once and no formfeeds will be inserted.

D) If inputting records from a column-spaced flat-file, ie. a file produced from formatted output, if the "Header" button is checked, the 1st record in the input file is skipped (assumed to be a header) as are any lines starting with a form-feed (\f). If a field-delimiter is specified, any line containing only spaces and the delimiter character are also skipped. This permits "formatted" files to be fed back in.

E) If inputting records from a column-spaced flat-file, fields specified with the ">" (right-justify) format character will be first stripped of leading spaces before being added to the table. This allows for data written to a "formatted" flat-file via ">" (right-justified) to be read back in properly.

18) Status box:

The actual SQL commands along with any status or error messages are displayed in this box. The user can scroll the box backwards to see a history for this session of the SQL commands/queries he has issued.

NOTE: Each command is committed as it is done! There is no procedure for doing rollbacks.

II) Interactive Record Manipulation, ie. inserts, updates, and deletes.

It is easy to manipulate records within tables interactively. SqlPerl can prompt users for necessary field data via popup windows and then generate the nessessary SQL.

A) Inserting records interactively: To insert a record into a table, do the following:

B) Updating records interactively: To update one or more records in a table, do the following:

C. Deleting records interactively: To delete records from tables interactive do the following:

III) Easy uploading from and downloading to delimited flat-files.

A) Downloading.

SqlPerl permits users to upload data from flat-files into tables and download data from tables into flat-files. All the user needs to do to download data is to click the radio button left of the [File:] button and either enter a file name or browse for an existing one (to be appended to), then do a query (via the [SELECT] button). The user should follow the steps below:

B) Uploading.

To upload data from a delimited flat-file into a table, do the following:

IV) Quick printable report generation with user-selectable formatting.

With SqlPerl, it is easy to produce simple, printable reports of your data using Perl's formatting capabilities. It also makes it easy to display data in nice, smooth columns with headers, etc. To format query output into columnar format, do the following:

V) Quick lookup of tables, fields, and data.

SqlPerl provides quick lookup of data. The names of all tables in the database appear in the "Tables" box when the user logs in". Click on a table name to see all field-names in the table. Click DESCRIBE] to see all field names along with their Oracle datatypes and maximum lengths.

To look up data, simply click fields, select your constraint fields into the "Where" box, use the "Order By" box to specify sort order, and click the [SELECT] button to do a query. You will be prompted for the constraints, which will be "ANDED" together.

Data matching the criteria and selected field-names is displayed in a pop-up window on the screen.

Press the [Format:] button to arrange the data into smooth columns, the "Header:" button to print the field names as headers at the top of the columns, and click the radio-button just left of the [File:] button to save the displayed query results to a text-file for printing (use "Format:") or saving (unformatted, delimited).

V). Minimum System Requirements:

sqlperl/sql.pl0000755000175000001440000060375010475715217013522 0ustar turnerjwusers#!/usr/bin/perl -s #use lib '.'; #STRIP OUT INC PATHS USED IN COMPILATION - COMPILER PUTS EVERYTING IN IT'S OWN #TEMPORARY PATH AND WE DONT WANT THE RUN-TIME PHISHING AROUND THE USER'S LOCAL #MACHINE FOR (POSSIBLY OLDER) INSTALLED PERL LIBS (IF HE HAS PERL INSTALLED)! BEGIN { if ($0 =~ /exe$/i) { while (@INC) { $_ = shift(@INC); push (@myNewINC, $_) if (/(?:cache|CODE)/); } @INC = @myNewINC; } } #NOTE: Windows compile: perl2exe [-gui] -perloptions="-p2x_xbm -s" yourscript.pl # perl2exe_include Tk/balArrow.xbm # perl2exe_include Tk/cbxarrow.xbm $showgrabopt = ''; $showgrabopt = '-nograb'; #UNCOMMENT IF YOU HAVE MY LATEST VERSION OF JDIALOG! #BEGIN { $ENV{DBI_PUREPERL} = 2 }; print "-using DBI::PurePerl!\n" if ($ENV{DBI_PUREPERL}); use Text::Wrap; #LOAD ORAPERL (DBI) STUFF----- $| = 1; $newwhere = 1; #$dbi_err = \$DBI::err; #$dbi_errstr = \$DBI::errstr; #eval 'use Oraperl; 1' || die $@ if $] >= 5; #require "OraPerl.ph"; require "setPalette.pl"; eval 'use File::Spec::Win32; 1'; eval 'use File::Glob; 1'; use DBI; eval 'use DBD::Proxy; 1'; eval 'use DBD::ODBC; 1'; eval 'use DBD::Oracle; 1'; eval 'use DBD::Sprite; 1'; eval 'use DBD::LDAP; 1'; eval 'use RPC::PlClient; 1'; $noexcel = 1; eval 'use Spreadsheet::WriteExcel; $noexcel = 0; 1'; $noexcelin = 1; eval 'use Spreadsheet::ParseExcel::Simple; $noexcelin = 0; 1'; $noxml = 1; #eval 'use XML::Generator::DBI; use XML::Handler::YAWriter; $noxml = 0; 1'; eval 'require MIME::Base64; $noxml = 0; 1'; $newfmt = 0; #eval 'use Text::Autoformat (form); $newfmt = 1; 1'; #THIS THING AINT READY FOR PRIME TIME!!!!!!!!!!!!!!!!!! #####eval 'require "BindMouseWheel.pl"; $WheelMouse = 1; 1'; #----------------------- use Tk; #LOAD TK STUFF use Tk::Radiobutton; use Tk::Checkbutton; use Tk::ROText; use Tk::JDialog; use Tk::JFileDialog; use Tk::JBrowseEntry; use Tk::JOptionmenu; #require 'getopts.pl'; require 'JCutCopyPaste.pl'; $| = 1; $dbname = ''; %themeCodeHash = (); %dbthemes = (); %dbtypes = (); %precmds = (); %attbs = (); $preStatus = ''; #$os = 'WINDOWS NT' unless (defined $os); #$os = 'UNIX' unless (defined $os); $os = $^O; $browser ||= 'start' if ($os =~ /Win/i); $dbtype = 'Oracle' unless (defined $dbtype); $pgmhome = $0; #$pgmhome =~ s#sql\.pl[^/]*$##; $pgmhome =~ s#sql[^/]*$##; #SET NAME TO SQL.PL FOR ORAPERL! print "-pgmhome=$pgmhome=\n"; &loadBrowseChoices; if ($os =~ /Win/i) { $fixedfont = '-*-lucida console-medium-r-normal-*-17-*-*-*-*-*-*-*'; #NT: PC-SPECIFIC. $osslash = "\\"; } elsif ($os =~ /x|solaris/) { #$fixedfont = '-b&h-lucidatypewriter-medium-r-normal-sans-17-120-100-100-m-100-iso8859-1'; #UNIX-SPECIFIC. $fixedfont = '-b&h-lucidatypewriter-medium-r-normal-sans-14-100-100-100-m-80-iso8859-1'; $osslash = '/'; } else { $fixedfont = '-*-courier-medium-r-normal-*-17-*-*-*-*-*-*-*'; #Win-95: PC-SPECIFIC. $osslash = '/'; } $oplist = ['=','!=','like','not like','<','>','<=','>=','is','is not','in']; #$oplist = ['=','!=','like','not like','<','>','<=','>=','is','is not','=~','!~'] if ($sprite); #if ($ARGV[0]) #ALLOWS COMMAND-LINE OF DB INFO (sql.pl dbname dbuser dbpswd) if (0) #WE NO LONGER ALLOW COMMAND-LINE ENTRY FOR SECURITY REASONS :-( { $dbname = $ARGV[0] || ''; $dbuser = $ARGV[1] || ''; $dbpswd = $ARGV[2] || ''; @dbname = split(/:/,$dbname); $dbname = 'T:' . $dbname if ($#dbname == 1); &dbconnect(); $didlogin = 0; #$didlogin = 1 if ($$dbi_err == 0); $didlogin = 1 unless (DBI->err); #$didlogin = 1; &mainstuff if ($didlogin); &exitFn(); exit (0); } my $vsn = '4.8'; my $headTitle = 'SqlPerl Plus, v. '.$vsn; my $helpurl = 'http://home.mesh.net/turnerjw/jim/sqlperl.html'; my ($OK, $Cancel) = ('~OK', '~Cancel'); &loginWindow(); #MainLoop; sub loginWindow { $MainWin->destroy if ($MainWin); $dB->disconnect if ($dB); $MainWin = MainWindow->new; $MainWin->title($headTitle); #FETCH ANY USER-SPECIFIC OPTIONS FROM sql.ini: $_ = $0; s/(\w+)\.\w+$/$1\.ini/g; if (open PROFILE, $_) { while () { chomp; s/[\r\n\s]+$//; s/^\s+//; next if (/^\#/); ($opt, $val) = split(/\=/, $_, 2); ${$opt} = $val if ($opt); } close PROFILE; } $c = $palette if ($palette); unless ($c) { if ($os =~ /Win/i) { if (open (T, ".Xdefaults") || open (T, "$ENV{HOME}/.Xdefaults") || open (T, "${pgmhome}Xdefaults") || open (T, "/etc/Xdefaults")) { while () { chomp; if (/tkPalette\s*\=\s*\"([^\"]+)\"/) { $c = $1; last; } } } } else { eval { $MainWin->optionReadfile('~/.Xdefaults') or $MainWin->optionReadfile('/etc/Xdefaults'); }; $c = $MainWin->optionGet('tkPalette','*'); } } $MainWin->setPalette($c) if ($c); $listheight = $lh || 8; $msgheight = $mh || 8; $sqlheight = $sh || 3; $fmtmax = $fmt || 6; $topLabel = $MainWin->Label(-text => 'Log onto desired database:'); $topLabel->pack( -fill => 'x', -expand => 'yes', -padx => '2m', -pady => '2m'); $bottomFrame = $MainWin->Frame; $lognbtnFrame = $bottomFrame->Frame; $lognlbl = $bottomFrame->Frame; $lognlbl->pack( -side => 'top', -fill => 'x', -padx => '2m', -pady => '2m'); $lognbtnFrame->pack( -side => 'bottom', -fill => 'x', -padx => '2m', -pady => '2m'); $sysidFrame = $bottomFrame->Frame; $sysidFrame->pack( -side => 'left', -fill => 'x', -padx => '2m', -pady => '2m'); $dbnameFrame = $bottomFrame->Frame; $dbnameFrame->pack( -side => 'left', -fill => 'x', -padx => '2m', -pady => '2m'); $pswdFrame = $bottomFrame->Frame; $pswdFrame->pack( -side => 'left', -fill => 'x', -padx => '2m', -pady => '2m'); $sysidLabel = $sysidFrame->Label(-text => 'Database'); $sysidLabel->pack(-side => 'top', -fill => 'x', -padx=>'2m'); $sysidText = $sysidFrame->JBrowseEntry( -btntakesfocus => 0, -variable => \$dbname, -browsecmd => sub { $dbtype = $dbtypes{$dbname} if ($dbtypes{$dbname}) }, -width => 12); $sysidText->pack( -side => 'bottom', -expand => 'yes', -padx => '2m', -pady => '2m', -fill => 'x'); $dbnameLabel = $dbnameFrame->Label(-text => 'User'); $dbnameLabel->pack(-side => 'top', -fill => 'x', -padx=>'2m'); #$dbnameText = $dbnameFrame->Entry( # -relief => 'sunken', # -width => 12); $dbnameText = $dbnameFrame->JBrowseEntry( -btntakesfocus => 0, -variable => \$dbuser, -browsecmd => sub { $dbtype = $dbtypes{$dbuser} if ($dbtypes{$dbuser}) }, -width => 12); $dbnameText->pack( -side => 'bottom', -expand => 'yes', -padx => '2m', -pady => '2m', -fill => 'x'); #NEXT LINE ADDED 20040819 TO ALLOW CAPTURE OF DBNAME FOR COPYING TO PASSWORD. $dbnameText->bind('' => sub {$MainWin->clipboardAppend('--',$dbuser);}); $pswdLabel = $pswdFrame->Label(-text => 'Password'); $pswdLabel->pack(-side => 'top', -fill => 'x', -padx => '2m'); $pswdText = $pswdFrame->Entry( -show => '*', -relief => 'sunken', -width => 12); $pswdText->pack( -side => 'bottom', -expand => 'yes', -padx => '2m', -pady => '2m', -fill => 'x'); $lognokButton = $lognbtnFrame->Button( -padx => 11, -pady => 4, -text => 'Ok', -underline => 0, -command => [\&dologin]); $lognokButton->pack(-side=>'left', -expand=>1, -padx=>'2m', -pady=>'2m'); $logncanButton = $lognbtnFrame->Button( -padx => 11, -pady => 4, -text => 'Exit', -underline => 0, -command => [\&exit]); $logncanButton->pack(-side=>'left', -expand=>1, -padx=>'2m', -pady=>'2m'); $lognHelpButton = $lognbtnFrame->Button( -padx => 11, -pady => 4, -text => 'Help', -underline => 0, -command => [\&About]); $lognHelpButton->pack(-side=>'left', -expand=>1, -padx=>'2m', -pady=>'2m'); $bottomFrame2 = $MainWin->Frame; #$dbtypeLabel = $bottomFrame2->Label( # -text => 'Database Type: '); #$dbtypeLabel->pack(-side => 'left'); my (@dbidrivers) = DBI->available_drivers(); my (%dbidrivers); foreach my $i (@dbidrivers, qw(Sprite mysql Oracle ODBC LDAP)) { ++$dbidrivers{$i}; } $dbtypeOpMenu = $bottomFrame2->JBrowseEntry( -label => 'Database Type', -variable => \$dbtype, -state => 'readonly', #-tabcomplete => 1, #-noselecttext => 1, -width => 12, -choices => [sort keys(%dbidrivers)]); $dbtypeOpMenu->pack(-side => 'left'); $attbFrame = $MainWin->Frame; $attbLabel = $attbFrame->Label(-text => 'Attributes:'); $attbLabel->pack(-side => 'left'); $attbText = $attbFrame->Entry( -relief => 'sunken', -width => 40); $attbText->pack( -side => 'left', -expand => 'yes', -padx => '2m', -pady => '2m', -fill => 'x'); $bottomFrame3 = $MainWin->Frame; $rhostLabel = $bottomFrame3->Label( -text => 'Remote Host:port'); $rhostLabel->pack(-side => 'left'); $rhostEntry = $bottomFrame3->JBrowseEntry( -btntakesfocus => 0, -variable => \$rhost, -width => 40) ->pack( -side => 'left', -padx => '1m', -pady => '4m'); $statusFrame = $MainWin->Frame; $statusText = $statusFrame->ROText( -width => $msgheight, -height => 4); $statusText->bind('' => [\&textfocusin]); &BindMouseWheel($statusText) if ($WheelMouse); $statusScrollY = $statusFrame->Scrollbar( -relief => 'sunken', -orient => 'vertical', -command=> [$statusText => 'yview']); $statusText->configure(-yscrollcommand=>[$statusScrollY => 'set']); $statusScrollY->pack( -side => 'right', -fill => 'y'); $statusText->pack( -side => 'top', -expand => 'yes', -fill => 'both'); ## tie (*STDERR, 'Tk::ROText', $statusText); #ADDED 20000224 SO I CAN SEE ERRORS! REMOVED 20060512 (STDERR PRODUCED TOO MUCH NOISE!) $statusText->see('end'); $statusFrame->pack( -side => 'bottom', -expand => 'yes', -fill => 'both'); $bottomFrame->pack(-side => 'top'); $bottomFrame3->pack(-side => 'bottom'); $attbFrame->pack(-side => 'bottom'); $bottomFrame2->pack(-side => 'bottom'); my $foundAlready = 0; for ($i=0;$i<=$#dbnames;$i++) { $sysidText->insert('end',$dbnames[$i]); $foundAlready = 1 if ($dbname && $dbnames[$i] eq $dbname); } unless ($foundAlready) { if ($dbname) { $sysidText->insert('end',$dbname); push (@dbnames, $dbname); } } $foundAlready = 0; for ($i=0;$i<=$#dbusers;$i++) { $dbnameText->insert('end',$dbusers[$i]); $foundAlready = 1 if ($dbuser && $dbusers[$i] eq $dbuser); } unless ($foundAlready) { if ($dbuser) { $dbnameText->insert('end',$dbuser); push (@dbusers, $dbuser); } } $foundAlready = 0; for ($i=0;$i<=$#rhosts;$i++) { $rhostEntry->insert('end',$rhosts[$i]); $foundAlready = 1 if ($rhost && $rhosts[$i] eq $rhost); } unless ($foundAlready) { if ($rhost) { $rhostEntry->insert('end',$rhost); push (@rhosts, $rhost); } } $sysidText->configure(-state => 'textonly') unless ($#dbnames >= 0); $dbnameText->configure(-state => 'textonly') unless ($#dbusers >= 0); $rhostEntry->configure(-state => 'textonly') unless ($#rhosts >= 0); $MainWin->update; $logncanButton->bind('' => "Invoke"); $lognokButton->bind('' => "Invoke"); #$MainWin->bind('' => [$lognokButton => "Invoke"]); #$MainWin->bind('' => [$logncanButton => "Invoke"]); bind('' => [$logncanButton => "Invoke"]); #$dbtypeOpMenu->bind('' => sub {shift->PostFirst; Tk->break;}); #$dbtypeOpMenu->bind('' => [$lognokButton => "Invoke"]); #$rhostEntry->bind('' => [$lognokButton => "Invoke"]); ####$MainWin->bind('' => [$lognokButton => "Invoke"]); ####$MainWin->bind('' => [$logncanButton => "Invoke"]); $pswdText->bind('' => [$lognokButton => "Invoke"]); $pswdText->bind('' => [$logncanButton => "Invoke"]); $attbText->bind('' => [$lognokButton => "Invoke"]); $attbText->bind('' => [$logncanButton => "Invoke"]); $sysidText->focus; $sysidText->selectionRange(0,'end'); $usefmt = 0; $newwhere = 1; MainLoop; } sub mainstuff { $MainWin->destroy if ($MainWin); $MainWin = MainWindow->new; $MainWin->setPalette($c) if ($c); $mainTitle = "$headTitle (DBD $dbtype): database:\"$rhostname$dbname\", user->$dbuser."; $MainWin->title($mainTitle); $orderSel = 'order'; $use = 'line'; $myfmt = ''; my $w_menu = $MainWin->Frame(-relief => 'raised', -borderwidth => 2); $w_menu->pack(-fill => 'x'); $fileMenubtn = $w_menu->Menubutton(-text => 'File', -underline => 0, -takefocus => 1); $fileMenubtn->command(-label => 'Alter table...', -underline =>0, -command => [\&altertable]); $fileMenubtn->command(-label => 'Break', -underline =>0, -command => sub {$abortit = 1;}); $fileMenubtn->command(-label => 'Create(setup)', -underline =>0, -command => [\&dodescribe,3]); $fileMenubtn->command(-label => 'Describe', -underline =>0, -command => \&dodescribe); $fileMenubtn->command(-label => 'Edit', -underline =>0, -command => \&editfid); $fileMenubtn->command(-label => 'Fields', -underline =>0, -command => [\&dodescribe,2]); $fileMenubtn->command(-label => 'field Names', -underline =>6, -command => [\&dodescribe,1]); $fileMenubtn->command(-label => 'Insert file', -underline =>0, -command => [\&insertfile]); $fileMenubtn->command(-label => 'Load Columns', -underline =>0, -command => \&loadcols); $fileMenubtn->command(-label => 'Process SQL File', -underline =>0, -command => \&doprocess); #ADDED 20030703. $fileMenubtn->command(-label => 'Xeq SQL File', -underline =>0, -command => \&doxeq); #ADDED 20030703. $fileMenubtn->command(-label => 'Reload', -underline =>0, -command => \&loadtable); $fileMenubtn->command(-label => 'Sprite', -underline =>0, -command => \&doSprite); $fileMenubtn->command(-label => 'M$-Excel', -underline =>1, -command => \&doExcel); # $fileMenubtn->cascade(-label => 'Use', -menuitems => [ if ($#usedbs >= 0) { my @usemenuItems = (); my ($usedb, $usetheme); for (my $i=0;$i<=$#usedbs;$i++) { $usedb = $usedbs[$i]; $usetheme = ($usedb =~ s/\:(.*)//) ? $1 : ''; push (@usemenuItems, [Button => $usedb, -command => [\&doUseDB, $usedb, $usetheme]]); } $fileMenubtn->cascade(-label => 'Use', -menuitems => \@usemenuItems); } $fileMenubtn->command(-label => 'XML', -command => \&doXML); $fileMenubtn->entryconfigure('M$-Excel', -state => 'disabled') if ($noexcel); $fileMenubtn->entryconfigure('XML', -state => 'disabled') if ($noxml); $fileMenubtn->separator; $fileMenubtn->command(-label => 'Login New', -underline =>0, -command => \&loginWindow); $fileMenubtn->command(-label => 'eXit', -underline =>1, -command => \&exitFn); my $editMenubtn = $w_menu->Menubutton(-text => 'Edit', -underline => 0); $editMenubtn->command(-label => 'Clear', -underline =>4, -command => \&clearFn); $editMenubtn->separator; $editMenubtn->command(-label => 'Copy', -underline =>0, -command => [\&doCopy]); $editMenubtn->command(-label => 'cuT', -underline =>2, -command => [\&doCut]); $editMenubtn->command(-label => 'Paste (Clipboard)', -underline =>0, -command => [\&doPaste,'CLIPBOARD']); $editMenubtn->command(-label => 'Paste (Primary)', -underline =>8, -command => [\&doPaste,'PRIMARY']); if (open (T, ".myethemes") || open (T, "$ENV{HOME}/.myethemes") || open (T, "${pgmhome}myethemes")) { $themeMenuBtn = $w_menu->Menubutton( -text => 'Themes'); my ($themename, $themecode); while () { chomp; ($themename, $themecode) = split(/\:/); $themeCodeHash{$themename} = $themecode; eval "\$themeMenuBtn->command(-label => '$themename', -command => sub {&setTheme($themename);});"; } close T; } my $globalUseThisTheme = $dbthemes{$dbuser} || $dbthemes{$dbname} || $dbthemes{$dbtype}; &setTheme($globalUseThisTheme); $startfpath = $ENV{PWD} || $ENV{HOME}; if (open (T, "$ENV{HOME}.sqlfpath.dat")) { $startfpath = ; chomp($startfpath); close T; } $startfpath = '.' unless ($startfpath =~ /\S/); $commitMenubtn = $w_menu->Menubutton(-text => 'Commit', -underline => 0); $commitMenubtn->command(-label => 'Commit', -underline =>0, -command => [\&docommit]); $commitMenubtn->command(-label => 'Rollback', -underline =>0, -command => [\&dorollback]); $commitMenubtn->separator; $commitMenubtn->command(-label => 'Auto commit', -underline =>0, -command => sub { $dB->{AutoCommit} = 1; $nocommit = 2; $commitButton->configure(-text => 'Autocommit', -state => 'disabled'); } ); $commitMenubtn->command(-label => 'Force commit', -underline =>0, -command => sub { $dB->{AutoCommit} = 0; # unless $autocommit; $nocommit = 0; $commitButton->configure(-text => 'Committed', -state => 'disabled'); } ); $commitMenubtn->command(-label => 'Manual commit', -underline =>0, -command => sub { $dB->{AutoCommit} = 0; # unless $autocommit; $nocommit = 1; $commitButton->configure(-text => 'COMMIT!', -state => 'normal'); } ); $commitMenubtn->configure(-state => 'disabled') if ($autocommit); my $helpMenubtn = $w_menu->Menubutton(-text => 'help', -underline => 0); $helpMenubtn->command(-label => 'About', -underline =>0, -command => \&About); if ($browser) { $helpMenubtn->command(-label => 'Help', -underline =>0, -command => sub { system($browser, $helpurl); } ); } $fileMenubtn->pack(-side=>'left'); $editMenubtn->pack(-side=>'left'); $themeMenuBtn->pack(-side=>'left') if (defined $themeMenuBtn); $commitMenubtn->pack(-side=>'left'); $helpMenubtn->pack(-side=>'right'); my $topFrame = $MainWin->Frame; my $sqlrbtnFrame = $topFrame->Frame; $sqlrbtnFrame->Radiobutton( -text => '', -highlightthickness => 0, -variable=> \$use, -value => 'file')->pack(-fill => 'y', -expand => 'yes'); $sqlrbtnFrame->Radiobutton( -text => '', -highlightthickness => 0, -variable=> \$use, -value => 'line')->pack(-fill => 'y', -expand => 'yes'); $sqlrbtnFrame->Radiobutton( -text => '', -highlightthickness => 0, -variable=> \$use, -value => 'sql')->pack(-fill => 'y', -expand => 'yes'); $sqlrbtnFrame->pack(-side => 'left', -fill => 'y', -expand => 'no'); my $toprFrame = $topFrame->Frame; my $fileFrame = $toprFrame->Frame; $fileButton = $fileFrame->Button( -text => 'File:', -command => [\&getfile]); $fileButton->pack( -side => 'left', -expand => 'no'); $fileText = $fileFrame->Entry( -relief => 'sunken', -width => 30); $fileText->bind('' => [\&textfocusin]); $fileText->pack( -side => 'left', -expand => 'yes', -fill => 'x'); my $delimLabel = $fileFrame->Label(-text=>' Delimiters: Field:'); $delimLabel->pack(-expand => 'no', -side => 'left', -padx => '1m'); $delimText = $fileFrame->Entry( -relief => 'sunken', -width => 6); $delimText->bind('' => [\&textfocusin]); $delimText->pack( -side => 'left', -expand => 'no', -fill => 'x'); my $rdelimLabel = $fileFrame->Label(-text=>' Rec:'); $rdelimLabel->pack(-expand => 'no', -side => 'left', -padx => '1m'); $rdelimText = $fileFrame->Entry( -relief => 'sunken', -width => 6); $rdelimText->bind('' => [\&textfocusin]); $rdelimText->pack( -side => 'left', -expand => 'no', -fill => 'x'); my $adelimLabel = $fileFrame->Label(-text=>' Args:'); $adelimLabel->pack(-expand => 'no', -side => 'left', -padx => '1m'); $adelimText = $fileFrame->Entry( -relief => 'sunken', -width => 6); $adelimText->bind('' => [\&textfocusin]); $adelimText->pack( -side => 'left', -expand => 'no', -fill => 'x'); $headerCbtn = $fileFrame->Checkbutton( -text => 'Header', -variable=> \$headers); $headerCbtn->pack( -side => 'left', -padx => '4m'); $fileFrame->pack(-side => 'top', -fill => 'x', -expand => 'yes'); my $wvtextFrame = $toprFrame->Frame; my $whereLabel = $wvtextFrame->Label(-text=>'Prompt'); $whereLabel->pack(-side => 'left'); my $valusLabel = $wvtextFrame->Label(-text=>' Values:'); $valusLabel->pack(-side => 'left'); $valusText = $wvtextFrame->Entry( -relief => 'sunken', -width => 72); $valusText->bind('' => [\&textfocusin]); $valusText->pack( -side => 'left', -expand => 'yes', -fill => 'x'); $valusLabel->pack(-side => 'left'); $wvtextFrame->pack( -side => 'top', -expand => 'yes', -fill => 'x'); my $sqlboxFrame = $toprFrame->Frame; my $sqlLabel = $sqlboxFrame->Label(-text=>'SQL: '); $sqlLabel->pack(-side => 'left'); $sqlText = $sqlboxFrame->Text( -height => $sqlheight); $sqlText->bind('' => [\&textfocusin]); $sqlScrollY = $sqlboxFrame->Scrollbar( -relief => 'sunken', -orient => 'vertical', -command=> [$sqlText => 'yview']); $sqlText->configure(-yscrollcommand=>[$sqlScrollY => 'set']); $sqlScrollY->pack( -side => 'right', -fill => 'y'); $sqlText->pack( -side => 'left', -expand => 'yes', -fill => 'both'); $sqlboxFrame->pack(-side => 'top', -fill => 'both', -expand => 'x'); $toprFrame->pack(-side => 'left', -expand => 'yes', -fill => 'x'); $topFrame->pack(-side => 'top', -expand => 'no', -fill => 'x'); $statusFrame = $MainWin->Frame; $statusText = $statusFrame->ROText( -height => $msgheight); $statusText->bind('' => [\&textfocusin]); &BindMouseWheel($statusText) if ($WheelMouse); $statusScrollY = $statusFrame->Scrollbar( -relief => 'sunken', -orient => 'vertical', -command=> [$statusText => 'yview']); $statusText->configure(-yscrollcommand=>[$statusScrollY => 'set']); $statusScrollY->pack( -side => 'right', -fill => 'y'); $statusText->pack( -side => 'top', -expand => 'yes', -fill => 'both'); ## tie (*STDERR, 'Tk::ROText', $statusText); #ADDED 20000224 SO I CAN SEE ERRORS! $statusText->insert('end', $preStatus); $statusText->see('end'); $statusFrame->pack( -side => 'bottom', -expand => 'yes', -fill => 'both'); $fmtFrame = $MainWin->Frame; $fmtFrame->Label( -text => 'Format:'); $fmtButton = $fmtFrame->Button( #-padx => '2m', -text => 'Format:', -command => [\&setdfltfmt]); my $fmtTextWidth = 48; $fmtTextWidth = 80 unless ($os =~ /x|solaris/); $fmtText = $fmtFrame->JBrowseEntry( #-height => 6, -variable => \$myfmt, #-tabcomplete => 1, -browsecmd => sub {$fmtTextSel = $myfmt;}, -width => $fmtTextWidth); $fmtText->Subwidget('entry')->bind('' => [\&textfocusin]); $fmtButton->pack(-side => 'left'); $fmtText->pack( -side => 'left', -expand => 'yes', -fill => 'x'); $fmtFrame->pack( -side => 'bottom', -fill => 'x', -padx => '2m'); my $btnsFrame = $MainWin->Frame; $abortButton = $btnsFrame->Button( -text => 'BREAK', -underline => 0, -command=> sub {$abortit = 1;}); $abortButton->pack( -side => 'left', -expand => 1); my $selbtnsFrame = $btnsFrame->Frame; $selectButton = $selbtnsFrame->Button( -text => 'SELECT', -underline => 0, #-command=> [\&doselect]); -command=> sub {$doexcel = 0; $doxml = 0; &doselect;}); $selectButton->pack( -side => 'left', -expand => 1); $distinctButton = $selbtnsFrame->Checkbutton( -text => 'Distinct', #-highlightthickness => 0, -variable => \$distinct); $distinctButton->pack( -side => 'left'); $selbtnsFrame->pack( -side => 'left', -expand => 1); $commitButton = $btnsFrame->Button( -text => 'COMMIT!', -underline => 0, -command=> [\&docommit]); $commitButton->pack( -side => 'left', -expand => 1); $insertButton = $btnsFrame->Button( -text => 'INSERT', -underline => 0, -command=> [\&doinsert]); $insertButton->pack( -side => 'left', -expand => 1); $updateButton = $btnsFrame->Button( -text => 'UPDATE', -underline => 0, -command=> [\&doupdate]); $updateButton->pack( -side => 'left', -expand => 1); $deleteButton = $btnsFrame->Button( -text => 'DELETE', -underline => 0, -command=> [\&dodelete]); $deleteButton->pack( -side => 'left', -expand => 1); $describeButton = $btnsFrame->Button( -text => 'DESCRIBE', -underline => 3, -command=> [\&dodescribe]); $describeButton->pack( -side => 'left', -expand => 1); $btnsFrame->pack( -side => 'bottom', -fill => 'x'); my $selectFrame = $MainWin->Frame; my $tableFrame = $selectFrame->Frame; $tableHead = $tableFrame->Label( -text => 'Table', -relief => 'sunken'); $tableTail = $tableFrame->Label( -text => '', -relief => 'flat'); $tableList = $tableFrame->Scrolled('Listbox', -scrollbars => 'se', -width => 16, -height => $listheight, -relief => 'sunken', -exportselection => 0, -selectmode => 'browse'); &BindMouseWheel($tableList) if ($WheelMouse); $tableHead->pack(-side => 'top', -fill => 'x', -expand => 'yes'); $tableTail->pack(-side => 'bottom', -fill => 'x', -expand => 'yes'); $tableList->pack(-side => 'right', -fill => 'both', -expand => 'yes'); my $fieldFrame = $selectFrame->Frame; $fieldHead = $fieldFrame->Label( -text => 'Field', -relief => 'sunken'); $fieldTail = $fieldFrame->Label( -text => '', -relief => 'flat'); $fieldList = $fieldFrame->Scrolled('Listbox', -scrollbars => 'se', -width => 16, -height => $listheight, -relief => 'sunken', -selectmode => 'browse'); #$fieldScrollY = $fieldFrame->Scrollbar( # -relief => 'sunken', # -orient => 'vertical', # -command=> [$fieldList => 'yview']); #$fieldList->configure(-yscrollcommand=>[$fieldScrollY => 'set']); &BindMouseWheel($fieldList) if ($WheelMouse); $fieldHead->pack(-side => 'top', -fill => 'x', -expand => 'yes'); $fieldTail->pack(-side => 'bottom', -fill => 'x', -expand => 'yes'); #$fieldScrollY->pack( # -side => 'right', # -fill => 'y'); $fieldList->pack(-side => 'right', -fill => 'both', -expand => 'yes'); my $whereFrame = $selectFrame->Frame; $whereHead = $whereFrame->Label( -text => 'where', -relief => 'sunken'); $whereList = $whereFrame->Scrolled('Listbox', -scrollbars => 'se', -width => 16, -height => $listheight, -relief => 'sunken', -selectmode => 'browse'); $whereRbtn = $whereFrame->Radiobutton( -text => 'Select', -highlightthickness => 0, -variable=> \$orderSel, -value => 'where'); &BindMouseWheel($whereList) if ($WheelMouse); $whereHead->pack(-side => 'top', -fill => 'x', -expand => 'yes'); $whereRbtn->pack( -side => 'bottom', -fill => 'x', -expand => 'yes'); $whereList->pack(-side => 'right', -fill => 'both', -expand => 'yes'); my $orderFrame = $selectFrame->Frame; $orderHead = $orderFrame->Label( -text => 'Order', -relief => 'sunken'); $orderList = $orderFrame->Scrolled('Listbox', -scrollbars => 'se', -width => 16, -height => $listheight, -relief => 'sunken', -selectmode => 'browse'); &BindMouseWheel($orderList) if ($WheelMouse); $orderRbtn = $orderFrame->Radiobutton( -text => 'Select', -highlightthickness => 0, -variable=> \$orderSel, -value => 'order'); $orderHead->pack(-side => 'top', -fill => 'x', -expand => 'yes'); $orderRbtn->pack( -side => 'bottom', -fill => 'x', -expand => 'yes'); $orderList->pack(-side => 'right', -fill => 'both', -expand => 'yes'); my $ordbyFrame = $selectFrame->Frame; $ordbyHead = $ordbyFrame->Label( -text => 'Order By', -relief => 'sunken'); $ordbyList = $ordbyFrame->Scrolled('Listbox', -scrollbars => 'se', -width => 16, -height => $listheight, -relief => 'sunken', -selectmode => 'browse'); &BindMouseWheel($ordbyList) if ($WheelMouse); $ordbyHead->pack(-side => 'top', -fill => 'x', -expand => 'yes'); my $ordbybtnFrame = $ordbyFrame->Frame; $ordbyRbtn = $ordbybtnFrame->Radiobutton( -text => 'Select', -highlightthickness => 0, -variable=> \$orderSel, -value => 'ordby'); $ordbyCbtn = $ordbybtnFrame->Checkbutton( -text => 'Descend', -highlightthickness => 0, -variable=> \$descorder); $ordbyRbtn->pack( -side => 'left', -fill => 'x', -expand => 'yes'); $ordbyCbtn->pack( -side => 'left', -fill => 'x', -expand => 'yes'); $ordbybtnFrame->pack( -side => 'bottom', -fill => 'x', -expand => 'yes'); $ordbyList->pack(-side => 'right', -fill => 'both', -expand => 'yes'); $tableFrame->pack( -side => 'left', -fill => 'both', -expand => 'yes'); $fieldFrame->pack( -side => 'left', -fill => 'both', -expand => 'yes'); $orderFrame->pack( -side => 'left', -fill => 'both', -expand => 'yes'); $whereFrame->pack( -side => 'left', -fill => 'both', -expand => 'yes'); $ordbyFrame->pack( -side => 'left', -fill => 'both', -expand => 'yes'); $selectFrame->pack( -side => 'left', -expand => 'yes', -fill => 'x'); $DIALOG1 = $MainWin->JDialog( -title => 'Attention', -text => '', -bitmap => 'error', -default_button => $Ok, -escape_button => $Ok, -buttons => [$OK], ); $DIALOG2 = $MainWin->JDialog( -title => 'Are you Sure?', -text => '', -bitmap => 'info', -default_button => $Cancel, -escape_button => $Cancel, -buttons => [$OK, $Cancel], ); $OkAll = 'Ok~All'; $DIALOG3 = $MainWin->JDialog( -title => 'Attention!', -text => 'Everything look ok to commit?', -bitmap => 'questhead', -default_button => $Cancel, -escape_button => $Cancel, -buttons => [$OK, $OkAll, $Cancel], ); $fieldList->bind('' => [\&fieldClickFn]); $fieldList->bind('' => [\&fieldDclickFn]); $fieldList->bind('' => [\&fieldClickFn,1]); $whereList->bind('' => [\&whereClickFn]); $whereList->bind('' => [\&whereClickFn,1]); $orderList->bind('' => [\&orderClickFn]); $orderList->bind('' => [\&orderClickFn,1]); $tableList->bind('' => [\&tableClickFnP]); $tableList->bind('' => [\&tableClickFn]); $tableList->bind('' => [\&tableDclickFn]); $tableList->bind('' => [\&tableClickFn,1]); $ordbyList->bind('' => [\&ordbyClickFn,1]); $ordbyList->bind('' => [\&ordbyClickFn]); # $MainWin->bind('' => [$describeButton => "Invoke"]); # $MainWin->bind('' => [$deleteButton => "Invoke"]); # $MainWin->bind('' => [$insertButton => "Invoke"]); # $MainWin->bind('' => [$selectButton => "Invoke"]); # $MainWin->bind('' => [$updateButton => "Invoke"]); if ($os =~ /Win/i) { $tableList->bind('', sub { $MainWin->bind('', [ sub { $tableList->xview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); $MainWin->bind('', [ sub { $tableList->yview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); }); $tableList->bind('', sub { $MainWin->bind('', sub { }) ; $MainWin->bind('', sub { }) }); $fieldList->bind('', sub { $MainWin->bind('', [ sub { $fieldList->xview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); $MainWin->bind('', [ sub { $fieldList->yview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); }); $fieldList->bind('', sub { $MainWin->bind('', sub { }) ; $MainWin->bind('', sub { }) }); $whereList->bind('', sub { $MainWin->bind('', [ sub { $whereList->xview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); $MainWin->bind('', [ sub { $whereList->yview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); }); $whereList->bind('', sub { $MainWin->bind('', sub { }) ; $MainWin->bind('', sub { }) }); $orderList->bind('', sub { $MainWin->bind('', [ sub { $orderList->xview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); $MainWin->bind('', [ sub { $orderList->yview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); }); $orderList->bind('', sub { $MainWin->bind('', sub { }) ; $MainWin->bind('', sub { }) }); $ordbyList->bind('', sub { $MainWin->bind('', [ sub { $ordbyList->xview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); $MainWin->bind('', [ sub { $ordbyList->yview('scroll',-($_[1]/120)*1,'units') }, Tk::Ev("D")]); }); $ordbyList->bind('', sub { $MainWin->bind('', sub { }) ; $MainWin->bind('', sub { }) }); } #NEXT 11 LINES ADDED 20030920 TO SUPPORT A "READONLY" MODE! $readonly = $r || 0; unless (!$readonly && (-e "$ENV{HOME}/.sqlrw" || -e "${pgmhome}/.sqlrw")) { $deleteButton->configure(-state => 'disabled'); $insertButton->configure(-state => 'disabled'); $updateButton->configure(-state => 'disabled'); $commitButton->configure(-state => 'disabled'); $commitMenubtn->configure(-state => 'disabled'); $fileMenubtn->entryconfigure('Alter table...', -state => 'disabled'); $readonly = 1; } $delimText->insert('end',','); $adelimText->insert('end',';'); $rdelimText->insert('end','\n'); $commitButton->configure(-state => 'disabled') unless ($nocommit); &loadtable; &loadoldfmts; $commitButton->configure(-text => 'Autocommit', -state => 'disabled') if ($dB->{AutoCommit}); MainLoop; } #----------------------------------------------------------------------- sub dologin { #$dbname = $sysidText->get; @dbname = split(/:/,$dbname); $dbname = 'T:' . $dbname if ($#dbname == 1); #$dbuser = $dbnameText->get; $dbpswd = $pswdText->get; &dbconnect(); my @mycmds; if ($#{$precmds{$dbuser}} >= 0) { @mycmds = @{$precmds{$dbuser}}; } elsif ($#{$precmds{$dbname}} >= 0) { @mycmds = @{$precmds{$dbname}}; } elsif ($#{$precmds{$dbtype}} >= 0) { @mycmds = @{$precmds{$dbtype}}; } my $res; $preStatus = ''; $didlogin = 0; #$didlogin = 1 if ($$dbi_err == 0); if ($dB && !$DBI::err) { foreach my $i (@mycmds) { $res = $dB->do($i) or $preStatus .= "..INIT ERROR: ".$dB->err.':'.$dB->errstr; $res = '' unless (defined $res); $preStatus .= "..INIT DID: $i; result = $res.\n"; } $didlogin = 1; } &mainstuff if ($didlogin); # exit (0) unless ($didlogin); #ADDED CONDITION FOR TK8 TO STOP EXITING! } sub dbconnect { my ($mydbname) = $dbname; $attb = $attbText->get || $attbs{$dbuser} || $attbs{$dbname} || $attbs{$dbtype}; #if ($dbtype eq 'Sprite' && $os =~ /Win/i) #SPECIAL KLUDGE JUST FOR ME. #SHOULDN'T NEED ANYMORE (FIXED SPRITE)! #{ # unless ($attb =~ /PrintWarn/) # { # $attb .= ',' if ($attb); # $attb .= 'PrintWarn => 0'; # } #} { $oplist = ['=','!=','like','not like','<','>','<=','>=','is','is not','=^','!^','in']; $sprite = 1; } if ($rhost =~ /\S/) { if ($rhost =~ s/^mysql\://) { $connectstr = "dbi:mysql:database=$mydbname;host=$rhost"; print "-MYSQL REMOTE- connectstr=$connectstr= user=$dbuser= pswd=****= sid=$ENV{ORACLE_SID}= TT=$ENV{TWO_TASK}=\n"; } else { $rhostname = $rhost; $rhostname = $1 if ($rhostname =~ /(.*)\:/); $rhostname .= ':'; $rhost =~ s/:/;port=/; ########$mydbname = '' if ($dbtype eq 'Oracle'); $connectstr = "dbi:Proxy:hostname=$rhost;dsn=DBI:$dbtype:$mydbname"; print "-PROXY connectstr=$connectstr= user=$dbuser= pswd=****= sid=$ENV{ORACLE_SID}= TT=$ENV{TWO_TASK}=\n"; print "-connect($connectstr,$dbuser,****)\n"; } #$dB=DBI->connect($connectstr,$dbuser,$dbpswd) $_ = ''; eval "\$dB=DBI->connect('$connectstr','$dbuser','$dbpswd',{$attb})"; &show_err("-no login: ".($_ ? $_ : ("err=".DBI->err.':'.DBI->errstr))) unless ($dB); # || die \"-no login: err=\".DBI->err.':'.DBI->errstr;"; # &show_err("-no login: err=$_") if ($_ && !$dB); } else { if ($dbtype eq 'Oracle') { $ENV{ORACLE_HOME} ||= '/home1/oracle/app/oracle/product/7.3.2'; $mydbname = ''; if ($dbname =~ s/^sid=(\w+)$/$1/i) { $ENV{ORACLE_SID} = $dbname; $ENV{TWO_TASK} = ''; } elsif ($dbname =~ s/^tt=(\w+)$/$1/i) { $ENV{ORACLE_SID} = ''; $ENV{TWO_TASK} = $dbname; } elsif ($dbname =~ s/^db=(\w+)$/$1/i) { $ENV{ORACLE_SID} = ''; $ENV{TWO_TASK} = ''; $mydbname = $1; } else { $ENV{ORACLE_SID} = $dbname; $ENV{TWO_TASK} = $dbname; } } # elsif ($dbtype eq 'Pg') # { # $dbname = 'dbname='.$dbname unless ($dbname =~ /\=/); # } $connectstr = "dbi:$dbtype:$mydbname"; $dB->disconnect if ($dB && $dB ne '1'); $dB = undef; $_ = ''; print "-connectstr=$connectstr= user=$dbuser= pswd=****= attb={$attb}= sid=$ENV{ORACLE_SID}= TT=$ENV{TWO_TASK}=\n"; eval "\$dB=DBI->connect('$connectstr','$dbuser','$dbpswd',{$attb})"; &show_err("-no login: ".($_ ? $_ : ("err=".DBI->err.':'.DBI->errstr))) unless ($dB); # &show_err("-no login: err=$_") if ($_ && !$dB); #REQUIRED SINCE FOR.. #SOME REASON DBI'S ERROR HANDLING DOESN'T PLAY NICE W/SPRITE?!? } if ($dB) { #if ($dbtype eq 'mysql' || $rhost =~ /\S/) #CHGD TO NEXT 20020606! if ($dbtype eq 'mysql' || ($rhost =~ /\S/ && $DBI::VERSION < 1.21)) { eval "\$dB->{AutoCommit} = 1"; $autocommit = 1; warn '-MySQL and DBD::Proxy do not support transactions, everything will be committed imediatly!'; } elsif ($attb =~ /AutoCommit\s*\=\>\s*1/) { eval "\$dB->{AutoCommit} = 1"; } else { eval "\$dB->{AutoCommit} = 0"; } $dB->do('set TEXTSIZE 65535') if ($dbtype eq 'Sybase'); #ADDED 20030131 TO FIX "OUT OF MEMORY" ERRORS ON SELECTS FROM SQL-SERVER TABLES. $dB->{LongTruncOk} = 1 if ($dbtype eq 'ODBC'); #ODBC. $nocommit = 1; print "..Logging into \"$dbname\", please stand by...\n"; $noplaceholders = ($dbtype eq 'Sybase'); #SYBASE DOES NOT UTILIZE PLACHOLDERS VERY WELL & FREETDS/M$-SQLSERVER DONT DO THEM AT ALL :( $noplaceholders = $1 if ($attb =~ /\bnoplaceholders\s*\=\>\s*(\d)/); } # else # { # eval "print \"Could not connect to database: \".DBI::err.':'.DBI::errstr.\"\\n\""; # print "Could not connect to database: $_\n" if ($_ && !$dB); # } } sub loadtable { &initsec; @tables_found = $dB->tables(); my ($tablecsr); if ($#tables_found < 0) { if ($dbtype eq 'Oracle' || $dbtype eq 'Sprite') { #$tablecsr = $dB->prepare("select TABLE_NAME from USER_TABLES") $tablecsr = $dB->prepare("select TABLE_NAME from all_tables") || warn "table-prepare: ".$dB->err.':'.$dB->errstr; } elsif ($dbtype eq 'mysql' || $dbtype eq 'LDAP') { $tablecsr = $dB->prepare("show TABLES") || warn "table-prepare: ".$dB->err.':'.$dB->errstr; } if ($tablecsr) { $tablecsr->execute || warn "table-xeq: $$dbi_err: ".$dB->err.':'.$dB->errstr; } } $sUperman = 1; # if ($ENV{USER} eq 'xjturner'); unless ($sUperman) { $sUperman = &chkacc('--',$me); $sUperman = &chkacc($dbtype,$me) unless ($sUperman); #ADDED 20000531. $sUperman = &chkacc($dbname,$me) unless ($sUperman); $sUperman = &chkacc("$dbname:$dbuser",$me) unless ($sUperman); $sUperman = &chkacc("$dbtype:$dbname:$dbuser",$me) unless ($sUperman); #ADDED 20000531. #$sUperman = 1 if ($dbtype eq 'Sprite'); } my $tablefid = $ENV{HOME} . '/.sqltable.' . &tolower(substr($dbtype,0,3)); my $skipfid = $ENV{HOME} . '/.sqlskip.' . &tolower(substr($dbtype,0,3)); if ($skipfid && open(IN, "<$skipfid")) { $skipfid = ; $skipfid =~ s/\s+$//; close IN; $skipfid = '=~ ' . $skipfid unless ($skipfid =~ /^\s*[\=\!]/); } else { $skipfid = undef; } unless (-e $tablefid) { $tablefid = $pgmhome . 'sqltables.' . &tolower(substr($dbtype,0,3)); } if ($tablecsr) { while (($table_name) = $tablecsr->fetchrow) { $_ = "\$table_name $skipfid"; unless ($skipfid && eval $_) { push(@tables_found,$table_name) if ($sUperman || &chkacc("$dbname:$dbuser:$table_name",$me)); } } $tablecsr->finish; } else { my (@all_tables) = @tables_found; @tables_found = (); for ($i=0;$i<=$#all_tables;$i++) { $_ = "\$all_tables[\$i] $skipfid"; unless ($skipfid && eval $_) { push(@tables_found,$all_tables[$i]) if ($sUperman || &chkacc("$dbname:$dbuser:$all_tables[$i]",$me)); } } } my ($slash) = $/; #NEXT 2 ADDED 20011001! $/ = "\n"; if (open(IN,"<$tablefid")) { while () { chomp; push(@tables_found,$_) if (/\S/ && ($sUperman || &chkacc("$dbname:$dbuser:$_",$me))); } close (IN); } $/ = $slash; #ADDED 20011001! if ($dbtype eq 'ODBC') { for ($i=0;$i<=$#tables_found;$i++) #ODBC-SPECIFIC. { $tables_found[$i] =~ s/^$dbuser\.//i; #$tables_found[$i] =~ s/\".*?\"\.//i; #CHGD. TO NEXT 20040819. $tables_found[$i] = $1 if ($tables_found[$i] =~ /\"([^\"]+)\"\s*$/); $tables_found[$i] =~ tr/a-z/A-Z/; } } else #ADDED 20000821! { for ($i=0;$i<=$#tables_found;$i++) #ODBC-SPECIFIC. { $tables_found[$i] =~ s/^$dbname\.//i; $tables_found[$i] =~ s/^$dbuser\.//i; } } $fieldList->delete('0.0','end'); $orderList->delete('0.0','end'); $whereList->delete('0.0','end'); $ordbyList->delete('0.0','end'); $tableList->delete('0.0','end'); foreach (sort @tables_found) { $tableList->insert('end',$_); } $newwhere = 1; } sub loadoldfmts { @fmtTextList = (); my $fmtfid = $ENV{HOME} . '/.' . substr($dbuser,0,7) . '.' . &tolower(substr($dbtype,0,3)); #unless (-e $fmtfid) #{ # $fmtfid = $ENV{HOME} . '/.sqlplfm.dat'; #} #if (open(IN,"<.sqlplfm.dat")) if (open(IN, "<$fmtfid")) { while () { chomp; $fmtText->insert('end',$_); push (@fmtTextList,$_); } close IN; } } sub loadBrowseChoices { my $tablefid = '.sqlplcfg.txt'; unless (-e $tablefid) { $tablefid = $ENV{HOME} . '/.sqlplcfg.txt'; } unless (-e $tablefid) { $tablefid = $pgmhome . 'sqlplcfg.txt'; } #if (open(IN,"<${pgmhome}sqlplcfg.txt")) my ($b, $d, $r); @usedbs = (); if (open(IN,"<$tablefid")) { my ($browsefield,$browseval,$arg1,$arg2,$arg3,$arg4); while () { chomp; ($browsefield,$browseval) = split(/=/, $_, 2); if ($browsefield eq 'dbname') { #$sysidText->insert('end',$browseval); ($arg1, $arg2, $arg3, $arg4) = split(/\:/, $browseval); push (@dbnames, $arg1); $dbthemes{$arg1} = $arg4||''; $attbs{$arg1} = $1 if ($arg2 =~ s/\{([^\}]+)\}//); @{$precmds{$arg1}} = split(/\;/, $arg2) if ($arg2); $dbname = $arg1 unless ($b); $dbthemes{$arg1} = $arg4 if ($arg4); $dbtypes{$arg1} = $arg3 if ($arg3); $b = 1; } elsif ($browsefield eq 'dbuser') { #$dbnameText->insert('end',$browseval); ($arg1, $arg2, $arg3, $arg4) = split(/\:/, $browseval); push (@dbusers, $arg1); $attbs{$arg1} = $1 if ($arg2 =~ s/\{([^\}]+)\}//); @{$precmds{$arg1}} = split(/\;/, $arg2) if ($arg2); $dbuser = $arg1 unless ($d); $dbthemes{$arg1} = $arg4 if ($arg4); $dbtypes{$arg1} = $arg3 if ($arg3); $d = 1; } elsif ($browsefield eq 'dbtype') { ($arg1, $arg2, $arg3) = split(/\:/, $browseval); $attbs{$arg1} = $1 if ($arg2 =~ s/\{([^\}]+)\}//); @{$precmds{$arg1}} = split(/\;/, $arg2) if ($arg2); $dbtype = $arg1; $dbthemes{$arg1} = $arg3 if ($arg3); } elsif ($browsefield eq 'host') { #$rhostEntry->insert('end',$browseval); push (@rhosts, $browseval); $rhost = $browseval unless ($r); $r = 1; } elsif ($browsefield eq 'use') { push (@usedbs, $browseval); } else { ${$browsefield} = $browseval unless (${$browsefield} =~ /\S/); } } close IN; } } sub tableClickFnP { my $mychoice = $tableList->curselection; $tableList->selection('set',$mychoice); } sub tableClickFn { $mytable = $tableList->get('active'); $tableHead->configure(-text => "Table=$mytable"); # $statusText->delete('0.0','end'); #DECIDED NOT TO CLEAR STATUS MSGS! $mytable =~ s/.*\.//; if ($dbtype eq 'mysql') { $fieldcsr = $dB->prepare("LISTFIELDS $mytable", {'mysql_use_result' => 1}) || &show_err("fields: prepare: ".$dB->err.':'.$dB->errstr); } elsif ($dbtype eq 'Sybase') #THIS MAY WORK W/OTHER dB'S, BUT I DON'T KNOW, PLEASE SOMEONE ENLIGHTEN ME! { $fieldcsr = $dB->prepare("select top 1 * from $mytable") || &show_err("fields: prepare: ".$dB->err.':'.$dB->errstr); } else { $fieldcsr = $dB->prepare("select * from $mytable", {ldap_sizelimit => 1, sprite_sizelimit => 1}) || &show_err("fields: prepare: ".$dB->err.':'.$dB->errstr); } $fieldcsr->execute || &show_err("fields: xeq: ".$dB->err.':'.$dB->errstr); #(@titles) = &ora_titles($fieldcsr,0); @titles = @{$fieldcsr->{NAME}}; $fieldList->delete('0.0','end'); $orderList->delete('0.0','end'); $whereList->delete('0.0','end'); $ordbyList->delete('0.0','end'); #$sqlText->delete('0.0','end'); $valusText->delete('0.0','end'); $orderSel = 'order'; for ($i=0;$i<=$#titles;$i++) { $fieldList->insert('end',$titles[$i]); } $fieldList->insert('end','<---filler--->'); #&ora_close($fieldcsr); $fieldcsr->finish; $use = 'line'; $newwhere = 1; } sub tableDclickFn { my ($myfield) = $tableList->get('active'); $sqlText->insert('insert',$myfield); $sqlText->focus; $use = 'sql'; } sub fieldClickFn { my ($myfield) = $fieldList->get('active'); $cmd = "\$".$orderSel."List->insert('end',$myfield);"; eval $cmd; $fieldList->focus(); } sub fieldDclickFn { my ($myfield) = $fieldList->get('active'); $sqlText->markSet('mymark','insert'); $sqlText->insert('insert',$myfield); $sqlText->see('mymark'); $mychoice = $fieldList->index('end'); my $myfield2 = $fieldList->get($mychoice); ### $fieldList->delete('end') if ($myfield eq $myfield2); $cmd = "\$".$orderSel."List->delete('end')"; eval $cmd; $sqlText->focus; $use = 'line'; } sub whereClickFn { $whereList->delete('active'); # $newwhere = 1; #COMMENTED 20030812 (CONVENIENCE) TO ALLOW REMOVAL OF CRITERIA W/O RESETTING VALUES. $whereList->focus(); } sub orderClickFn { $orderList->delete('active'); $orderList->focus(); } sub ordbyClickFn { $ordbyList->delete('active'); $ordbyList->focus(); } sub getfile { my $mytitle = "Select delimited flatfile:"; my ($create) = 1; #THIS MUST BE 1. my ($fileDialog) = $MainWin->JFileDialog( -Title=> $mytitle, -Path => $startfpath || $ENV{PWD}, -History => 12, -HistFile => "$ENV{HOME}.sqlhist", -Create=>$create); $myfile = $fileDialog->Show(); #$startfpath = $fileDialog->{Configure}{-Path}; $startfpath = $fileDialog->getLastPath(); if ($myfile =~ /\S/) { $fileText->delete('0.0','end'); $fileText->insert('end',$myfile); } $use = 'file'; } sub doSprite { $dosprite = 1; $doexcel = 0; $doxml = 0; &doselect; $dosprite = 0; } sub doExcel { return 0 if ($noexcel); $dosprite = 0; $doexcel = 1; $doxml = 0; &doselect; $doexcel = 0; } sub doXML { return 0 if ($noxml); $dosprite = 0; $doexcel = 0; $doxml = 1; %xmleschash = ( '<' => '<', '>' => '>', '"' => '"', '--' => '--', # "\0" => '�' ); &doselect; $doxml = 0; } sub doselect { #my ($myline, $mymyfmt, $myfmtstmt, $myfmtstmt2, $myfmtstmtH, $myfmtstmtH2, $mycnt, $mysel, $usrres, $myselect, $myfile, $mydelims); my ($myline, $mycnt, $mysel, $usrres, $myselect, $myfile, $mydelims); my (@titles, @types, @lens, %typesH, %lensH, @mytypes, @mylens, $selcsr); my ($fullheaderlist); local ($mymyfmt) = $myfmt; @fieldvals = (); my ($bindcnt, @wherebits); $mypaglen = 0; my ($reccount) = 0; # $statusText->delete('0.0','end'); $myfile = $fileText->get; if ($doexcel && $myfile !~ /\S/) { $DIALOG1->configure( -text => "Must specify an output file!"); $usrres = $DIALOG1->Show(); return; } ($mysdelim,$myjdelim) = &getdelims(0); my ($myasdelim, $myajdelim) = &getdelims(2); my ($myrsdelim,$myrjdelim) = &getdelims(1); #FETCH RECORD DELIMITERS. my ($slash) = $/; $/ = $myrjdelim; $errorsfound = 0; if ($use ne 'file') { $usrres = 'No'; } elsif (-e $myfile) { $DIALOG2->configure( -text => "File \"$myfile\" exists, overwrite?"); $usrres = $DIALOG2->Show(); } else { $usrres = $OK; } $bindcnt = 0; if ($use eq 'sql') #NOTE: SECURITY HOLE: CURRENTLY ONLY CHECKS 1ST TABLE!!! { $myselect = $sqlText->get('0.0','end'); $myselect =~ s/;+$//; #NEXT 6 LINES ADDED 20030920 TO SUPPORT A "READONLY" MODE! if ($readonly && $myselect =~ /^\s*(?:insert|update|drop|delete|truncate)/i) { &show_err("..MAY NOT PERFORM THIS QUERY IN READONLY MODE!\n"); $/ = $slash; return; } if ($myselect =~ /^\s*(?:drop|delete|truncate)/i) { $DIALOG2->configure( -text => "ABOUT TO DROP/DELETE/TRUNCATE TABLE!\nAre you SURE?"); return (0) if ($DIALOG2->Show() ne $OK); } $myselect =~ s/\sinto\s+\:\w+(\s+\:\w+)*//; #ADDED 20011217. $myselect =~ /\b(?:table|into|from|update)\b\s*([^\s\,]+)/i; $chktable = "\U$1"; unless ($sUperman || &chkacc("$dbname:$dbuser:$chktable",$me)) { $chktable =~ s/,\s+/,/g; @chktables = split(/,/,$chktable); foreach (@chktables) { unless (&chkacc("$dbname:$dbuser:$_",$me)) { &show_err("..NOT AUTHORIZED TO ACCESS TABLE \"$chktable\"\!\n"); $/ = $slash; return; } } } } else { $StuffEnterred = 0; my (@fieldlist) = $orderList->get('0','end'); my (@orderlist) = $ordbyList->get('0','end'); my (@wherelist) = $whereList->get('0','end'); my $useTop2Limit = ''; $useTop2Limit = 'top 1 ' if ($dbtype eq 'Sybase'); if ($selcsr = $dB->prepare('select '.$useTop2Limit." * from $mytable", {ldap_sizelimit => 1, sprite_sizelimit => 1})) { $selcsr->execute; &show_err("sql select: EXEC ERROR: ".$dB->err.':'.$dB->errstr) if ($dB->err); #@lens = @{$selcsr->{PRECISION}}; @titles = @{$selcsr->{NAME}}; @types = @{$selcsr->{TYPE}}; @lens = @{$selcsr->{PRECISION}}; if ($dbtype eq 'Oracle') { my @oralens = @{$selcsr->{'ora_lengths'}}; #ORACLE-SPECIFIC. for (my $i=0;$i<=$#lens;$i++) { $lens[$i] ||= $oralens[$i]; } } elsif ($dbtype eq 'mysql') { @lens = @{$selcsr->{mysql_length}}; } $selcsr->finish; for (my $i=0;$i<=$#titles;$i++) { $typesH{$titles[$i]} = $types[$i]; $lensH{$titles[$i]} = $lens[$i]; } } $wherestuff = $sqlText->get('0.0','end'); $wherestuff =~ s/\n//g; @ops = (); @relops = (); $mysel = join(',',@fieldlist); $mysel = '*' if ($#fieldlist < 0); $myselect = 'select '; $myselect .= 'distinct ' if ($distinct); $myselect .= "$mysel from ".$mytable; #$myselect .= ' where '.$wherestuff if ($wherestuff =~ /\S/); if ($wherestuff =~ /\S/ && $#wherelist < 0) { #EMPTY WHERE-LIST - TREAT STUFF IN SQL BOX AS A COMPLETE #WHERE-CLAUSE. $myselect .= ' where ' . $wherestuff; $wherestuff = ''; } elsif ($#wherelist >= 0) { $StuffEnterred = 0; if ($wherestuff =~ /\S/) { #TREAT WHERE-STUFF AS LIST OF VALUES #FOR FIELDS LISTED IN ORDER-BY LIST. @fieldvals = split($myasdelim,$wherestuff,-1); #NOTHING TO FIX HERE - IF VALUE HAS QUOTES, INCLUDE THEM. $fieldvals[0] = '' if ($#fieldvals < 0); $wherestuff = ''; for (0..$#wherelist) { $wherestuff .= $myajdelim if ($_ > 0); $wherestuff .= $wherelist[$_] . '=' . $fieldvals[$_]; } $StuffEnterred = 2; } else { &inputscr(1); #PROMPT FOR WHERE-STUFF. } unless ($StuffEnterred) { $/ = $slash; return (0); } } if ($wherestuff =~ /\S/) { $myselect .= ' where '; @fieldvals = (); @wherebits = split($myasdelim,$wherestuff,-1); $wherebits[0] = '' if ($#wherebits < 0); for ($i=0;$i<=$#wherebits;$i++) { $wherebits[$i] =~ s/\x02/$myajdelim/g; ($wherevars,$wherevals) = split(/=/,$wherebits[$i],2); if ($ops[$i]) { $wherevals =~ s/\\([\%\_])/$1/g; if ($ops[$i] eq ' is' || $ops[$i] eq ' is not') { $myselect .= $wherevars . $ops[$i] . ' NULL'; } elsif ($ops[$i] eq ' in') { if ($wherevals =~ /^\s*\(.*\)\s*$/) { $myselect .= $wherevars . $ops[$i] . ' ' . $wherevals; } else { $myselect .= $wherevars . $ops[$i] . ' ('.$wherevals.') '; } } else { #my @isNumeric = DBI::looks_like_number($wherevals); if ($StuffEnterred == 2 && $wherevals !~ /^([\'\"]).*\1$/ && $wherevals =~ /^[A-Z_]/io) { $myselect .= $wherevars . $ops[$i] . ' ' . $wherevals; $preboundHash{$i} = 1; } else { ++$bindcnt; $myselect .= $wherevars . $ops[$i] . ' ?'; $wherevals .= '%' if ($ops[$i] =~ /like/ && $wherevals !~ /[\%\_]/); push (@fieldvals,$wherevals); push (@mytypes, $typesH{$wherevars}); push (@mylens, $lensH{$wherevars}); } } } elsif ($wherevals =~ /[^\\][\%\_]/) { #my @isNumeric = DBI::looks_like_number($wherevals); if ($StuffEnterred == 2 && $wherevals !~ /^([\'\"]).*\1$/ && $wherevals =~ /^[A-Z_]/io) { $myselect .= $wherevars . ' like ' . $wherevals; $preboundHash{$i} = 1; } else { ++$bindcnt; $myselect .= $wherevars . ' like ?'; push (@fieldvals,$wherevals); push (@mytypes, $typesH{$wherevars}); push (@mylens, $lensH{$wherevars}); } } else { $wherevals =~ s/\\([\%\_])/$1/g; #my @isNumeric = DBI::looks_like_number($wherevals); if (!length($wherevals)) { $myselect .= $wherevars . ' is NULL'; $preboundHash{$i} = 1; } elsif ($StuffEnterred == 2 && $wherevals !~ /^([\'\"]).*\1$/ && $wherevals =~ /^[A-Z_]/io) { $myselect .= $wherevars . ' = ' . $wherevals; $preboundHash{$i} = 1; } else { ++$bindcnt; $myselect .= $wherevars . ' = ?'; $wherevals =~ s/^([\'\"])(.*)\1$/$2/; push (@fieldvals,$wherevals); push (@mytypes, $typesH{$wherevars}); push (@mylens, $lensH{$wherevars}); } } $myselect .= $relops[$i]|| (($myajdelim =~ /^\|\|?$/) ? ' or ' : ' and ') if ($i < $#wherebits); } } if ($#orderlist >= 0) { $myselect .= ' order by '.join(',',@orderlist); $myselect .= ' DESC' if ($descorder); } } chomp ($myselect); ##$statusText->insert('end',"..DID QUERY: $myselect. $reccount records selected.\n"); $statusText->insert('end',"..DOING QUERY: $myselect.\n"); $statusText->see('end'); #$fieldcsr = &ora_open($dB,$myselect) my $myPHselect = $myselect; $myselect =~ s/([\'\"])([^\1]*?)\1/ my ($quote) = $1; my ($str) = $2; $str =~ s|\?|\x02\^2jSpR1tE\x02|g; #PROTECT ?'S IN QUOTES. "$quote$str$quote" /egs; my $t; for (my $i=0;$i<$bindcnt;$i++) { $t = $fieldvals[$i]; if (defined $t) #CONDITION & ELSE ADDED 20050209 2 BETTER HANDLE NULLS. { $t =~ s/\'/\'\'/gs; $t =~ s/\?/\x02\^2jSpR1tE\x02/gs; # if ($dbtype eq 'Sybase' && $t =~ /^((?:\'\')?)[\d\.\+\-]+\1$/) #ADDED 20060427 TO PREVENT ERROR! if ($t eq '') { $myselect =~ s/\?/NULL/; } elsif ($StuffEnterred == 2 || ($mytypes[$i] >= 2 && $mytypes[$i] <= 8) || $mytypes[$i] == 1700 || $mytypes[$i] == -5 || $mytypes[$i] == -6) { $t =~ s/^\'\'(.*)\'\'$/\'$1\'/; $myselect =~ s/\?/$t/s; } else { $myselect =~ s/\?/\'$t\'/s; } } else { $myselect =~ s/\?/NULL/s; } } $myselect =~ s/\x02\^2jSpR1tE\x02/\?/gs; #UNPROTECT ?'S IN QUOTES. if ($noplaceholders) { $fieldcsr = $dB->prepare($myselect) || &show_err("sql select: OPEN ERROR: ".$dB->err.':'.$dB->errstr); } else { $fieldcsr = $dB->prepare($myPHselect) || &show_err("sql select: OPEN ERROR: ".$dB->err.':'.$dB->errstr); #&ora_bind($fieldcsr, @fieldvals) if ($bindcnt); for my $i (1..$bindcnt) { $fieldcsr->bind_param($i, $fieldvals[$i-1], {TYPE => $mytypes[$i-1]}) || &show_err("sql select: BIND ERROR: ".$dB->err.':'.$dB->errstr); } } $fieldcsr->execute; &show_err("sql select: EXEC ERROR: ".$dB->err.':'.$dB->errstr) if ($dB->err); if ($myselect =~ /^\s*(?:create|drop|delete|alter|truncate)/i) { &loadtable(); #ADDED 20020620 TO AUTO-GENERATE A "TDF" (TABLE-DEFINITION FILE) #WHEN A TABLE IS CREATED OR ALTERED, IF A "DATA-DEFINITION PATH #(DDPATH) PARAMETER IS SPECIFIED IN .SQLPLCFG.TXT! if ($ddpath) { if ($myselect =~ /^\s*create\s+table\s+([^\s\(]+)/i) { $mytable = $1; my $primarykeys = ''; $primarykeys = $1 if ($myselect =~ /primary\s+keys?\s*\(([^\)]+)\)/s); &dodescribe(4, $primarykeys); } elsif ($myselect =~ /^\s*alter\s+table\s+([^\s\(]+)/i) { $mytable = $1; my $primarykeys = ''; $ddpath .= $osslash if ($ddpath && $ddpath !~ m#${osslash}$#); if (open(IN,"<${ddpath}${mytable}.tdf")) { while () { chomp; if (/primary\s+keys?\s*\(([^\)]+)\)/s) { $primarykeys = $1; last; } } close (IN); } &dodescribe(4, $primarykeys); } } $statusText->insert('end',".......DID above command.\n") unless ($dB->err); $statusText->see('end'); } else { $xpopup->destroy if (Exists($xpopup)); $xpopup = $MainWin->Toplevel; $xpopup->title("Selected records: ($myselect)"); my $xpopupFrame = $xpopup->Frame; $xpopupText = $xpopupFrame->ROText( -font => $fixedfont, #PC-SPECIFIC. -relief => 'sunken', -setgrid=> 1, -wrap => 'none', #-height => 25, -width => 80); my $w_menu = $xpopup->Frame(-relief => 'raised', -borderwidth => 2); $w_menu->pack(-fill => 'x'); my $fileMenubtn = $w_menu->Menubutton(-text => 'File', -underline => 0); $fileMenubtn->command(-label => 'Break', -underline =>0, -command => sub {$abortit = 1;}); $fileMenubtn->command(-label => 'Save', -underline =>0, -command => [\&doSave]); $fileMenubtn->separator; $fileMenubtn->command(-label => 'Close', -underline =>0, -command => [$xpopup => 'destroy']); $fileMenubtn->command(-label => 'eXit', -underline =>1, -command => \&exitFn); my $editMenubtn = $w_menu->Menubutton(-text => 'Edit', -underline => 0); $editMenubtn->command(-label => 'Copy', -underline =>0, -command => [\&doCopy]); $editMenubtn->separator; $editMenubtn->command( -label => 'Find', -underline =>0, -accelerator => 'Alt-s', -command => [\&newSearch,$xpopupText,1]); $editMenubtn->command(-label => 'Modify search', -underline =>0, -command => [\&newSearch,$xpopupText,0]); $editMenubtn->command( -label => 'Again', -underline =>0, -accelerator => 'Alt-a', -command => [\&doSearch,$xpopupText,0]); $fileMenubtn->pack(-side=>'left'); $editMenubtn->pack(-side=>'left'); #$xpopup->bind('' => [\&doSearch,$xpopupText,0]); $xpopupText->bind('' => [\&textfocusin]); my $xpopupScrollY = $xpopupFrame->Scrollbar( -relief => 'sunken', -orient => 'vertical', -command=> [$xpopupText => 'yview']); $xpopupText->configure(-yscrollcommand=>[$xpopupScrollY => 'set']); $xpopupScrollY->pack(-side=>'right', -fill=>'y'); $xpopupScrollX = $xpopupFrame->Scrollbar( -relief => 'sunken', -orient => 'horizontal', -command=> [$xpopupText => 'xview']); $xpopupText->configure( -xscrollcommand=>[$xpopupScrollX => 'set']); $xpopupScrollX->pack( -side => 'bottom', -fill=>'x'); $xpopupText->pack( -side => 'left', -expand => 'yes', -fill => 'both'); my $recLabel = $xpopup->Label( -text => "$reccount records found", -relief => 'ridge'); my $btnFrame = $xpopup->Frame; my $okButton = $btnFrame->Button( -text => 'Ok', -underline => 0, #-command => [$xpopup => 'destroy']); -command => sub {$abortit = 1; $xpopup->destroy;}); $okButton->pack(-side=>'left', -expand => 1); #$okButton->pack(-side=>'left'); my $abortButton = $btnFrame->Button( -text => 'Break', -underline => 0, -command => sub {$abortit = 1;}); $abortButton->pack(-side=>'left', -expand => 1); #$abortButton->pack(-side=>'left' -fill => x); my $copyButton = $btnFrame->Button( -text => 'Copy', -underline => 0, -command => sub {&doCopy();}); $copyButton->pack( -side=>'left', -expand => 1); $btnFrame->pack( -side => 'bottom', -fill => 'x', #-expand => 1, -padx => '2m', -pady => '2m'); $recLabel->pack( -side => 'bottom'); $xpopupFrame->pack( -side => 'bottom', -expand => 'yes', -fill => 'both'); $xpopup->bind('' => [$okButton => "Invoke"]); $okButton->focus; # $xpopup->bind('' => [$okButton => "Invoke"]); $xpopup->bind('' => [$okButton => "Invoke"]); ###$myfmt = $fmtText->get; ($mysdelim,$myjdelim) = &getdelims(0); my $doCSV; $doCSV = $1 if ($myjdelim =~ /^\"(\S+)\"$/); #20060619: HANDLE CSV FILES! #print "-mytable=$mytable=\n"; $myjdelim = $doCSV if ($doCSV); if ($doexcel) #ADDED 20010524! { $xls = Spreadsheet::WriteExcel->new("$myfile"); $xlssheet = $xls->addworksheet($mytable); # Create a right-justify format for numeric fields. $numericfmt = $xls->addformat(); $numericfmt->set_align('right'); $normalfmt = $xls->addformat(); $normalfmt->set_align('left'); } if ($myfmt =~ /\S/ && !$doxml) { foreach $i (@fmtTextList) { goto SAMEFMT if ($i eq $myfmt); } $fmtText->insert('0',$myfmt); unshift (@fmtTextList, $myfmt);; #$x = $fmtText->index('end'); #print "-index=$x=\n"; if ($#fmtTextList >= $fmtmax) { $fmtText->delete('end','end'); pop (@fmtTextList); } SAMEFMT: $linecnt = 0; open(OUTFILE,">.sqlout.tmp") || warn "Could not create temp. file($!)!"; binmode OUTFILE; #20000404 #@headerlist = (); #@headerlist = $orderList->get('0','end'); #@headerlist = $fieldList->get('0','end') if ($#headerlist < 0); $mymyfmt =~ s/\\\\/\x02/g; #PROTECT DOUBLE-SLASHES. $mymyfmt =~ s/\\%/\x03/g; #PROTECT ESCAPED PERCENT-SIGNS. $mymyfmt =~ s/\\\@/\x04/g; #PROTECT ESCAPED PERCENT-SIGNS. @sumlist = ($mymyfmt =~ /(\@|\%|\#|\&)/g); #print "--sums=".join(',',@sumlist).'= '; my ($showsums) = 0; for (my $i=0;$i<=$#sumlist;$i++) { $sums[$i] = ''; if ($sumlist[$i] eq '&') { $sumlist[$i] = 1; $showsums = 1; } else { $sumlist[$i] = 0; } } $mymyfmt =~ s/\&/\@/g; if ($newfmt) { @fmts = ($mymyfmt =~ /(\s*[\@\&\#\%]\S*)/g); $mymyfmt = ''; for (my $i=0;$i<=$#fmts;$i++) { $fmts[$i] =~ s/[\@\&\#](\d+)(.)/ $2 x ($1 + 1) /e; $fmts[$i] =~ s/[\@\&\#]/\>/; if ($fmts[$i] =~ /\%([\+\-]?)(\d+)/) { $lens[$i] = $2; $fmtjust[$i] = ($1 eq '-') ? '<' : '>'; } else { $lens[$i] = length($fmts[$i]); $fmtjust[$i] = ($fmts[$i] =~ /([\^\>])/) ? $1 : '<'; } #print "-fmt=$fmts[$i]= len=$lens[$i]= just=$fmtjust[$i]= sep=$seps[$i]=\n"; #$mymyfmt .= $fmts[$i]; $fmts[$i] =~ s/ \< / \<\ /\>\> /; #HACK AROUND BUG IN TEXT::AUTOFORMAT :-( } $mymyfmt = join("\x05", @fmts); #print "-1- mymyfmt=$mymyfmt=\n"; $mymyfmt =~ s/\%[\+\-]?(\d+)./ '<' x ($1 + 1) /eg; #print "-2- mymyfmt=$mymyfmt=\n"; } else { $mymyfmt =~ s/\@\*/%s/g; $mymyfmt =~ s/\@>([>]+)/ my ($ac) = length($1); '%'.(2+$ac).'s'/eg; $mymyfmt =~ s/\@<([<]+)/ my ($ac) = length($1); '%-'.(2+$ac).'s'/eg; $mymyfmt =~ s/\@\|([\|]+)/ my ($ac) = length($1); '%-'.(2+$ac).'c'/eg; $mymyfmt =~ s/\@(\d*)/'%'.(1+$1).'s'/eg; $mymyfmt =~ s/\@(\d*)\|/'%-'.(1+$1).'c'/eg; $mymyfmt =~ s/\%(\d+)([Wwc])/\%\-$1$2/g; $mymyfmt =~ s/\@/\%1s/g; #print "--newfmt=$newfmt= myfmt1=$mymyfmt=\n"; @lens = ($mymyfmt =~ /\%[\+\-]?(\d+)/g); @fmts = ($mymyfmt =~ /\%[^a-zA-Z]*([a-zA-Z])/g); @fmtjust = ($mymyfmt =~ /\%(.)/g); for (my $i=0;$i<=$#fmtjust;$i++) { if ($fmtjust[$i] eq '-') { $fmtjust[$i] = '<'; } elsif ($fmts[$i] =~ /[c\^\|]/) { $fmtjust[$i] = '^'; } else { $fmtjust[$i] = '>'; } } #print "--fmts=".join(',',@fmts).'= lens='.join(',',@lens).'= justs='.join(',',@fmtjust); $mymyfmt =~ s/\\n/$myrjdelim/g; $mymyfmt =~ s/\\t/\t/g; $mymyfmt =~ s/(\%[^a-zA-Z]*)[Wwc]/$1s/g; } $mymyfmt =~ s/\x04/\@/g; $mymyfmt =~ s/\x03/\%/g; $mymyfmt =~ s/\x02/\\/g; $mymyfmt .= $myrjdelim; $fmtTextSel = $mymyfmt; #print "--myfmt2=$mymyfmt=\n"; #print "-4- fmt=$mymyfmt= headers=$headers=\n"; @dashes = (); if ($headers) { for ($i=0;$i<=$#headerlist;$i++) { $headerlist[$i] =~ s/\n/\\n/g; s/\r/\\r/g; $fullheaderlist[$i] = $headerlist[$i]; $headerlist[$i] = substr($headerlist[$i],0,$lens[$i]) if ($lens[$i]); if ($fmts[$i] eq 'c') { $l = length($headerlist[$i]); $j = int(($lens[$i] - $l) / 2); #print "h??? j=$j= l=$l= lns=$lens[$i]= f=$headerlist[$i]=\n"; $headerlist[$i] = ' 'x$j . $headerlist[$i]; } $t = $lens[$i]; $t = length($headerlist[$i]) unless ($t); push (@dashes,(${myjdelim}x$t)); } #open (OUTFILE,">.sqlhdr.tmp"); #binmode OUTFILE; #20000404 $myfmtstmtH = &headerfmt($mymyfmt,0); if ($newfmt) { @l = split(/\x05/, $myfmtstmtH); for ($i=0;$i<=$#l;$i++) { $_ = form($l[$i], $headerlist[$i]); chomp unless ($i == $#l); print OUTFILE; } } else { printf OUTFILE $myfmtstmtH, @headerlist; } ++$linecnt; if ($myjdelim ne '') { $myfmtstmtH2 = &headerfmt($mymyfmt,1); if ($newfmt) { #print OUTFILE form($myfmtstmtH2, @dashes) if ($myjdelim ne ''); @l = split(/\x05/, $myfmtstmtH2); for ($i=0;$i<=$#l;$i++) { $_ = form($l[$i], $dashes[$i]); chomp unless ($i == $#l); print OUTFILE; } } else { printf OUTFILE $myfmtstmtH2, @dashes if ($myjdelim ne ''); } ++$linecnt; } $mypaglen = 58; if ($doexcel) #ADDED 20010524! { # Create a format for the column headings. $excelheader = $xls->addformat(); $excelheader->set_bold(); #$excelheader->set_size(12); for $i (0..$#headerlist) { $xlssheet->write(0, $i, $fullheaderlist[$i], $excelheader); #20010604: TRY HERE SO FULL HEADER GETS PRINTED. if ($types[$j] =~ /(NUM|INT|DOUBLE|FLOAT)/) { $xlssheet->set_column($i, $i, ($lens[$i]+1)); } else { $xlssheet->set_column($i, $i, $lens[$i]); } #$xlssheet->write(0, $i, $headerlist[$i], $excelheader); } } } else { $mypaglen = 0; } $valuestuff = $valusText->get; $valuestuff =~ s/\\h\=.*$//g; $ffchar = ''; #ADDED 20030812 TO REINITIALIZE. #$ffchar = $1 if ($valuestuff =~ s/(\D+)//); #CHGD. TO NEXT 20030812. $ffchar = $1 if ($valuestuff =~ s/(\D+|\\x\d\d|\\0)//); $ffchar =~ s/\\n/\n/g; $ffchar =~ s/\\f/\f/g; $valuestuff = -1 unless ($valuestuff =~ m/\d+/); $valuestuff = 999999 unless ($valuestuff); $mypaglen = $valuestuff if ($valuestuff >= 0); #select((select(OUTFILE),$- = 0)[0]); #select((select(OUTFILE),$= = $mypaglen)[0]); $reccount = 0; $abortit = 0; #while (@fieldlist = &ora_fetch($fieldcsr)) $k = 0; $k++ if ($headers); while (@fieldlist = $fieldcsr->fetchrow_array) { ###########DoOneEvent(1); $xpopup->update; if (($reccount % 10) == 9) { $xpopup->idletasks; $recLabel->configure( -text => "$reccount records found so far..."); } last if ($abortit); &pageit; $maxlines = 0; #NOW, FILL IN LINE# IF REQUESTED ("#" IN LEU OF "@"); $myfmtstmt = $mymyfmt; $myfmtstmt =~ s/\#>([>]+)/ my ($ac) = length($1); '#'.(2+$ac).'s'/eg; $myfmtstmt =~ s/\#<([<]+)/ my ($ac) = length($1); '#-'.(2+$ac).'s'/eg; $myfmtstmt =~ s/\#\|([\|]+)/ my ($ac) = length($1); '#-'.(2+$ac).'c'/eg; $myfmtstmt =~ s/\#(\d*)/'#'.(1+$1).'s'/eg; $myfmtstmt =~ s/\#(\d*)\|/'#-'.(1+$1).'c'/eg; $myfmtstmt =~ s/\#(\d+)([Wwc])/\#\-$1$2/g; $myfmtstmt2 = $myfmtstmt; $myfmtstmt =~ s/\#([\+\-]?\d*)([a-zA-Z])/ my ($linenosz) = $1; my ($linenofmt) = $2; $linenosz = 0 unless ($linenosz); $fmtreccnt = sprintf("%$linenosz$linenofmt",($reccount+1)); $fmtreccnt/eg; $myfmtstmt2 =~ s/\#([\+\-]?)(\d*)[a-zA-Z]/ my ($linesign) = $1; my ($linenosz) = $2; $linenosz = 0 unless ($linenosz); $fmtreccnt = sprintf("%$linesign${linenosz}s",' 'x$linenosz); $fmtreccnt/eg; foreach $i (0..$#fieldlist) { $fieldlist[$i] =~ s/\n/\\n/gs; $fieldlist[$i] =~ s/\r/\\r/gs; @{"fl$i"} = (); if ($fmts[$i] =~ /w/i) { $mylines = 0; $j = $lens[$i]; $l = length($fieldlist[$i]); if ($fmts[$i] eq 'W') { $Text::Wrap::columns = $lens[$i]; eval {$t = wrap('','',$fieldlist[$i]);}; if ($@) { $fmts[$i] = 'w'; #WRAP CRAPPED :-(, DO MANUALLY! } else { @{"fl$i"} = split(/\n/,$t); #shift (@{"fl$i"}); $mylines = $#{"fl$i"}; } } if ($fmts[$i] eq 'w') { while ($j < $l) { push (@{"fl$i"},substr($fieldlist[$i],$j,$lens[$i])); $mylines += 1; $j += $lens[$i]; } } $maxlines = $mylines if ($maxlines < $mylines); } unless ($fmts[$i] eq 'W') { $sums[$i] += $fieldlist[$i] if ($sumlist[$i] && $fieldlist[$i] =~ /^[\d\s\.\+\-]*$/); $fieldlist[$i] = substr($fieldlist[$i],0,$lens[$i]) if ($lens[$i]); } else { $fieldlist[$i] = shift (@{"fl$i"}); } if ($fmts[$i] eq 'c') { $l = length($fieldlist[$i]); $j = int(($lens[$i] - $l) / 2); $fieldlist[$i] = ' 'x$j . $fieldlist[$i]; } } ; &pageit; if ($newfmt) { #print OUTFILE form($myfmtstmt,@fieldlist); @l = split(/\x05/, $myfmtstmt); for ($i=0;$i<=$#l;$i++) { $_ = form($l[$i], $fieldlist[$i]); chomp unless ($i == $#l); print OUTFILE; } } else { printf OUTFILE $myfmtstmt,@fieldlist; } if ($doexcel) #ADDED 20010524! { for $j (0..$#fieldlist) { #!!! NEED TO ADD SOME CODE TO USE FORMATS!!! #if ($types[$j] =~ /(NUM|INT|DOUBLE|FLOAT)/) if ($fmtjust[$j] eq '>') { $xlssheet->write($k, $j, $fieldlist[$j], $numericfmt); } else { $x = (length($fieldlist[$j]) > 255) ? substr($fieldlist[$j],0,255) : $fieldlist[$j]; if ($x =~ /^\=/) { $xlssheet->write_formula($k, $j, $x, $normalfmt); } if ($x =~ m#^(?:https?\:\/\/|ftp\:\/\/|mailto\:|internal\:|external\:)#) { $xlssheet->write_url($k, $j, $x, $normalfmt); } else { $xlssheet->write_string($k, $j, $x, $normalfmt); } } } ++$k; } ++$linecnt; @l = split(/\x05/, $myfmtstmtH2) if ($newfmt); for ($i=0;$i<=$maxlines-1;$i++) { &pageit; if ($newfmt) { #$eval = 'print OUTFILE form $myfmtstmt2,'; for ($j=0;$j<=$#l;$j++) { $_ = form($l[$j], ${"fl$j"}[$i]); chomp unless ($j >= $#l); print OUTFILE; } } else { $eval = 'printf OUTFILE $myfmtstmt2,'; for ($j=0;$j<=$#fieldlist;$j++) { $eval .= "\${fl$j}[$i],"; } chop($eval); eval $eval; } ++$linecnt; if ($doexcel) #ADDED 20010524! { for $j (0..$#fieldlist) { if ($types[$j] =~ /(NUM|INT|DOUBLE|FLOAT)/) { $xlssheet->write($k, $j, ${"fl$j"}[$i], $numericfmt); } else { $x = (length(${"fl$j"}[$i]) > 255) ? substr(${"fl$j"}[$i],0,255) : ${"fl$j"}[$i]; if ($x =~ /^\=/) { $xlssheet->write_formula($k, $j, $x, $normalfmt); } if ($x =~ m#^(?:https?\:\/\/|ftp\:\/\/|mailto\:|internal\:|external\:)#) { $xlssheet->write_url($k, $j, $x, $normalfmt); } else { $xlssheet->write_string($k, $j, $x, $normalfmt); } } } ++$k; } } ++$reccount; } $fieldcsr->finish(); if ($showsums) { &pageit; @l = split(/\x05/, $myfmtstmtH2) if ($newfmt); if ($myjdelim ne '' && ($linecnt % $mypaglen) > 2) { $myfmtstmtH2 = &headerfmt($mymyfmt,1); if ($newfmt) { #print OUTFILE form($myfmtstmtH2, @dashes); for ($i=0;$i<=$#l;$i++) { $_ = form($l[$i], $dashes[$i]); chomp unless ($i == $#l); print OUTFILE; } } else { printf OUTFILE $myfmtstmtH2, @dashes; } ++$linecnt; } if ($newfmt) { #$eval = 'print OUTFILE form $myfmtstmt2,'; for ($j=0;$j<=$#l;$j++) { $_ = form($l[$j], $sums[$j]); chomp unless ($j >= $#l); print OUTFILE; } } else { $eval = 'printf OUTFILE $myfmtstmt2,'; for ($j=0;$j<=$#sums;$j++) { $eval .= "\$sums\[$j\],"; } chop($eval); eval $eval; } if ($doexcel) #ADDED 20010524! { for $j (0..$#sums) { $xlssheet->write($k, $j, ('-' x length($sums[$j])), $numericfmt); $xlssheet->write($k+1, $j, $sums[$j], $numericfmt); } $k += 2; } } close (OUTFILE); } else { open(OUTFILE2,">.sqlout.tmp") || warn "Could not create temp. file($!)!"; binmode OUTFILE2; #20000404 if ($doxml) { require MIME::Base64; #open (OUTFILE, ">$myfile"); #binmode OUTFILE; $_ = $myselect; #2 foreach my $i (@fieldvals) #2 { #2 s/\?/\'$i\'/; #2 } print OUTFILE2 < END_XML print OUTFILE2 < END_XML print OUTFILE2 < /\