What Pascal dialect is this? And what does it do? - progress-4gl

I'm investigating somebody's mudball of mixed shell scripts, perl scripts, C code and a curious file called 'rekening.p'.
/*--------------------------------------------------------------------------------
File: rekening.p
Description: Bepalen 868-nummer dossier
History: nabn - 16/04/2004 - Citrix Implementatie (verwijderen van copy-fsk)
jedf - 17/02/2010 - F2009/030 (Aanpassingen voor DBC)
jedf - 20/12/2010 - F2010/024 (Noor)
Pefl - 22/02/2012 - F2012/002 Sequence aanpassing + controle
--------------------------------------------------------------------------------*/
/* Parameters */
DEFINE INPUT PARAMETER iHerv AS INTEGER NO-UNDO.
DEFINE INPUT PARAMETER cParam AS CHARACTER NO-UNDO.
DEFINE OUTPUT PARAMETER cDosNr AS CHARACTER NO-UNDO.
/* Variabelen */
DEFINE VARIABLE iZetelNr AS INTEGER NO-UNDO INIT 0.
DEFINE VARIABLE dDosNr AS DECIMAL NO-UNDO.
DEFINE VARIABLE cBron AS CHARACTER NO-UNDO INIT "":u.
DEFINE VARIABLE cPrefix AS CHARACTER NO-UNDO INIT "":u.
DEFINE VARIABLE cMailParams AS CHARACTER NO-UNDO INIT "":u EXTENT 20.
DEFINE VARIABLE pvRestIn AS INTEGER NO-UNDO.
DEFINE VARIABLE pvSeqNaamTx AS CHARACTER NO-UNDO.
ASSIGN
cParam = REPLACE(cParam, ",":u, ";":u)
cParam = TRIM(cParam)
cBron = CAPS(ENTRY(1, cParam, ";":u))
NO-ERROR.
IF NUM-ENTRIES(cParam, ";":u) >= 2
THEN ASSIGN
cPrefix = CAPS(ENTRY(2, cParam, ";":u))
NO-ERROR.
/* Zet sequence naam voor controle. */
CASE cPrefix:
WHEN "934":u THEN ASSIGN pvSeqNaamTx = 'seq-banknr-noor':U.
WHEN "93489":u THEN ASSIGN pvSeqNaamTx = 'seq-banknr-auxircs':U.
OTHERWISE CASE cBron:
WHEN "DBC":u THEN .
OTHERWISE CASE iHerv:
WHEN 1 THEN ASSIGN pvSeqNaamTx = 'seq-banknr':U.
WHEN 2 THEN ASSIGN pvSeqNaamTx = 'seq-bankfinnr':U.
WHEN 3 THEN ASSIGN pvSeqNaamTx = 'seq-banknr':U.
WHEN 4 THEN ASSIGN pvSeqNaamTx = 'seq-banknr-vd':U.
WHEN 5 THEN ASSIGN pvSeqNaamTx = 'seq-banknr-cr':U.
WHEN 6 THEN ASSIGN pvSeqNaamTx = 'seq-cbk':U.
END CASE.
END CASE.
END CASE.
IF LENGTH(pvSeqNaamTx) > 0
THEN DO:
FIND FIRST fsk._sequence NO-LOCK
WHERE fsk._sequence._Seq-name = pvSeqNaamTx
NO-ERROR.
IF AVAILABLE fsk._sequence
AND fsk._sequence._Seq-Max <> ?
AND fsk._sequence._Cycle-OK = FALSE
THEN DO:
ASSIGN
pvRestIn = DYNAMIC-CURRENT-VALUE(pvSeqNaamTx, 'fsk':U)
. /* ff voor de debug. */
pvRestIn = (fsk._sequence._Seq-Max - DYNAMIC-CURRENT-VALUE(pvSeqNaamTx, 'fsk':U)) / fsk._sequence._Seq-Incr
.
IF pvRestIn < 500
THEN DO:
ASSIGN
cMailParams[1] = pvSeqNaamTx
cMailParams[2] = STRING(pvRestIn)
.
RUN programs/RootMail.p
(INPUT '868':U
,INPUT cMailParams
).
END.
END.
END.
CASE cPrefix:
WHEN "934":u THEN ASSIGN cDosNr = "9348":u + STRING(NEXT-VALUE(seq-banknr-noor , fsk), "999999":u).
WHEN '93489':U THEN ASSIGN cDosNr = '9348':U + STRING(NEXT-VALUE(seq-banknr-auxircs, fsk), '999999':U).
OTHERWISE CASE cBron:
WHEN "DBC":u THEN DO:
ASSIGN iZetelNr = INTEGER(ENTRY(2, cParam, ";":u)) NO-ERROR.
/* Waarschuwing sturen via e-mail dat 868-reeks bijna vol is */
IF CURRENT-VALUE(seq-banknr-dbc-fr, fsk) >= 49500 /* 868330 - 868334 = Franstalige klanten */
OR CURRENT-VALUE(seq-banknr-dbc-nl, fsk) >= 99500 THEN DO: /* 868335 - 868339 = Nederlandstalige klanten */
ASSIGN cMailParams[1] = (IF (iZetelNr = 0) THEN "330":u
ELSE "335":u).
RUN programs/RootMail.p(INPUT "868":u,
INPUT cMailParams).
END.
CASE iZetelNr:
WHEN 0 THEN ASSIGN cDosNr = "86833":u + STRING(NEXT-VALUE(seq-banknr-dbc-fr, fsk), "99999":u).
WHEN 1 THEN ASSIGN cDosNr = "86833":u + STRING(NEXT-VALUE(seq-banknr-dbc-nl, fsk), "99999":u).
END CASE.
END.
OTHERWISE CASE iHerv:
WHEN 1 THEN ASSIGN cDosNr = "8686":u + STRING(NEXT-VALUE(seq-banknr, fsk), "999999":u).
WHEN 2 THEN ASSIGN cDosNr = "8685":u + STRING(NEXT-VALUE(seq-bankfinnr, fsk), "999999":u).
WHEN 3 THEN ASSIGN cDosNr = "8686":u + STRING(NEXT-VALUE(seq-banknr, fsk), "999999":u).
WHEN 4 THEN ASSIGN cDosNr = "8688":u + STRING(NEXT-VALUE(seq-banknr-vd, fsk), "999999":u).
WHEN 5 THEN ASSIGN cDosNr = "8689":u + STRING(NEXT-VALUE(seq-banknr-cr, fsk), "999999":u).
WHEN 6 THEN ASSIGN cDosNr = "8687":u + STRING(NEXT-VALUE(seq-cbk, fsk), "999999":u).
END CASE.
END CASE.
END CASE.
/* Bepalen controlenummer */
ASSIGN dDosNr = DEC(cDosNr).
DO WHILE dDosNr > 2100000000:
ASSIGN dDosNr = dDosNr - 970000000.
END.
IF dDosNr MOD 97 = 0
THEN ASSIGN cDosNr = cDosNr + "97":u.
ELSE ASSIGN cDosNr = cDosNr + STRING(dDosNr MOD 97, "99":u).
Anybody got any idea if this is some sort of Pascal dialect?
And for extra points, what does it do?
Thanks in advance.

