home *** CD-ROM | disk | FTP | other *** search
/ Usenet 1994 January / usenetsourcesnewsgroupsinfomagicjanuary1994.iso / sources / misc / volume30 / sybperl / patch05 next >
Encoding:
Text File  |  1992-07-06  |  29.7 KB  |  1,046 lines
  1. Newsgroups: comp.sources.misc
  2. From: mpeppler@itf0.itf.ch (Michael Peppler)
  3. Subject:  v30i092:  sybperl - Sybase DB-library extensions to Perl, Patch05
  4. Message-ID: <1992Jun29.191350.15676@sparky.imd.sterling.com>
  5. X-Md4-Signature: 62f0fcc21bb10fc68d45cc3c9f490f57
  6. Date: Mon, 29 Jun 1992 19:13:50 GMT
  7. Approved: kent@sparky.imd.sterling.com
  8.  
  9. Submitted-by: mpeppler@itf0.itf.ch (Michael Peppler)
  10. Posting-number: Volume 30, Issue 92
  11. Archive-name: sybperl/patch05
  12. Environment: UNIX, Perl, Sybase
  13. Patch-To: sybperl: Volume 28, Issue 33
  14.  
  15. This is patch 5 to Sybperl, a set of Sybase DB-Library extensions to Perl.
  16. Note that Sybperl was posted at patchlevel 4.
  17.  
  18. >From the CHANGES file:
  19.      1.005   Sybperl would core dump if you used a uninitialized
  20.              DBPROCESS.
  21.          A solution to the sometime pathological    memory usage
  22.          observed when using a release of Perl lower than 4.035
  23.          is also described in BUGS.
  24.          &dblogin now returns -1 if the dblogin() or dbopen()
  25.          calls fail.
  26.          Added the possibility to login to a specific server
  27.          without setting the DSQUERY environment variable.
  28.          Added a script to extract the information regarding
  29.          the database from the databases' system tables. See
  30.          eg/dbschema.pl.
  31.  
  32. Apply the patch with 
  33.     patch -p1 -N <patch
  34.  -- 
  35. Michael Peppler                 mpeppler@itf.ch {uunet,mcsun}!chsun!itf1!mpeppler
  36. ITF Management SA            BIX:   mpeppler                         
  37. 13 Rue de la Fontaine        Phone: (+4122) 312 1311  
  38. CH-1204 Geneva, Switzerland  Fax:   (+4122) 312 1322  
  39.  
  40. -----------------  snip       snip  --------------------------
  41.  
  42. diff -c -r ./BUGS /usr/local/src/perl/sybase/dist-1.5/BUGS
  43. *** ./BUGS    Wed Jun 24 13:37:32 1992
  44. --- /usr/local/src/perl/sybase/dist-1.5/BUGS    Thu Jun 25 13:18:07 1992
  45. ***************
  46. *** 41,44 ****
  47.       Thanks to Teemu Torma for providing the initial input on this problem.    
  48.   
  49.   
  50. !     Michael
  51. --- 41,105 ----
  52.       Thanks to Teemu Torma for providing the initial input on this problem.    
  53.   
  54.   
  55. ! 
  56. !     Sybperl Memory Usage
  57. !     --------------------
  58. ! 
  59. !     The general format of a Sybperl script usually looks somewhat like
  60. !     this:
  61. ! 
  62. !     #!/usr/local/bin/sybperl
  63. ! 
  64. !     &dbcmd( query text );
  65. !     &dbsqlexec;
  66. !     &dbresults;
  67. ! 
  68. !     while(@data = &dbnextrow)
  69. !     {
  70. !        process data
  71. !     }
  72. ! 
  73. ! 
  74. !     If you are using a version of Perl prior to release 4, patchlevel
  75. !     35, then this method will result in a rather important memory
  76. !     leak. There are two ways around this problem:
  77. ! 
  78. !     1) Upgrade to Perl 4, patchlevel 35 :-)
  79. ! 
  80. !     2) Write a subroutine that calls &dbnextrow and stores the returned
  81. !        array to a local variable, and which in turn returns that array to
  82. !        the main while() loop, like so:
  83. ! 
  84. !     sub getRow
  85. !     {
  86. !         local(@data);
  87. ! 
  88. !     @data = &dbnextrow;
  89. ! 
  90. !     @data;
  91. !     }
  92. ! 
  93. !     while(@data = &getRow)
  94. !     {
  95. !        etc.
  96. !     }
  97. ! 
  98. ! 
  99. !     This technique should keep the memory usage of Sybperl to a
  100. !     manageable level.
  101. ! 
  102. ! 
  103. ! 
  104. ! 
  105. ! 
  106. ! 
  107. ! 
  108. ! 
  109. !     Please let me know if you find any other problems with Sybperl so
  110. !     that I can look into it.
  111. ! 
  112. !     Thank you.
  113. ! 
  114. !     Michael Peppler    <mpeppler@itf.ch>
  115. ! 
  116. !     
  117. diff -c -r ./CHANGES /usr/local/src/perl/sybase/dist-1.5/CHANGES
  118. *** ./CHANGES    Wed Jun 24 13:37:32 1992
  119. --- /usr/local/src/perl/sybase/dist-1.5/CHANGES    Thu Jun 25 13:18:08 1992
  120. ***************
  121. *** 1,6 ****
  122.       Sybperl CHANGES:
  123.   
  124. !     
  125.       1.004    Added support for Perl based error and message
  126.           handlers (as made possible by Perl 4.018). Many Thanks
  127.           to Teemu Torma for this code.
  128. --- 1,18 ----
  129.       Sybperl CHANGES:
  130.   
  131. ! 
  132. !     1.005   Sybperl would core dump if you used a uninitialized
  133. !             DBPROCESS.
  134. !         A solution to the sometime pathological    memory usage
  135. !         observed when using a release of Perl lower than 4.035
  136. !         is also described in BUGS.
  137. !         &dblogin now returns -1 if the dblogin() or dbopen()
  138. !         calls fail.
  139. !         Added the possibility to login to a specific server
  140. !         without setting the DSQUERY environment variable.
  141. !         Added a script to extract the information regarding
  142. !         the database from the databases' system tables. See
  143. !         eg/dbschema.pl.
  144.       1.004    Added support for Perl based error and message
  145.           handlers (as made possible by Perl 4.018). Many Thanks
  146.           to Teemu Torma for this code.
  147. ***************
  148. *** 13,15 ****
  149. --- 25,28 ----
  150.           Added a couple of example scripts in eg/*.pl, courtesy
  151.           of Gijs Mos (Thank You!).
  152.       1.003    Base version.
  153. + 
  154. diff -c -r ./Makefile /usr/local/src/perl/sybase/dist-1.5/Makefile
  155. *** ./Makefile    Wed Jun 24 13:37:32 1992
  156. --- /usr/local/src/perl/sybase/dist-1.5/Makefile    Thu Jun 25 13:18:09 1992
  157. ***************
  158. *** 1,7 ****
  159. ! #    @(#)Makefile    1.6    11/25/91
  160.   #
  161.       
  162. ! CC = cc
  163.   PERLSRC = ..                # where to find uperl.o
  164.   SYBINCS = /usr/local/sybase/include    # where to find the sybase .h files
  165.   LOCINCS =                # other includes ?
  166. --- 1,7 ----
  167. ! #    @(#)Makefile    1.10    6/25/92
  168.   #
  169.       
  170. ! CC = gcc
  171.   PERLSRC = ..                # where to find uperl.o
  172.   SYBINCS = /usr/local/sybase/include    # where to find the sybase .h files
  173.   LOCINCS =                # other includes ?
  174. ***************
  175. *** 44,50 ****
  176.                       # not possible without this, however.
  177.   OLD_SYBPERL= -DOLD_SYBPERL        # some backward compatibility stuff.                    
  178.   
  179. ! CFLAGS = -O                 # 
  180.   CPPFLAGS = -I$(PERLSRC) -I$(LOCINCS) -I$(SYBINCS) $(PERL_VERSION) \
  181.           $(SAVESTR) $(HAS_CALLBACK) $(OLD_SYBPERL)
  182.   BINDIR = /usr/local/bin            # where does the executable go
  183. --- 44,50 ----
  184.                       # not possible without this, however.
  185.   OLD_SYBPERL= -DOLD_SYBPERL        # some backward compatibility stuff.                    
  186.   
  187. ! CFLAGS = -O2 -funroll-loops                 # 
  188.   CPPFLAGS = -I$(PERLSRC) -I$(LOCINCS) -I$(SYBINCS) $(PERL_VERSION) \
  189.           $(SAVESTR) $(HAS_CALLBACK) $(OLD_SYBPERL)
  190.   BINDIR = /usr/local/bin            # where does the executable go
  191. ***************
  192. *** 65,70 ****
  193. --- 65,72 ----
  194.   $(UPERL): $(PERLSRC)/uperl.o
  195.       cp $(PERLSRC)/uperl.o $(UPERL)
  196.       perl -p -i.bak -e 's/savestr/psvestr/g;' $(UPERL)
  197. +     rm -f $(UPERL).bak
  198. +     
  199.   
  200.   clean:
  201.       rm -f sybperl *.o *~ core
  202. ***************
  203. *** 78,84 ****
  204.       rm -f sybperl.shar
  205.       shar.pl README PACKING.LST BUGS CHANGES Makefile sybperl.c \
  206.       sybperl.1 patchlevel.h lib/sybperl.pl lib/sybdb.ph t/sbex.pl \
  207. !     eg/sql.pl eg/space.pl eg/capture.pl eg/report.pl >sybperl.shar
  208.   
  209.   
  210.   
  211. --- 80,97 ----
  212.       rm -f sybperl.shar
  213.       shar.pl README PACKING.LST BUGS CHANGES Makefile sybperl.c \
  214.       sybperl.1 patchlevel.h lib/sybperl.pl lib/sybdb.ph t/sbex.pl \
  215. !     eg/sql.pl eg/space.pl eg/capture.pl eg/report.pl \
  216. !     eg/dbschema.pl eg/README >sybperl.shar
  217. ! 
  218. ! 
  219. ! tar:
  220. !     rm -f sybperl.tar
  221. !     tar cvfB sybperl.tar README PACKING.LST BUGS CHANGES Makefile sybperl.c \
  222. !     sybperl.1 patchlevel.h lib/sybperl.pl lib/sybdb.ph t/sbex.pl \
  223. !     eg/sql.pl eg/space.pl eg/capture.pl eg/report.pl \
  224. !     eg/dbschema.pl eg/README
  225. ! 
  226. ! 
  227.   
  228.   
  229.   
  230. diff -c -r ./PACKING.LST /usr/local/src/perl/sybase/dist-1.5/PACKING.LST
  231. *** ./PACKING.LST    Wed Jun 24 13:37:33 1992
  232. --- /usr/local/src/perl/sybase/dist-1.5/PACKING.LST    Thu Jun 25 13:18:06 1992
  233. ***************
  234. *** 20,23 ****
  235. --- 20,30 ----
  236.           eg/capture.pl   Create a table extracted from /etc/passwd
  237.           eg/report.pl    Report from table created by capture.pl
  238.           eg/sql.pl        Utility routines used by the above example programs.
  239. + 
  240. +         eg/dbschema.pl  Create an Isql script that will to
  241. +                         recreate your database(s) structure (data
  242. +                 types, tables, indexes, rules, defaults,
  243. +                 views, triggers and stored procedures),
  244. +                 extracting the information from the
  245. +                 database's system tables.
  246.           
  247. diff -c -r ./README /usr/local/src/perl/sybase/dist-1.5/README
  248. *** ./README    Wed Jun 24 13:37:31 1992
  249. --- /usr/local/src/perl/sybase/dist-1.5/README    Thu Jun 25 13:18:06 1992
  250. ***************
  251. *** 45,51 ****
  252.      Pyramid MIServer 2/2, OSx V5.1a, Sybase 4.0, Perl 4.010
  253.      
  254.      I use sybperl daily in a production environment on a Sun 4/65 under
  255. !    SunOS 4.1.1, with Sybase version 4.0.1 and Perl 4.019
  256.   
  257.      BUGS:
  258.   
  259. --- 45,51 ----
  260.      Pyramid MIServer 2/2, OSx V5.1a, Sybase 4.0, Perl 4.010
  261.      
  262.      I use sybperl daily in a production environment on a Sun 4/65 under
  263. !    SunOS 4.1.1, with Sybase version 4.0.1 and Perl 4.035
  264.   
  265.      BUGS:
  266.   
  267. ***************
  268. *** 52,57 ****
  269. --- 52,60 ----
  270.      There seems to be a major incompatibility between Perl and
  271.      DB-Library, but I've been able to code around it. See the BUGS file
  272.      for details.
  273. + 
  274. +    Memory usage can also be a problem in certain cases. Again see the
  275. +    BUGS file for details.
  276.   
  277.   
  278.   
  279. Common subdirectories: ./eg and /usr/local/src/perl/sybase/dist-1.5/eg
  280. Common subdirectories: ./lib and /usr/local/src/perl/sybase/dist-1.5/lib
  281. diff -c -r ./patchlevel.h /usr/local/src/perl/sybase/dist-1.5/patchlevel.h
  282. *** ./patchlevel.h    Wed Jun 24 13:37:36 1992
  283. --- /usr/local/src/perl/sybase/dist-1.5/patchlevel.h    Thu Jun 25 13:18:11 1992
  284. ***************
  285. *** 1,4 ****
  286.   #define VERSION 1
  287. ! #define PATCHLEVEL 4
  288.   
  289.   
  290. --- 1,4 ----
  291.   #define VERSION 1
  292. ! #define PATCHLEVEL 5
  293.   
  294.   
  295. diff -c -r ./sybperl.1 /usr/local/src/perl/sybase/dist-1.5/sybperl.1
  296. *** ./sybperl.1    Wed Jun 24 13:37:37 1992
  297. --- /usr/local/src/perl/sybase/dist-1.5/sybperl.1    Thu Jun 25 13:18:11 1992
  298. ***************
  299. *** 1,5 ****
  300.   .\".po 4
  301. ! .TH SYBPERL 1 "3 September 1991"
  302.   .ad
  303.   .nh
  304.   .SH NAME
  305. --- 1,5 ----
  306.   .\".po 4
  307. ! .TH SYBPERL 1 "24 June 1992"
  308.   .ad
  309.   .nh
  310.   .SH NAME
  311. ***************
  312. *** 6,13 ****
  313.   sybperl \- Perl access to Sybase databases
  314.   .SH SYNOPSIS
  315.   .nf
  316. ! $dbproc  = &dblogin([$user[, $pwd]])
  317. ! $dbproc1 = &dbopen()
  318.          &dbclose($dbproc)
  319.   $ret     = &dbcmd($dbproc, $sql_cmd)
  320.   $ret     = &dbsqlexec($dbproc)
  321. --- 6,13 ----
  322.   sybperl \- Perl access to Sybase databases
  323.   .SH SYNOPSIS
  324.   .nf
  325. ! $dbproc  = &dblogin([$user[, $pwd[, $server]]])
  326. ! $dbproc1 = &dbopen([$server])
  327.          &dbclose($dbproc)
  328.   $ret     = &dbcmd($dbproc, $sql_cmd)
  329.   $ret     = &dbsqlexec($dbproc)
  330. ***************
  331. *** 40,47 ****
  332.   The following functions are provided:
  333.   
  334.   .nf
  335. ! \fB$dbproc  = &dblogin([$user[, $pwd]])\fP
  336. ! \fB&dbproc1 = &dbopen()\fP
  337.   \fB          &dbclose($dbproc)\fP
  338.   \fB$status  = &dbcmd($dbproc, $sql_cmd)\fP
  339.   \fB$status  = &dbsqlexec($dbproc)\fP
  340. --- 40,47 ----
  341.   The following functions are provided:
  342.   
  343.   .nf
  344. ! \fB$dbproc  = &dblogin([$user[, $pwd[, $server]]])\fP
  345. ! \fB&dbproc1 = &dbopen([$server])\fP
  346.   \fB          &dbclose($dbproc)\fP
  347.   \fB$status  = &dbcmd($dbproc, $sql_cmd)\fP
  348.   \fB$status  = &dbsqlexec($dbproc)\fP
  349. ***************
  350. *** 58,70 ****
  351.   
  352.   Differences with DB-Library:
  353.   
  354. ! \fB&dblogin\fP takes 2 optional arguements (the userid and the
  355. ! password). These default to the Unix userid, and the null password.
  356.   
  357.   \fB&dblogin\fP returns a \fBDBPROCESS\fP, not a \fBLOGINREC\fP. This
  358.   simplifies the call to open a connection to a Sybase dataserver
  359. ! somewhat. Further \fBDBPROCESSes\fP can be opened using
  360. ! \fB&dbopen()\fP (No arguments). The number of simultaneous DBPROCESSes
  361.   is limited to 25 (This can be changed by altering a #define in sybperl.c).
  362.   
  363.   The \fB$dbproc\fP parameter is optional, and defaults to the DBPROCESS returned
  364. --- 58,73 ----
  365.   
  366.   Differences with DB-Library:
  367.   
  368. ! \fB&dblogin\fP takes 3 optional arguements (the userid, the
  369. ! password and the server to connect to). These default to the Unix
  370. ! userid, the null password and the default server (from the DSQUERY
  371. ! environment variable).
  372.   
  373.   \fB&dblogin\fP returns a \fBDBPROCESS\fP, not a \fBLOGINREC\fP. This
  374.   simplifies the call to open a connection to a Sybase dataserver
  375. ! somewhat. If the login fails for any reason \fB&dblogin\fP returns -1.
  376. ! Further \fBDBPROCESSes\fP can be opened using
  377. ! \fB&dbopen([$server])\fP (with an optional server name to connect to). The number of simultaneous DBPROCESSes
  378.   is limited to 25 (This can be changed by altering a #define in sybperl.c).
  379.   
  380.   The \fB$dbproc\fP parameter is optional, and defaults to the DBPROCESS returned
  381. ***************
  382. *** 85,98 ****
  383.   \fB&dbfcmd\fP is not implemented, but can be emulated by using
  384.   \fIsprintf\fP as in \fI&dbcmd($dbproc, sprintf("%d", $num_val))\;\fP
  385.   
  386. - One cannot log in to a specific server (ie \fIdbopen()\fP is always
  387. - called with a \fINULL\fP second parameter. However, setting the
  388. - \fBDSQUERY\fP environment variable (as in \fI$ENV{'DSQUERY'} =
  389. - $server\fP) will work.
  390.   
  391.   .SH OPTIONS
  392.   
  393.   See the \fIPerl(1)\fP manual page.
  394.   
  395.   .SH FILES
  396.   
  397. --- 88,103 ----
  398.   \fB&dbfcmd\fP is not implemented, but can be emulated by using
  399.   \fIsprintf\fP as in \fI&dbcmd($dbproc, sprintf("%d", $num_val))\;\fP
  400.   
  401.   
  402.   .SH OPTIONS
  403.   
  404.   See the \fIPerl(1)\fP manual page.
  405. + 
  406. + .SH BUGS
  407. + 
  408. + Memory usage can become very large in certain conditions when
  409. + using a version of Perl prior to 4.035. This
  410. + can be circumvented - see the BUGS file in the Sybperl distribution.
  411.   
  412.   .SH FILES
  413.   
  414. diff -c -r ./sybperl.c /usr/local/src/perl/sybase/dist-1.5/sybperl.c
  415. *** ./sybperl.c    Wed Jun 24 13:37:37 1992
  416. --- /usr/local/src/perl/sybase/dist-1.5/sybperl.c    Thu Jun 25 13:18:10 1992
  417. ***************
  418. *** 1,6 ****
  419. ! static char SccsId[] = "@(#)sybperl.c    1.9    12/20/91";
  420.   /************************************************************************/
  421. ! /*    Copyright 1991 by Michael Peppler and ITF Management SA     */
  422.   /*                                    */
  423.   /*    Full ownership of this software, and all rights pertaining to     */
  424.   /*    the for-profit distribution of this software, are retained by     */
  425. --- 1,6 ----
  426. ! static char SccsId[] = "@(#)sybperl.c    1.11    6/24/92";
  427.   /************************************************************************/
  428. ! /*    Copyright 1991, 1992 by Michael Peppler and ITF Management SA     */
  429.   /*                                    */
  430.   /*    Full ownership of this software, and all rights pertaining to     */
  431.   /*    the for-profit distribution of this software, are retained by     */
  432. ***************
  433. *** 193,199 ****
  434.   {
  435.       STR **st = stack->ary_array + sp;
  436.       ARRAY *ary = stack;    
  437. -     register int i;
  438.       register STR *Str;        /* used in str_get and str_gnum macros */
  439.       int inx = -1;        /* Index into dbproc[] array. Passed as first parameter to nearly all &dbxxx() calls */
  440.   
  441. --- 193,198 ----
  442. ***************
  443. *** 223,260 ****
  444.       switch (ix)
  445.       {
  446.         case US_dblogin:
  447. !     if (items > 2)
  448. !         fatal("Usage: &dblogin([user[,pwd]])");
  449.       if (login)
  450.           fatal("&dblogin() called twice.");
  451.       else
  452.       {
  453. !         int retval;
  454.   
  455.           login = dblogin();
  456. !         if(items)
  457.           {
  458. !         DBSETLUSER(login, (char *)str_get(STACK(sp)[1]));
  459. !         if(items > 1)
  460. !             DBSETLPWD(login, (char *)str_get(STACK(sp)[2]));
  461.           }
  462.   
  463. !         dbproc[0] = dbopen(login, NULL);
  464. !         str_numset(STACK(sp)[0], (double) 0);
  465.       }
  466.       break;
  467.         case US_dbopen:
  468. !     if (items != 0)
  469. !         fatal("Usage: $dbproc = &dbopen;");
  470.       else
  471.       {
  472.           int j;
  473.           for(j = 0; j < MAX_DBPROCS; ++j)
  474.           if(dbproc[j] == NULL)
  475.               break;
  476.           if(j == MAX_DBPROCS)
  477.           fatal("&dbopen: No more dbprocs available.");
  478. !         dbproc[j] = dbopen(login, NULL);
  479.           str_numset(STACK(sp)[0], (double) j);
  480.       }
  481.       break;
  482. --- 222,275 ----
  483.       switch (ix)
  484.       {
  485.         case US_dblogin:
  486. !     if (items > 3)
  487. !         fatal("Usage: &dblogin([user[,pwd[,server]]])");
  488.       if (login)
  489.           fatal("&dblogin() called twice.");
  490.       else
  491.       {
  492. !         int retval = 0;
  493. !         char *server = NULL, *user = NULL, *pwd = NULL;
  494.   
  495.           login = dblogin();
  496. !         switch(items)
  497.           {
  498. !           case 3:
  499. !         server = (char *)str_get(STACK(sp)[3]);
  500. !           case 2:
  501. !         pwd = (char *)str_get(STACK(sp)[2]);
  502. !         if(pwd && strlen(pwd))
  503. !             DBSETLPWD(login, pwd);
  504. !           case 1:
  505. !         user = (char *)str_get(STACK(sp)[1]);
  506. !         if(user && strlen(user))
  507. !             DBSETLUSER(login, user);
  508.           }
  509. +         
  510. +         
  511. +         if((dbproc[0] = dbopen(login, server)) == NULL)
  512. +         retval = -1;
  513.   
  514. !         str_numset(STACK(sp)[0], (double) retval);
  515.       }
  516.       break;
  517.         case US_dbopen:
  518. !     if (items > 1)
  519. !         fatal("Usage: $dbproc = &dbopen([server]);");
  520.       else
  521.       {
  522.           int j;
  523. +         char *server = NULL;
  524. +         
  525.           for(j = 0; j < MAX_DBPROCS; ++j)
  526.           if(dbproc[j] == NULL)
  527.               break;
  528.           if(j == MAX_DBPROCS)
  529.           fatal("&dbopen: No more dbprocs available.");
  530. !         if(items == 1)
  531. !         server = (char *)str_get(STACK(sp)[1]);
  532. !         
  533. !         dbproc[j] = dbopen(login, server);
  534.           str_numset(STACK(sp)[0], (double) j);
  535.       }
  536.       break;
  537. ***************
  538. *** 951,956 ****
  539. --- 966,973 ----
  540.   
  541.       if(ix < 0 || ix >= MAX_DBPROCS)
  542.       fatal("$dbproc parameter is out of range.");
  543. +     if(dbproc[ix] == NULL || DBDEAD(dbproc[ix]))
  544. +     fatal("$dbproc parameter is NULL or the connection to the server has been closed.");
  545.       return ix;
  546.   }
  547.   
  548. Common subdirectories: ./t and /usr/local/src/perl/sybase/dist-1.5/t
  549. diff -c -r ./eg/README /usr/local/src/perl/sybase/dist-1.5/eg/README
  550. *** ./eg/README    Thu Jun 25 13:16:19 1992
  551. --- /usr/local/src/perl/sybase/dist-1.5/eg/README    Thu Jun 25 13:18:20 1992
  552. ***************
  553. *** 0 ****
  554. --- 1,48 ----
  555. +     @(#)README    1.3    6/25/92
  556. + 
  557. + 
  558. +     This directory contains a number of example scripts for Sybperl.
  559. + 
  560. + 
  561. +     
  562. +     space.pl        Report the space used by your database.
  563. +     capture.pl        Create a table with information from
  564. +             /etc/passwd.
  565. +     report.pl        Report information from the above table.
  566. +     sql.pl        Utility used by the above three scripts.
  567. +     dbschema.pl        Extract an Isql script to re-create a database
  568. + 
  569. + 
  570. +     
  571. +     Dbschema.pl Documentation:
  572. +     --------------------------
  573. +     
  574. +     This is a Sybperl script that extracts a Sybase database definition
  575. +     and creates an Isql script to rebuild the database.
  576. + 
  577. +     dbschema.pl is NOT a production script, in the sense that it does
  578. +     not do ALL the necessary work. The script tries to do the right
  579. +     thing, but in certain cases (mainly where the owner of an object
  580. +     is not the DBO) it creates an invalid or incorrect Isql command. I
  581. +     have tried to detect these cases, and log them both to stdout and to a
  582. +     file, so that the script can be corrected.
  583. +     Please note also that dbschema.pl logs in to Sybase with the
  584. +     default (Unix) user id, and a NULL password. This behaviour is
  585. +     maybe not OK for your site.
  586. + 
  587. +     Usage:
  588. + 
  589. +         itf1% dbschema.pl -d excalibur -o excalibur.isql -v
  590. + 
  591. +     Run dbschema on database 'excalibur', place the resulting script
  592. +     in 'excalibur.isql' (and the error log in 'excalibur.isql.log')
  593. +     and turn on verbose output on the console. The default database is
  594. +     'master', the default output file is 'script.isql'.
  595. + 
  596. + 
  597. +     I hope this will prove of some use, and I would be more than happy
  598. +     to hear of any improvements :-)
  599. + 
  600. + 
  601. +     Michael Peppler        mpeppler@itf.ch
  602. + 
  603. diff -c -r ./eg/capture.pl /usr/local/src/perl/sybase/dist-1.5/eg/capture.pl
  604. *** ./eg/capture.pl    Wed Jun 24 13:37:33 1992
  605. --- /usr/local/src/perl/sybase/dist-1.5/eg/capture.pl    Thu Jun 25 13:18:17 1992
  606. ***************
  607. *** 1,5 ****
  608. --- 1,9 ----
  609.   #! /usr/local/bin/sybperl
  610.   
  611. + #
  612. + #    @(#)capture.pl    1.1    6/24/92
  613. + #
  614. + 
  615.   require "sybperl.pl";
  616.   require "sql.pl";
  617.   
  618. diff -c -r ./eg/dbschema.pl /usr/local/src/perl/sybase/dist-1.5/eg/dbschema.pl
  619. *** ./eg/dbschema.pl    Wed Jun 24 13:38:17 1992
  620. --- /usr/local/src/perl/sybase/dist-1.5/eg/dbschema.pl    Thu Jun 25 13:18:19 1992
  621. ***************
  622. *** 0 ****
  623. --- 1,377 ----
  624. + #! /usr/local/bin/sybperl
  625. + #
  626. + #    @(#)dbschema.pl    1.3    6/24/92
  627. + #
  628. + #
  629. + #    dbschema.pl    A script to extract a database structure from
  630. + #            a Sybase database
  631. + #
  632. + #    Written by:    Michael Peppler (mpeppler@itf.ch)
  633. + #    Last Modified:  24 June 1992
  634. + #
  635. + #    Usage:        dbschema.pl -d database -o script.name -t pattern -v
  636. + #                where   database is self-explanatory (default: master)
  637. + #                                   script.name is the output file (default: script.isql)
  638. + #                                   pattern is the pattern of object names (in sysobjects)
  639. + #                                           that we will look at (default: %)
  640. + #
  641. + #                -v turns on a verbose switch.
  642. + #
  643. + 
  644. + 
  645. + require 'sybperl.pl';
  646. + require 'getopts.pl';
  647. + require 'ctime.pl';
  648. + 
  649. + @nul = ('not null','null');
  650. + 
  651. + select(STDOUT); $| = 1;        # make unbuffered
  652. + 
  653. + do Getopts('d:t:o:v');
  654. + 
  655. + $opt_d = 'master' unless $opt_d;
  656. + $opt_o = 'script.isql' unless $opt_o;
  657. + $opt_t = '%' unless $opt_t;
  658. + 
  659. + open(SCRIPT, "> $opt_o") || die "Can't open $opt_o: $!\n";
  660. + open(LOG, "> $opt_o.log") || die "Can't open $opt_o.log: $!\n";
  661. + 
  662. + #
  663. + # NOTE: We login to Sybase with the default (Unix) user id.
  664. + #       We should probably login as 'SA', and get the passwd
  665. + #       from the user at run time.
  666. + #
  667. + $dbproc = &dblogin;
  668. + &dbuse($dproc, $opt_d);
  669. + 
  670. + chop($date = &ctime(time));
  671. + 
  672. + 
  673. + print "dbschema.pl on Database $opt_d\n";
  674. + 
  675. + print LOG "Error log from dbschema.pl on Database $opt_d on $date\n\n";
  676. + print LOG "The following objects cannot be reliably created from the script in $opt_o.
  677. + Please correct the script to remove any inconsistencies.\n\n";
  678. + 
  679. + print SCRIPT
  680. +     "/* This Isql script was generated by dbschema.pl on $date.
  681. + ** The indexes need to be checked: column names & index names
  682. + ** might be truncated!
  683. + */\n";
  684. + 
  685. + print SCRIPT "\nuse $opt_d\ngo\n"; # Change to the appropriate database
  686. + 
  687. + 
  688. + # first, Add the appropriate user data types:
  689. + #
  690. + 
  691. + print "Add user-defined data types...";
  692. + print SCRIPT
  693. +     "/* Add user-defined data types: */\n\n";
  694. + 
  695. + &dbcmd($dbproc, "select s.length, s.name, st.name,\n");
  696. + &dbcmd($dbproc, "       object_name(s.tdefault),\n");
  697. + &dbcmd($dbproc, "       object_name(s.domain)\n");
  698. + &dbcmd($dbproc, "from   $opt_d.dbo.systypes s, $opt_d.dbo.systypes st\n");
  699. + &dbcmd($dbproc, "where  st.type = s.type\n");
  700. + &dbcmd($dbproc, "and s.usertype > 100 and st.usertype < 100 and st.usertype != 18\n");
  701. + &dbsqlexec($dbproc);
  702. + &dbresults($dbproc);
  703. + 
  704. + 
  705. + while((@dat = &dbnextrow($dbproc)))
  706. + {
  707. +     print SCRIPT "sp_addtype $dat[1],";
  708. +     if ($dat[2] =~ /char|binary/)
  709. +     {
  710. +         print SCRIPT "'$dat[2]($dat[0])'";
  711. +     }
  712. +     else
  713. +     {
  714. +         print SCRIPT "$dat[2]";
  715. +     }
  716. +     print SCRIPT "\ngo\n";
  717. +                 # Now remeber the default & rule for later.
  718. +     $urule{$dat[1]} = $dat[4] if $dat[4] !~ /NULL/;
  719. +     $udflt{$dat[1]} = $dat[3] if $dat[3] !~ /NULL/;
  720. + }
  721. + 
  722. + print "Done\n";
  723. + 
  724. + print "Create rules...";
  725. + print SCRIPT
  726. +     "\n/* Now we add the rules... */\n\n";
  727. + 
  728. + &getObj('Rule', 'R');
  729. + print "Done\n";
  730. + 
  731. + print "Create defaults...";
  732. + print SCRIPT
  733. +     "\n/* Now we add the defaults... */\n\n";
  734. + 
  735. + &getObj('Default', 'D');
  736. + print "Done\n";
  737. + 
  738. + print "Bind rules & defaults to user data types...";
  739. + print SCRIPT "/* Bind rules & defaults to user data types... */\n\n";
  740. + 
  741. + while(($dat, $dflt)=each(%udflt))
  742. + {
  743. +     print SCRIPT "sp_bindefault $dflt, $dat\ngo\n";
  744. + }
  745. + while(($dat, $rule) = each(%urule))
  746. + {
  747. +     print SCRIPT "sp_bindrule $rule, $dat\ngo\n";
  748. + }
  749. + print "Done\n";
  750. + 
  751. + print "Create Tables & Indices...";
  752. + print "\n" if $opt_v;
  753. + 
  754. + &dbcmd($dbproc, "select o.name,u.name, o.id\n");
  755. + &dbcmd($dbproc, "from $opt_d.dbo.sysobjects o, $opt_d.dbo.sysusers u\n");
  756. + &dbcmd($dbproc, "where o.type = 'U' and o.name like '$opt_t' and u.uid = o.uid\n");
  757. + &dbcmd($dbproc, "order by o.name\n");
  758. + 
  759. + &dbsqlexec($dbproc);
  760. + &dbresults($dbproc);
  761. + 
  762. + while((@dat = &dbnextrow($dbproc)))
  763. + {
  764. +     $_ = join('@', @dat);    # join the data together on a line
  765. +     push(@tables,$_);        # and save it in a list
  766. + }
  767. + 
  768. + 
  769. + foreach (@tables)        # For each line in the list
  770. + {
  771. +     @tab = split(/@/, $_);
  772. + 
  773. +     print "Creating table $tab[0], owner $tab[1]\n" if $opt_v;
  774. + 
  775. +     print SCRIPT "/* Start of description of table $tab[1].$tab[0] */\n\n";
  776. + 
  777. +     &dbcmd($dbproc, "select Column_name = c.name, \n");
  778. +     &dbcmd($dbproc, "       Type = t.name, \n");
  779. +     &dbcmd($dbproc, "       Length = c.length, \n");
  780. +     &dbcmd($dbproc, "       Nulls = convert(bit, (c.status & 8)),\n");
  781. +     &dbcmd($dbproc, "       Default_name = object_name(c.cdefault),\n");
  782. +     &dbcmd($dbproc, "       Rule_name = object_name(c.domain)\n");
  783. +     &dbcmd($dbproc, "from   $opt_d.dbo.syscolumns c, $opt_d.dbo.systypes t\n");
  784. +     &dbcmd($dbproc, "where  c.id = $tab[2]\n");
  785. +     &dbcmd($dbproc, "and    c.usertype *= t.usertype\n");
  786. + 
  787. +     &dbsqlexec($dbproc);
  788. +     &dbresults($dbproc);
  789. + 
  790. +     undef(%rule);
  791. +     undef(%dflt);
  792. + 
  793. +     print SCRIPT "\n\nCREATE TABLE $opt_d.$tab[1].$tab[0]\n ("; 
  794. +     $first = 1;
  795. +     while((@field = &dbnextrow($dbproc)))
  796. +     {
  797. +         print SCRIPT ",\n" if !$first;        # add a , and a \n if not first field in table
  798. +         
  799. +         print SCRIPT "\t$field[0] \t$field[1]";
  800. +         print SCRIPT "($field[2])" if $field[1] =~ /char|bin/;
  801. +         print SCRIPT " $nul[$field[3]]";
  802. +     
  803. +     $rule{"$tab[0].$field[0]"} = $field[5] if ($field[5] !~ /NULL/ && $urule{$field[1]} ne $field[5]);
  804. +     $dflt{"$tab[0].$field[0]"} = $field[4] if ($field[4] !~ /NULL/ && $udflt{$field[1]} ne $field[4]);;
  805. +         $first = 0 if $first;
  806. +         
  807. +     }
  808. +     print SCRIPT " )\n";
  809. + 
  810. + # now get the indexes...
  811. + #
  812. + 
  813. +     print "Indexes for table $tab[1].$tab[0]\n" if $opt_v;
  814. +     
  815. +     &dbcmd($dbproc, "sp_helpindex '$tab[1].$tab[0]'\n");
  816. + 
  817. +     &dbsqlexec($dbproc);
  818. +     &dbresults($dbproc);
  819. + 
  820. +     while((@field = &dbnextrow($dbproc)))
  821. +     {
  822. +         print SCRIPT "\nCREATE ";
  823. +         print SCRIPT "unique " if $field[1] =~ /unique/;
  824. +         print SCRIPT "clustered " if $field[1] =~ /^clust/;
  825. +         print SCRIPT "index $field[0]\n";
  826. +         @col = split(/,/,$field[2]);
  827. +         print SCRIPT "on $opt_d.$tab[1].$tab[0] (";
  828. +         $first = 1;
  829. +         foreach (@col)
  830. +         {
  831. +             print SCRIPT ", " if !$first;
  832. +             $first = 0;
  833. +             print SCRIPT "$_";
  834. +         }
  835. +         print SCRIPT ")\n";
  836. +     }
  837. + 
  838. +     &getPerms("$tab[1].$tab[0]");
  839. + 
  840. +     print SCRIPT "go\n";
  841. + 
  842. +     print "Bind rules & defaults to columns...\n" if $opt_v;
  843. +     print SCRIPT "/* Bind rules & defaults to columns... */\n\n";
  844. + 
  845. +     if($tab[1] ne 'dbo' && (keys(%dflt) || keys(%rules)))
  846. +     {
  847. +     print SCRIPT "/* The owner of the table is $tab[1].
  848. + ** I can't bind the rules/defaults to a table of which I am not the owner.
  849. + ** The procedures below will have to be run manualy by user $tab[1].
  850. + */";
  851. +     print LOG "Defaults/Rules for $tab[1].$tab[0] could not be bound\n";
  852. +     }
  853. + 
  854. +     while(($dat, $dflt)=each(%dflt))
  855. +     {
  856. +     print SCRIPT "/* " if $tab[1] ne 'dbo';
  857. +     print SCRIPT "sp_bindefault $dflt, '$dat'";
  858. +     if($tab[1] ne 'dbo')
  859. +     {
  860. +         print SCRIPT " */\n";
  861. +     }
  862. +     else
  863. +     {
  864. +         print SCRIPT "\ngo\n";
  865. +     }
  866. +     }
  867. +     while(($dat, $rule) = each(%rule))
  868. +     {
  869. +     print SCRIPT "/* " if $tab[1] ne 'dbo';
  870. +     print SCRIPT "sp_bindrule $rule, '$dat'";
  871. +     if($tab[1] ne 'dbo')
  872. +     {
  873. +         print SCRIPT " */\n";
  874. +     }
  875. +     else
  876. +     {
  877. +         print SCRIPT "\ngo\n";
  878. +     }
  879. +     }
  880. +     print SCRIPT "\n/* End of description of table $tab[1].$tab[0] */\n";
  881. + 
  882. + }
  883. + 
  884. + print "Done\n";
  885. + 
  886. + 
  887. + #
  888. + # Now create any views that might exist
  889. + #
  890. + 
  891. + print "Create views...";
  892. + print SCRIPT
  893. +     "\n/* Now we add the views... */\n\n";
  894. + 
  895. + &getObj('View', 'V');
  896. + 
  897. + print "Done\n";
  898. + 
  899. + #
  900. + # Now create any stored procs that might exist
  901. + #
  902. + 
  903. + print "Create stored procs...";
  904. + print SCRIPT
  905. +     "\n/* Now we add the stored procedures... */\n\n";
  906. + &getObj('Stored Proc', 'P');
  907. + 
  908. + print "Done\n";
  909. + 
  910. + #
  911. + # Now create the triggers
  912. + #
  913. + 
  914. + print "Create triggers...";
  915. + print SCRIPT
  916. +     "\n/* Now we add the triggers... */\n\n";
  917. + 
  918. + &getObj('Trigger', 'TR');
  919. + 
  920. + 
  921. + print "Done\n";
  922. + 
  923. + print "\nLooks like I'm all done!\n";
  924. + close(SCRIPT);
  925. + close(LOG);
  926. + 
  927. + &dbexit;
  928. + 
  929. + 
  930. + sub getPerms
  931. + {
  932. +     local($obj) = $_[0];
  933. +     local($ret, @dat, $act, $cnt);
  934. + 
  935. +     &dbcmd($dbproc, "sp_helprotect '$obj'\n");
  936. +     &dbsqlexec;
  937. + 
  938. +     $cnt = 0;
  939. +     while(($ret = &dbresults) != $NO_MORE_RESULTS && $ret != $FAIL)
  940. +     {
  941. +     while(@dat = &dbnextrow)
  942. +     {
  943. +         $act = 'to';
  944. +         $act = 'from' if $dat[0] =~ /Revoke/;
  945. +         print SCRIPT "$dat[0] $dat[1] on $obj $act $dat[2]\n";
  946. +         ++$cnt;
  947. +     }
  948. +     }
  949. +     $cnt;
  950. + }
  951. + 
  952. + sub getObj
  953. + {
  954. +     local($objname, $obj) = @_;
  955. +     local(@dat, @items, @vi, $found);
  956. +     
  957. +     &dbcmd($dbproc, "select o.name, u.name, o.id\n");
  958. +     &dbcmd($dbproc, "from $opt_d.dbo.sysobjects o, $opt_d.dbo.sysusers u\n");
  959. +     &dbcmd($dbproc, "where o.type = '$obj' and o.name like '$opt_t' and u.uid = o.uid\n");
  960. +     &dbcmd($dbproc, "order by o.name\n");
  961. + 
  962. +     &dbsqlexec($dbproc);
  963. +     &dbresults($dbproc);
  964. + 
  965. +     while((@dat = &dbnextrow($dbproc)))
  966. +     {                # 
  967. +     $_ = join('@', @dat);    # join the data together on a line
  968. +     push(@items, $_);    # and save it in a list
  969. +     }
  970. + 
  971. +     foreach (@items)
  972. +     {
  973. +     @vi = split(/@/, $_);
  974. +     $found = 0;
  975. + 
  976. +     &dbcmd($dbproc, "select text from syscomments where id = $vi[2]");
  977. +     &dbsqlexec;
  978. +     &dbresults;
  979. +     
  980. +     print SCRIPT
  981. +         "/* $objname $vi[0], owner $vi[1] */\n";
  982. + 
  983. +     while(($text) = &dbnextrow)
  984. +     {
  985. +         if(!$found && $vi[1] ne 'dbo')
  986. +         {
  987. +         ++$found if($text =~ /$vi[1]/);
  988. +         }
  989. +         print SCRIPT $text;
  990. +     }
  991. +     print SCRIPT "\ngo\n";
  992. +     if(!$found && $vi[1] ne 'dbo')
  993. +     {
  994. +         print "**Warning**\n$objname $vi[0] has owner $vi[1]\nbut this is not mentioned in the CREATE PROC statement!!\n";
  995. +         print LOG "$objname $vi[0] (owner $vi[1])\n";
  996. +     }
  997. +     }
  998. + }
  999. + 
  1000. + 
  1001. diff -c -r ./eg/report.pl /usr/local/src/perl/sybase/dist-1.5/eg/report.pl
  1002. *** ./eg/report.pl    Wed Jun 24 13:37:34 1992
  1003. --- /usr/local/src/perl/sybase/dist-1.5/eg/report.pl    Thu Jun 25 13:18:18 1992
  1004. ***************
  1005. *** 1,5 ****
  1006. --- 1,9 ----
  1007.   #! /usr/local/bin/sybperl
  1008.   
  1009. + #
  1010. + #    @(#)report.pl    1.1    6/24/92
  1011. + #
  1012. + 
  1013.   require "sybperl.pl";
  1014.   require "sql.pl";
  1015.   
  1016. diff -c -r ./eg/space.pl /usr/local/src/perl/sybase/dist-1.5/eg/space.pl
  1017. *** ./eg/space.pl    Wed Jun 24 13:37:34 1992
  1018. --- /usr/local/src/perl/sybase/dist-1.5/eg/space.pl    Thu Jun 25 13:18:16 1992
  1019. ***************
  1020. *** 1,5 ****
  1021. --- 1,9 ----
  1022.   #! /usr/local/bin/sybperl
  1023.   
  1024. + #
  1025. + #    @(#)space.pl    1.1    6/24/92
  1026. + #
  1027. + 
  1028.   require "sybperl.pl";
  1029.   require "sql.pl";
  1030.   
  1031. diff -c -r ./eg/sql.pl /usr/local/src/perl/sybase/dist-1.5/eg/sql.pl
  1032. *** ./eg/sql.pl    Wed Jun 24 13:37:35 1992
  1033. --- /usr/local/src/perl/sybase/dist-1.5/eg/sql.pl    Thu Jun 25 13:18:16 1992
  1034. ***************
  1035. *** 1,3 ****
  1036. --- 1,7 ----
  1037. + #
  1038. + #    @(#)sql.pl    1.1    6/24/92
  1039. + #
  1040. + 
  1041.   sub sql {
  1042.       local($db,$sql,$sep)=@_;            # local copy parameters
  1043.   
  1044.  
  1045. exit 0 # Just in case...
  1046.