Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : LADDER.ZIP
Filename : LAD_DEMO.PRG

 
Output of file : LAD_DEMO.PRG contained in archive : LADDER.ZIP
*:*********************************************************************
*:
*: Program: LAD_DEMO.PRG
*:
*: System: LADDER Demonstration Program
*: Author: Larry Seyer
*: Addr1: 1319 Lost Creek Blvd.
*: City St: Austin, TX 78746
*: Phone: (512)328-6633 (But don't call me unless you have money)
*: Copyright (c) 1989, Seyerworks Software
*: Last modified: 10-21-1989 2:42:10 AM
*:
*: Procs & Fncts: GETRUN()
*: : LADDER()
*: : PAT()
*: : PRNTLINE()
*: : ADVPNT()
*: : DEVICE()
*: : LAD_OPEN()
*: : ALLTRIM()
*: : PAD()
*: : MSG()
*:
*: Calls: GETRUN() (function in LAD_DEMO.PRG)
*: : LADDER() (function in LAD_DEMO.PRG)
*:
*: Documented 10/21/89 at 00:15 SNAP! version 3.12e
*:*********************************************************************

*******************************
* This is the demo
* the rest of the functions you can use, copy, pirate, mutilate, trash, whatever
*******************************
PARAMETERS strg
IF Pcount() < 1
@ 0,0 CLEAR TO 24,79
getrun()
ELSE
ladder(UPPER(strg))
ENDIF
QUIT
********************************
* end of the demo
********************************


**********************************************
****** [ Here is the function ] ************
**********************************************
*!*********************************************************************
*!
*! Function: LADDER()
*!
*! Called by: LAD_DEMO.PRG
*! : GETRUN() (function in LAD_DEMO.PRG)
*!
*! Calls: LAD_OPEN() (function in LAD_DEMO.PRG)
*! : PAD() (function in LAD_DEMO.PRG)
*! : MSG() (function in LAD_DEMO.PRG)
*!
*!*********************************************************************
FUNCTION ladder
PARAMETERS prefix
IF Pcount() < 1
RETURN .F.
ENDIF

* save the stuff we need to save
PRIVATE oa,D,lp,C,F,R,p

********************
* description of variables
********************
* oa - old area
* d - variable to use if no return variable is specified in DBF field
* lp - last place (record number) of LADDER
* c - character string for determining if we are to run the function (this should evaluate to TRUE or FALSE)
* f - character string of function to perform
* r - character string name of return variable
* p - character string for determining if we are to repeat this function (this should evaluate to TRUE or FALSE)

* used to pass return values from one function to another
* this is optional, you can use any public variable that is not being used for something else.
* take this out if you're real picky about extrainous vars laying around
PUBLIC pubvar
pubvar = ''

* save the area we came from
m->oa=SELECT()

* open database here
IF !lad_open()
* oops! there's nobody home at Grandma's house!
RETURN .F.
ENDIF

* because we have to find an EXACT match
* we need to pad prefix to be the lenth of the field in LADDER database
m->prefix=pad(m->prefix,LEN(ladder->code))

* find the function (at the junction [ha ha ha])
SEEK m->prefix

* ok we found one... let's get on with it
IF FOUND()
DO WHILE .T. && do forever
* trim up the condition string
m->c= Alltrim(ladder->condition)

* if nothing was entered assume we want to do it
IF LEN(m->c) < 2
m->c = '.T.'
ENDIF

* trim up the repeat string
m->p= Alltrim(ladder->repeat)

* if nothing was entered assume we don't want to repeat it
IF LEN(m->p) < 2
m->p = '.F.'
ENDIF

* if the condition character string evaluates to true...DO IT!
IF &c
* get and trim the function
m->f=Alltrim(ladder->function)

* get and trim the [variable to return to]'s name
m->r=Alltrim(ladder->return_var)

* let user know if they didn't put a function in the function field
IF LEN(m->f) < 3
m->f=msg("Function is undefined in LADDER")
RETURN .F.
ENDIF

* check to see if there is a variable to return to
IF LEN(m->r) < 1
* hmmm... it appears there's no var in thar!
* make a dummy variable to return to
m->r = 'd'
ENDIF

* save the place in the LADDER database (in case we change it in a recursive call)
m->lp=RECNO()

* select the original area
SELECT (m->oa)

* run this puppy
&r=&f

* get back to the LADDER area
SELECT ladder

* go back to where we started
* this is in case we've called this function recursivly (boy, what a tongue twisted sister!)
GO m->lp

* stop the descent if we hit the escape switch!
IF LASTKEY() = 27
RETURN .F.
ENDIF
ENDIF

* if we are to repeat, don't skip (skip anyway if we didn't DO IT) ((* IF WE ARE TO REPEAT, DON'T SKIP (SKIP ANYWAY IF WE DIDN'T DO IT)))
IF (.NOT. (&p)) .OR. (.NOT. (&c))
SKIP + 1 ALIAS ladder
ENDIF