This is PROGRESS, currently also known as OpenEdge Advanced Business Language.
See also http://en.wikipedia.org/wiki/OpenEdge_Advanced_Business_Language.

Yes, this is indeed Progress ABL.
The name rekening.p is a Dutch name, also comments are in Dutch. The variable cBron can be explained as cSource (bron=source).
The main reason of this program is to return a new invoice number.
It receives 2 input parameters which contains some info about the business/customer (noor / auxircs). Based on that information the correct sequence is used to return the next (new) available number.

Related

How to detect MouseWheel in QB45

I am using the following code to trap Left/Right/Middle mouse button and mouse row/column in QB45:
(QB45 is Microsoft Quick Basic v4.5)
and I need a way to detect MouseWheel. I have looked at Ralf Brown's interrupt list without luck.
Any ideas? btw: I am using Int 0x33.
The code I am submitting is for the Microsoft Quickbasic IDE and requires the library file QB.QLB.
DECLARE SUB Mouse.Function (Var1, Var2)
DIM SHARED MouseX AS INTEGER, MouseY AS INTEGER
TYPE RegTypeX
AX AS INTEGER
BX AS INTEGER
CX AS INTEGER
DX AS INTEGER
BP AS INTEGER
SI AS INTEGER
DI AS INTEGER
Flags AS INTEGER
DS AS INTEGER
ES AS INTEGER
END TYPE
COMMON SHARED InregsX AS RegTypeX
COMMON SHARED OutregsX AS RegTypeX
DECLARE SUB InterruptX (N AS INTEGER, I AS RegTypeX, O AS RegTypeX)
CALL Mouse.Function(0, 0) ' init mouse
CALL Mouse.Function(1, 0) ' show mouse
DO
IF LEN(INKEY$) THEN
CALL Mouse.Function(2, 0) ' hide mouse
EXIT DO
END IF
' read mouse button press
CALL Mouse.Function(3, 0)
Var2 = INT((OutregsX.CX - 1) / 8 + 1)
Var3 = INT((OutregsX.DX - 1) / 8 + 1)
IF Var3 <> Mouse.Row OR Var2 <> Mouse.Column THEN
CALL Mouse.Function(2, 0) ' hide mouse
Mouse.Row = Var3
Mouse.Column = Var2
PRINT Mouse.Row, Mouse.Column
CALL Mouse.Function(1, 0) ' show mouse
END IF
Mouse.Button = False
CALL Mouse.Function(5, 0)
IF (OutregsX.AX AND 1) = 1 THEN
IF OutregsX.BX > False THEN
Mouse.Button = -1
PRINT "Left-Click"
END IF
END IF
Mouse.Button2 = False
CALL Mouse.Function(5, 1)
IF (OutregsX.AX AND 2) = 2 THEN
IF OutregsX.BX > False THEN
Mouse.Button2 = -1
PRINT "Right-Click"
END IF
END IF
Mouse.Button3 = False
CALL Mouse.Function(5, 2)
IF (OutregsX.AX AND 4) = 4 THEN
IF OutregsX.BX > False THEN
Mouse.Button3 = -1
PRINT "Middle-Click"
END IF
END IF
LOOP
END
SUB Mouse.Function (Var1, Var2)
InregsX.AX = Var1
InregsX.BX = Var2
CALL InterruptX(&H33, InregsX, OutregsX)
END SUB

