home *** CD-ROM | disk | FTP | other *** search
/ PDA Software Library / pdasoftwarelib.iso / PSION / UTILS / DBSORT / DBSORT.OPL next >
Encoding:
Text File  |  1993-11-15  |  4.7 KB  |  233 lines
  1. rem DBSORT - Database sort 1.0
  2. rem Copyright 1993 Michael Geary - All rights reserved
  3.  
  4. proc dbsort:
  5.     global info%(4), maxrec%, r%(2000), s%(2000)
  6.     local off%(6), total%, time0&, from$(128), to$(128)
  7.     maxrec% = 2000 : rem should match r% and s% array sizes
  8.     trap cache 1500, 1500
  9.     font 7, 0
  10.     from$ = "\dat\*.dbf"
  11.     to$ = "\dat\"
  12.     do
  13.         dinit "Sort database file"
  14.         dfile from$, "Input file", 64
  15.         dfile to$, "Output file", 1+2+64
  16.         if dialog = 0
  17.             stop
  18.         endif
  19.         to$ = parse$( to$, from$, off%() )
  20.     until okwrite%:( from$, to$ )
  21.     trap mkdir left$( to$, off%(4)-1 )
  22.     time0& = time&:
  23.     openr from$, a, a$, b$
  24.     trap delete to$
  25.     create to$, b, a$, b$, c$, d$, e$, f$, g$, h$, i$, j$, k$, l$, m$, n$, o$, p$, q$, r$, s$, t$, u$, v$, w$, x$, y$, z$, aa$, bb$, cc$, dd$, ee$, ff$
  26.     odbinfo info%()
  27.     use a
  28.     print "Input file: " + from$
  29.     print "Output file: " + to$
  30.     if dsccopy%:( 1, 2 ) < 0
  31.         fatal:( "Error writing file!" )
  32.     endif
  33.     total% = count
  34.     if total% = 0
  35.         fatal:( "File is empty!" )
  36.     endif
  37.     print "Reading key fields"
  38.     rdkeys:( total% )
  39.     print "Sorting " + num$(total%,99) + " records"
  40.     qsort:( 1, total% )
  41.     print "Copying records"
  42.     cpyall:( total% )
  43.     use b
  44.     close
  45.     print "All done! " + num$(time&:-time0&,99) + " seconds elapsed"
  46.     beep 4,400
  47.     beep 4,350
  48.     beep 4,300
  49.     get
  50. endp
  51.  
  52. proc rdkeys:( total% )
  53.     local i%, keys&, l1%, l2%, m%, t$(255)
  54.     keys& = 0
  55.     i% = 0
  56.     first
  57.     while not eof
  58.         i% = i% + 1
  59.         if i% > maxrec%
  60.             fatal:( "Too many records!" )
  61.         endif
  62.         r%(i%) = i%
  63.         l1% = len(a.a$)
  64.         l2% = len(a.b$)
  65.         keys& = keys& + l1% + l2% + 2 + 2
  66.         m% = alloc( l1% + l2% + 2 )
  67.         if m% = 0
  68.             fatal:( "Out of memory for keys!" )
  69.         endif
  70.         s%(i%) = m%
  71.         t$ = upper$(a.a$)
  72.         memcpy:( uadd(addr(t$),1), m%, l1% )
  73.         m% = uadd( m%, l1% )
  74.         pokeb m%, 1
  75.         m% = uadd( m%, 1 )
  76.         t$ = upper$(a.b$)
  77.         memcpy:( uadd(addr(t$),1), m%, l2% )
  78.         m% = uadd( m%, l2% )
  79.         pokeb m%, 0
  80.         next
  81.     endwh
  82.     if i% <> total%
  83.         fatal:( "File contains wrong number of records!" )
  84.     endif
  85.     print "Used " + num$(keys&,99) + " bytes for key fields"
  86. endp
  87.  
  88. proc cpyall:( total% )
  89.     local i%, ok%
  90.     i% = 1
  91.     while i% <= total%
  92.         ok% = reccopy%:( 1, r%(i%), 2 )
  93.         if ok% < 0
  94.             fatal:( "Error writing file!" )
  95.         endif
  96.         i% = i% + 1
  97.     endwh
  98. endp
  99.  
  100. proc qsort:( left%, right% )
  101.     local i%, last%
  102.     if left% < right%
  103.         swap:( left%, (left%+right%)/2 )
  104.         last% = left%
  105.         i% = left% + 1
  106.         while i% <= right%
  107.             if strcmp%:( s%(r%(i%)), s%(r%(left%)) ) < 0
  108.                 last% = last% + 1
  109.                 swap:( last%, i% )
  110.             endif
  111.             i% = i% + 1
  112.         endwh
  113.         swap:( left%, last% )
  114.         qsort:( left%, last%-1 )
  115.         qsort:( last%+1, right% )
  116.     endif
  117. endp
  118.  
  119. proc swap:( i%, j% )
  120.     local t%
  121.     t% = r%(i%)
  122.     r%(i%) = r%(j%)
  123.     r%(j%) = t%
  124. endp
  125.  
  126. proc dsccopy%:( fsrc%, fdest% )
  127.     local len%
  128.     len% = dscread%:( fsrc% )
  129.     if len% <= 0
  130.         return len%
  131.     endif
  132.     memcpy:( peekw(uadd(info%(fsrc%),8)), peekw(uadd(info%(fdest%),8)), len%+2 )
  133.     return dscwrt%:( fdest%, len% )
  134. endp
  135.  
  136. proc dscread%:( file% )
  137.     local ax%, bx%, cx%, dx%, si%, di%
  138.     bx% = peekw(info%(file%))
  139.     ax% = $1700
  140.     if os( $D8, addr(ax%) ) and 1
  141.         return ax% or $FF00
  142.     endif
  143.     return ax%
  144. endp
  145.  
  146. proc dscwrt%:( file%, len% )
  147.     local ax%, bx%, cx%, dx%, si%, di%
  148.     cx% = len%
  149.     bx% = peekw(info%(file%))
  150.     ax% = $1800
  151.     if os( $D8, addr(ax%) ) and 1
  152.         return ax% or $FF00
  153.     endif
  154.     return 0
  155. endp
  156.  
  157. proc reccopy%:( fsrc%, recno%, fdest% )
  158.     local len%, offset%, pbuf%, psrc%
  159.     position recno%
  160.     pbuf% = peekw(uadd(info%(fsrc%),8))
  161.     offset% = peekw(uadd(info%(fsrc%),2))
  162.     psrc% = uadd(pbuf%,offset%)
  163.     len% = peekw(psrc%) and $0FFF
  164.     memcpy:( psrc%, peekw(uadd(info%(fdest%),8)), len%+2 )
  165.     return recapp%:( fdest%, len% )
  166. endp
  167.  
  168. proc recapp%:( file%, len% )
  169.     local ax%, bx%, cx%, dx%, si%, di%
  170.     cx% = len%
  171.     bx% = peekw(info%(file%))
  172.     ax% = $1100
  173.     if os( $D8, addr(ax%) ) and 1
  174.         return ax% or $FF00
  175.     endif
  176.     return 0
  177. endp
  178.  
  179. proc memcpy:( psrc%, pdest%, len% )
  180.     call( $A1, 0, len%, 0, psrc%, pdest% )
  181. endp
  182.  
  183. proc strcmp%:( s1%, s2% )
  184.     local ax%, bx%, cx%, dx%, si%, di%
  185.     local f%
  186.     si% = s1%
  187.     di% = s2%
  188.     f% = os( $AF, addr(ax%) )
  189.     if f% and $0040
  190.         return 0
  191.     elseif ( ( f% * 8 ) and $0400 ) = ( f% and $0400 )
  192.         return 1
  193.     else
  194.         return -1
  195.     endif
  196. endp
  197.  
  198. proc time&:
  199.     return int(hour)*3600 + minute*60 + second
  200. endp
  201.  
  202. proc okwrite%:( from$, to$ )
  203.     if from$ = to$
  204.         errdlg:( "Input and output files cannot be the same" )
  205.         return 0
  206.     endif
  207.     if exist(to$)
  208.         dinit "File already exists: overwrite?"
  209.         dbuttons "No", %N, "Yes", %Y
  210.         if dialog <> %y
  211.             return 0
  212.         endif
  213.     endif
  214.     return -1
  215. endp
  216.  
  217. proc errdlg:( msg$ )
  218.     dinit msg$
  219.     dbuttons "Continue", 27
  220.     dialog
  221. endp
  222.  
  223. proc fatal:( msg$ )
  224.     print msg$
  225.     beep 4,300
  226.     beep 4,400
  227.     beep 4,300
  228.     beep 4,400
  229.     get
  230.     stop
  231. endp
  232.  
  233.