* no sense doing something we're not supposed to...
IF ladder->code # m->prefix
EXIT
ENDIF
ENDDO
ELSE
SELECT (m->oa)
* tell them we couldn't find what they were looking for
msg("Prefix [&prefix.] is not in the LADDER database.")
ENDIF

RETURN .T.


*!*********************************************************************
*!
*! Function: GETRUN()
*!
*! Called by: LAD_DEMO.PRG
*!
*! Calls: LADDER() (function in LAD_DEMO.PRG)
*!
*! Memory Files: LADDER.LST
*!
*!*********************************************************************
FUNCTION getrun

* this function asks for a prefix to run
* then runs it in the LADDER

* if we saved the last run function, retrieve it
IF FILE('LADDER.LST')
RESTORE FROM ladder.lst ADDI
ELSE
* we either erased that file and it hasn't ran yet
PRIVATE prefix
m->prefix = SPACE(10)
ENDIF

* ask for their hand in marriage (sick!)
@ 0,0 CLEAR TO 1,79
CLEAR GETS
@ 15,0 SAY "Run what LADDER function? " GET m->prefix PICTURE "@K!"
READ

* trim it up
m->prefix=Alltrim(m->prefix)

* if it's long enough ...DO IT! [Gosh, Mr Peabody, what a big %$# you have!]
IF LEN(m->prefix) > 0
* make sure the length of the variable saved is
* long enough for any LADDER code we want to run
m->prefix=m->prefix+SPACE(10-LEN(m->prefix))

* now put this puppy in the bank
SAVE TO ladder.lst ALL LIKE prefix

* now, off to see the wizard!
ladder(m->prefix)

* no sense keeping this around
RELEASE m->prefix

ENDIF
RETURN .T.


*!*********************************************************************
*!
*! Function: PAT()
*!
*!*********************************************************************
FUNCTION pat
PARAMETERS pr,pc,pw
* print at row,col
@ pr,pc SAY pw
RETURN .T.


*!*********************************************************************
*!
*! Function: PRNTLINE()
*!
*! Called by: ADVPNT() (function in LAD_DEMO.PRG)
*!
*!*********************************************************************
FUNCTION prntline
PARAMETERS _p_txt,crlf
* prints a line of text with/without cr/lf
IF Pcount() < 2
? _p_txt
ELSE
IF Pcount() = 1
?? _p_txt
ENDIF
ENDIF
RETURN .T.


*!*********************************************************************
*!
*! Function: ADVPNT()
*!
*! Calls: PRNTLINE() (function in LAD_DEMO.PRG)
*!
*!*********************************************************************
FUNCTION advpnt
PARAMETERS _n_lns
* advances print_head/cursor _n_lns lines
PRIVATE X
FOR m->x = 1 TO _n_lns
prntline('')
NEXT
RETURN .T.