When assigning the value of a MEMPTR to a LONGCHAR variable using GET-STRING, i got an error 9324

When assigning the value of a MEMPTR to a LONGCHAR variable using GET-STRING, i got an error 9324 (Attempt to exceed maximum size of a CHARACTER variable) is there any solution ?
You should use COPY-LOB statement
As definitely not solved (COPY-LOB does not work) use the following hard coding:
DEF VAR Z64 AS MEMPTR.
DEF VAR A AS LONGCHAR.
DEF VAR Z AS CHAR.
DEF VAR size64 AS INT.
SET-SIZE(Z64) = 200000. /* base64 is a function of vpxPrint */
RUN base64("e:/temp/XXXX.jpg", Z64, 10, OUTPUT size64). /* get the size */
MESSAGE "base64 string length" size64 VIEW-AS ALERT-BOX.
RUN base64("e:/temp/XXXX.jpg", Z64, 200000, OUTPUT size64).
DEF VAR i AS INT.
DEF VAR j AS INT.
DEF VAR lastSegment AS INT.
/* Segments of 30.000 bytes (PROGRESS limit) */
j = TRUNC(size64 / 30000, 0).
IF j MOD 30000 <> 0 THEN DO:
j = j + 1.
lastSegment = size64 MOD 30000.
END.
ELSE
lastSegment = 30000.
DO i = 1 TO j:
Z = GET-STRING(Z64, (i - 1) * 30000 + 1,
(IF i = j THEN lastSegment ELSE 30000)).
A = A + Z.
END.
SET-SIZE(z64) = 0.
/* LONGCHAR "A" contains the string!
===================================*/
Marcel FONDACCI
www.4GL.fr

How to Remove special characters from name-value pairs in the Webspeed URL?