*!*********************************************************************
*!
*! Function: DEVICE()
*!
*!*********************************************************************
FUNCTION DEVICE
PARAMETERS pc
* routes all output to screen/printer
IF Pcount() = 1
SET DEVICE TO PRINT
SET CONSOLE OFF
SET PRINT ON
Setprc(0,0)
ELSE
SET DEVICE TO SCREEN
SET CONSOLE ON
SET PRINT OFF
ENDIF
RETURN .T.



*!*********************************************************************
*!
*! Function: LAD_OPEN()
*!
*! Called by: LADDER() (function in LAD_DEMO.PRG)
*!
*! Calls: MSG() (function in LAD_DEMO.PRG)
*!
*! Uses: LADDER.DBF Alias: LADDER
*!
*!*********************************************************************
FUNCTION lad_open
* check for existance of file
IF FILE('LADDER.DBF')
* a ha! we found King Tut's Jewels... and big ones they are at that!
* let's open 'em before somebody else gets here!
SELECT 0
USE ladder
* You can put the NTX file checking back in once you get the hang of what's going on here
* it's only removed now to make sure that all you database interpreter nuts
* don't screw up the DBF without re-doing the NTX! (no insult intended)
* IF !FILE('LADDER.NTX')
INDEX ON UPPER(CODE)+UPPER(ORDER) TO ladder
* ENDIF
USE ladder INDEX ladder
ELSE
* let DOS have the processor, we don't have our !@#$%^&* together
msg('Cannot find the LADDER.DBF file...MUST EXIT!')
INKEY(0)
ENDIF
RETURN Used()


*!*********************************************************************
*!
*! Function: ALLTRIM()
*!
*!*********************************************************************
FUNCTION Alltrim
PARAMETERS instr
* arn't you sick of all those LIBRARIES you have to link in every time you want to make a simple EXE?
RETURN LTRIM(RTRIM(instr))


*!*********************************************************************
*!
*! Function: PAD()
*!
*! Called by: LADDER() (function in LAD_DEMO.PRG)
*!
*!*********************************************************************
FUNCTION pad
PARAMETERS _s, _l
* just pads a string with spaces
* I use this when I have a hot date
PRIVATE _sl
m->_sl = LEN(m->_s)
IF m->_sl < m->_l
m->_s = m->_s + SPACE(m->_l - m->_sl)
ELSE
m->_s = SUBSTR(m->_s,1,m->_l)
ENDIF
RETURN m->_s


*!*********************************************************************
*!
*! Function: MSG()
*!
*! Called by: LADDER() (function in LAD_DEMO.PRG)
*! : LAD_OPEN() (function in LAD_DEMO.PRG)
*!
*!*********************************************************************
FUNCTION msg
PARAMETERS msg
* simple message function
* I got this from the massage parlor...(REALLY SICK!!!!)
* she was really cute and had bit bazongas!
@ 0,0 CLEAR TO 1,79
@ 0,0 SAY msg
INKEY(0)
RETURN .T.

* wipe screen
* have you cleaned your screen lately?
* why not do it now, while you're thinking about it!
FUNCTION clear
PARAMETERS r,c,r2,c2
IF pcount() < 2
r=ROW()
c=COL()
ENDIF
IF pcount() < 4
r2=24
c2=79
ENDIF
@ r,c CLEAR TO r2,c2
RETURN .T.

* mission is a no-go-no-mo
FUNCTION abort
QUIT
RETURN .T.

*: EOF: LAD_DEMO.PRG


  3 Responses to “Category : Dbase (Clipper, FoxBase, etc) Languages Source Code
Archive   : LADDER.ZIP
Filename : LAD_DEMO.PRG

  1. Very nice! Thank you for this wonderful archive. I wonder why I found it only now. Long live the BBS file archives!

  2. This is so awesome! 😀 I’d be cool if you could download an entire archive of this at once, though.

  3. But one thing that puzzles me is the “mtswslnkmcjklsdlsbdmMICROSOFT” string. There is an article about it here. It is definitely worth a read: http://www.os2museum.com/wp/mtswslnk/