I need to remove carriage return and linefeed characters that are present in Webspeed URL containing name-value pairs..How can that be done? any ideas please!
To replace characters you can use the REPLACE function
REPLACE function
Returns a string with specified substring replacements.
Syntax
REPLACE ( source-string , from-string , to-string )
Example:
DEFINE VARIABLE cTxt AS CHARACTER NO-UNDO FORMAT "x(20)".
DEFINE VARIABLE cNewTxt AS CHARACTER NO-UNDO FORMAT "x(20)".
cTxt = "abc123abc123abc123".
cNewTxt = REPLACE(cTxt, "a", "-").
DISPLAY cNewTxt .
You could target new lines using the control code ~n
REPLACE(cString, "~n", "replacing character").
Or target the individual %0d (decimal ascii code 13) and %0a's (decimal ascii code 10).
REPLACE(cString, CHR(13), "replacing character").
REPLACE(cString, CHR(10), "replacing character").
I have recently had a need to do something like this and found the following to be quite handy. This might be a bit drastic -- it removes all control codes and anything higher than ascii 126. But you can adjust those limits easily enough. (My usage is to populate text fields -- so all of that stuff is illegal input for me.)
define variable hd as character no-undo initial "0123456789ABCDEF".
function hex2char returns character ( h as character ):
define variable i as integer no-undo.
if length( h ) <> 2 or index( hd, substring( h, 1, 1 )) < 0 or index( hd, substring( h, 2, 1 )) < 0 then
return "".
i = ((( index( hd, substring( h, 1, 1 )) - 1 ) * 16 ) +
index( hd, substring( h, 2, 1 )) - 1
).
if i < 32 or i >= 127 then
return "".
else
return chr( i ).
end.
function url-decode returns character ( input url as character ):
define variable xurl as character no-undo.
define variable zurl as character no-undo.
define variable pct as integer no-undo.
/* fix known trouble makers
*/
assign
xurl = replace( url, "+", " " )
xurl = replace( xurl, "%0A%0D", "~n" ) /* <LF><CR> */
xurl = replace( xurl, "%0D%0A", "~n" ) /* <CR><LF> */
xurl = replace( xurl, "%0D", "~n" ) /* <CR> */
.
pct = index( xurl, "%" ).
do while pct > 0 and xurl > "":
assign
zurl = zurl + substring( xurl, 1, pct - 1 ) + hex2char( substring( xurl, pct + 1, 2 ))
xurl = substring( xurl, pct + 3 )
pct = index( xurl, "%" )
.
end.
return zurl + xurl.
end.
display url-decode( sampleUrl ) view-as editor size 60 by 25.

How can I convert Date() to dd-monthname-YYYY in ASP Classic?

I searched but couldn't find what I'm looking for.
How do I convert a normal Date() in ASP Classic to a string in the format dd-monthname-YYYY?
Here is an example:
Old date (mm/dd/YYYY) : 5/7/2013
New date (dd-monthname-YYYY) : 7-May-2013
Dim Dt
Dt = CDate("5/7/2013")
Response.Write Day(Dt) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
' yields 7-May-2013
' or if you actually want dd-monthname-YYYY instead of d-monthname-YYYY
Function PadLeft(Value, Digits)
PadLeft = CStr(Value)
If Len(PadLeft) < Digits Then
PadLeft = Right(String(Digits, "0") & PadLeft, Digits)
End If
End Function
Response.Write PadLeft(Day(Dt), 2) & "-" & MonthName(Month(Dt)) & "-" & Year(Dt)
'yields 07-May-2013
I wrote an ASP Classic date handling object a while back that might be of use to you. It has a .Format() method that lets you pass in format specifiers just like the Format() function from VB/VBA. If there are any parts missing, I apologize--but this should be a giant leap forward toward natural date formatting.
Private pMillisecondMatch
Function RemoveMillisecondsFromDateString(DateString) ' Handle string dates from SQL Server that have milliseconds attached
If IsEmpty(pMillisecondMatch) Then
Set pMillisecondMatch = New RegExp
pMillisecondMatch.Pattern = "\.\d\d\d$"
pMillisecondMatch.Global = False
End If
RemoveMillisecondsFromDateString = pMillisecondMatch.Replace(DateString, "")
End Function
Function DateConvert(DateValue, ValueIfError)
On Error Resume Next
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
ElseIf TypeName(DateValue) = "String" Then
DateValue = RemoveMillisecondsFromDateString(DateValue)
If IsDate(DateValue) Then
DateConvert = CDate(DateValue)
Exit Function
End If
End If
DateConvert = ValueIfError
End Function
Class AspDate
Private pValue
Public Default Property Get Value()
Value = pValue
End Property
Public Property Set Value(DateValue)
If TypeName(DateValue) = "AspDate" Then
pValue = DateValue.Value
Else
Err.Raise 60020, "Class AspDate: Invalid object type " & TypeName(DateValue) & " passed to Value property."
End If
End Property
Public Property Let Value(DateValue)
pValue = DateConvert(DateValue, Empty)
End Property
Public Property Get FormattedDate()
FormattedDate = Format("yyyy-mm-dd hh:nn:ss")
End Property
Public Function Format(Specifier)
Dim Char, Code, Pos, MonthFlag
Format = "": Code = ""
If IsEmpty(Value) Then
Format = "(Empty)"
End If
Pos = 0
MonthFlag = False
For Pos = 1 To Len(Specifier) + 1
Char = Mid(Specifier, Pos, 1)
If Char = Left(Code, 1) Or Code = "" Then
Code = Code & Char
Else
Format = Format & Part(Code, MonthFlag)
Code = Char
End If
Next
End Function
Private Function Part(Interval, MonthFlag)
Select Case LCase(Left(Interval, 1))
Case "y"
Select Case Len(Interval)
Case 1, 2
Part = Right(CStr(Year(Value)), 2)
Case 3, 4
Part = Right(CStr(Year(Value)), 4)
Case Else
Part = Right(CStr(Year(Value)), 4)
End Select
Case "m"
If Not MonthFlag Then ' this is a month calculation
MonthFlag = True
Select Case Len(Interval)
Case 1
Part = CStr(Month(Value))
Case 2
Part = Right("0" & CStr(Month(Value)), 2)
Case 3
Part = MonthName(Month(Value), True)
Case 4
Part = MonthName(Month(Value))
Case Else
Part = MonthName(Month(Value))
End Select
Else ' otherwise it's a minute calculation
Part = Right("0" & Minute(Value), 2)
End If
Case "n"
Part = Right("0" & Minute(Value), 2)
Case "d"
Part = CStr(Day(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "h"
MonthFlag = True
Part = CStr(Hour(Value))
If Len(Part) < Len(Interval) Then
Part = Right("0" & Part, Len(Interval))
End If
Case "s"
Part = Right("0" & Second(Value), 2)
Case Else ' The item is not a recognized date interval, just return the value
Part = Interval
End Select
End Function
End Class
Function NewDate(Value)
Set NewDate = New AspDate
NewDate.Value = Value
End Function
Function NewDateWithDefault(Value, DefaultValue)
Set NewDateWithDefault = New AspDate
If Value = Empty Then
NewDateWithDefault.Value = DefaultValue
Else
NewDateWithDefault.Value = Value
End If
End Function
Here's example code using the above class:
<%=NewDate(Checkin.Parameters.Item("#DOB").Value).Format("mm/dd/yyyy")%>
To get the format you've noted above, you would do:
.Format("d-mmmm-yyyy")

Value changing event in browser?

define variable hOrderQuery as handle no-undo.
define variable browseOrder-hdl as handle no-undo.
define variable browse-hdl as handle no-undo.
define variable CNumber as integer no-undo.
CREATE QUERY hQuery.
hQuery:SET-BUFFERS(BUFFER Customer:HANDLE).
hQuery:QUERY-PREPARE("FOR EACH Customer").
hQuery:QUERY-OPEN().
CREATE BROWSE browse-hdl
ASSIGN
TITLE = "Customer Browser"
FRAME = FRAME MyFrame:HANDLE
QUERY = hQuery
X = 2
Y = 2
WIDTH = 74
DOWN = 10
VISIBLE = YES
SENSITIVE = TRUE
READ-ONLY = yes.
browse-hdl:ADD-COLUMNS-FROM(BUFFER Customer:HANDLE,"SalesRep,email,fax,comments,address,City,State,PostalCode").
on value-changed of browse-hdl
do:
FIND CURRENT Customer.
cNumber = Customer.CustNum.
CREATE QUERY hOrderQuery.
hOrderQuery:SET-BUFFERS(BUFFER Order:HANDLE).
hOrderQuery:QUERY-PREPARE("FOR EACH Order where Order.CustNum = " + string(cNumber)) no- error.
hOrderQuery:QUERY-OPEN().
CREATE BROWSE browseOrder-hdl
ASSIGN
TITLE = "Order Browser"
FRAME = FRAME MyFrame:HANDLE
QUERY = hOrderQuery
X = 2
Y = 240
WIDTH = 74
DOWN = 10
VISIBLE = YES
SENSITIVE = TRUE
READ-ONLY = yes.
browseOrder-hdl:ADD-COLUMNS-FROM(BUFFER Order:HANDLE,"warehousenum,CustNum").
end.
on value-changed of browseOrder-hdl
do:
message "hai" view-as alert-box.
end.
this is my issue.I have 3 browsers.Now i created only two. When I click on first customer browser's one row it should select the current customer and should show his order in the second browser-order browser.
When I click on order browser value it should show the corresponding orderline table values in the 3rd orderline browser(which i didnt create now).
So when I tried to take the browseOrder-hdl to create second value-changed event, it is showing it is already deleted.
How to overcome this issue??Please reply.
DEFINE FRAME MyFrame
WITH 1 DOWN NO-BOX KEEP-TAB-ORDER OVERLAY
SIDE-LABELS NO-UNDERLINE THREE-D
AT COL 1 ROW 1
SIZE 80 BY 16.
define variable hOrderQuery as handle no-undo.
define variable browseOrder-hdl as handle no-undo.
define variable browse-hdl as handle no-undo.
define variable CNumber as integer no-undo.
DEFINE VARIABLE hQuery AS HANDLE NO-UNDO.
CREATE QUERY hQuery.
hQuery:SET-BUFFERS(BUFFER Customer:HANDLE).
hQuery:QUERY-PREPARE("FOR EACH Customer").
hQuery:QUERY-OPEN().
CREATE BROWSE browse-hdl
ASSIGN
TITLE = "Customer Browser"
FRAME = FRAME MyFrame:HANDLE
QUERY = hQuery
X = 2
Y = 2
WIDTH = 74
DOWN = 10
VISIBLE = TRUE
SENSITIVE = TRUE
READ-ONLY = TRUE
TRIGGERS:
ON VALUE-CHANGED DO:
RUN ShowOrderBrowser.
END.
END.
browse-hdl:ADD-COLUMNS-FROM(BUFFER Customer:HANDLE,"SalesRep,email,fax,comments,address,City,State,PostalCode").
WAIT-FOR CLOSE OF THIS-PROCEDURE.
/* ********************** Internal Procedures *********************** */
PROCEDURE ShowOrderBrowser:
/*------------------------------------------------------------------------------
Purpose:
Notes:
------------------------------------------------------------------------------*/
FIND CURRENT Customer.
cNumber = Customer.CustNum.
CREATE QUERY hOrderQuery.
hOrderQuery:SET-BUFFERS(BUFFER Order:HANDLE).
hOrderQuery:QUERY-PREPARE("FOR EACH Order WHERE Order.CustNum = " + STRING(cNumber)).
hOrderQuery:QUERY-OPEN().
CREATE BROWSE browseOrder-hdl
ASSIGN
TITLE = "Order Browser"
FRAME = FRAME MyFrame:HANDLE
QUERY = hOrderQuery
X = 2
Y = 240
WIDTH = 74
DOWN = 10
VISIBLE = TRUE
SENSITIVE = TRUE
READ-ONLY = TRUE
TRIGGERS:
ON VALUE-CHANGED DO:
MESSAGE "hai"
VIEW-AS ALERT-BOX.
END.
END.
browseOrder-hdl:ADD-COLUMNS-FROM(BUFFER Order:HANDLE,"warehousenum,CustNum").
WAIT-FOR VALUE-CHANGED OF browseOrder-hdl.
END PROCEDURE.