code pb json
Posted: Mon Apr 20, 2009 11:10 pm
Code: Select all
;;;;json pb
ImportC "/usr/local/lib/libjson.a"
json_object_new_object()
json_object_object_add(obj.l, key.s, value.l);
json_object_new_string(cars.s)
json_object_put(obj.l)
json_object_to_json_string(obj.l)
json_object_array_add(ds_dt.l,d_dt.l);
json_object_new_array();
EndImportCode: Select all
;;
IncludeFile "include/mysql.pbi"
IncludeFile "include/cgi.pbi"
IncludeFile "include/json.pbi"
;
init_cgi()
conecta_db()
;
Define.s json, jmsg
Global mensagen.s, tp.l
;
tp =Val(GET_CAMPO("tp"));tipo da ação
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
Procedure.l salva_cco()
Protected cod_cco.s, nome_cco.s, isql.s, banc_cco.s, titu_cco.s, nume_cco.s, agen_cco.s, gere_cco.s
mensagen=#NUL$
cod_cco= Trim(GET_CAMPO("ed_cod_cco"))
banc_cco= Str(Val(Trim(GET_CAMPO("ed_banc_cco"))))
titu_cco= UCase(Trim(GET_CAMPO("ed_titu_cco")))
nume_cco= UCase(Trim(GET_CAMPO("ed_nume_cco")))
agen_cco= UCase(Trim(GET_CAMPO("ed_agen_cco")))
gere_cco= UCase(Trim(GET_CAMPO("ed_gere_cco")))
If Val(cod_cco) < 1; SALVA
cod_cco = Str(pega_id("COD_CCO", "CONTA_CORRENTE"))
isql="Insert Into CONTA_CORRENTE (COD_CCO,NUME_CCO, BANC_CCO, TITU_CCO, AGEN_CCO, GERE_CCO) values ('"+cod_cco+"','"+nume_cco+"','"+banc_cco+"','"+titu_cco+"','"+agen_cco+"','"+gere_cco+"')"
mensagen="REGISTRO SALVO COM SUCESSO!"
Else ;ALTERA
isql="UPDATE CONTA_CORRENTE SET NUME_CCO ='"+nume_cco+"', BANC_CCO ='"+banc_cco+"', TITU_CCO ='"+titu_cco+"', AGEN_CCO ='"+agen_cco+"', GERE_CCO ='"+gere_cco+"' WHERE COD_CCO='"+Str(Val(cod_cco))+"'"
mensagen="REGISTRO ALTERADO COM SUCESSO!"
EndIf
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
If mysql_query(*hDB,isql) <> 1
cod_main=RSet(cod_cco,4,"0")
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
;
Procedure.l deleta_cco()
Protected cod_cco.s, isql.s
mensagen=#NUL$
cod_cco = Trim(GET_CAMPO("ed_cod_cco"))
isql="DELETE FROM CONTA_CORRENTE WHERE COD_CCO='"+Str(Val(cod_cco))+"'"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
If mysql_query(*hDB,isql) <> 1
mensagen="REGISTRO APAGADO COM SUCESSO!"
ProcedureReturn #True
Else
ProcedureReturn #False
EndIf
EndProcedure
;
Procedure pesquisa_cco()
Protected sql.s , *resultado, *rowx, *element, *ar_cc,*jsonmsg
Protected sqlval.s
Define.s jsons
;;;;;;;;;;;;;;
If tp = #BUSCAR
sqlval=GET_CAMPO("ed_cons_cco")
sql="Select COD_CCO, TITU_CCO, NUME_CCO,AGEN_CCO,NOME_BAN FROM CONTA_CORRENTE INNER JOIN BANCO ON COD_BAN = BANC_CCO WHERE NOME_BAN LIKE '%"+sqlval+"%' OR TITU_CCO LIKE '%"+sqlval+"%' OR NUME_CCO LIKE '%"+sqlval+"%' OR GERE_CCO LIKE '%"+sqlval+"%' OR AGEN_CCO LIKE '%"+sqlval+"%'"
ElseIf tp = #CARREGAR
sqlval=GET_CAMPO("ed_cod_cco")
sql="Select COD_CCO,NUME_CCO,BANC_CCO,AGEN_CCO,TITU_CCO,GERE_CCO, (SELECT NOME_BAN FROM BANCO WHERE COD_BAN = BANC_CCO) FROM CONTA_CORRENTE WHERE COD_CCO = '"+sqlval+"'"
EndIf
;
*ar_cc = json_object_new_array();
;
*resultado= s_mysql(sql)
If *resultado
;nRows= mysql_num_rows(*resulta)
Repeat
*r.MYSQL_ROW=mysql_fetch_row(*resultado)
If *r
If tp = #BUSCAR
*element = json_object_new_object();
json_object_object_add(*element, "cod_cco", json_object_new_string(RSet(*r\field[0],4,"0")));
json_object_object_add(*element, "nume_cco", json_object_new_string(*r\field[1]));
json_object_object_add(*element, "titu_cco", json_object_new_string(*r\field[2]));
json_object_object_add(*element, "gere_cco", json_object_new_string(*r\field[3]));
json_object_array_add(*ar_cc, *element);
ElseIf tp = #CARREGAR
*element = json_object_new_object();
json_object_object_add(*element, "cod_cco", json_object_new_string(RSet(*r\field[0],4,"0")));
json_object_object_add(*element, "nume_cco", json_object_new_string(*r\field[1]));
json_object_object_add(*element, "cban_cco", json_object_new_string(RSet(*r\field[2],3,"0")));
json_object_object_add(*element, "agen_cco", json_object_new_string(*r\field[3]));
json_object_object_add(*element, "titu_cco", json_object_new_string(*r\field[4]));
json_object_object_add(*element, "gere_cco", json_object_new_string(*r\field[5]));
json_object_object_add(*element, "nban_cco", json_object_new_string(*r\field[6]));
json_object_array_add(*ar_cc, *element);
EndIf
EndIf
Until Not *r
mysql_free_result(*resultado)
EndIf
*jsonmsg = json_object_new_object();
json_object_object_add(*jsonmsg, "conta_corrente", *ar_cc);
jsons =PeekS(json_object_to_json_string(*jsonmsg))
json_object_put(*element)
json_object_put(*ar_cc)
json_object_put(*jsonmsg)
html_c+jsons
EndProcedure
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
html_c = "Content-type: text/html;charset=utf-8"+ #CRLF$ + #CRLF$
;
Select tp
Case #BUSCAR, #CARREGAR
; html_c = "Content-type: text/xml;charset=utf-8"+ #CRLF$ + #CRLF$
pesquisa_cco()
Case #SALVAR
If salva_cco()=#True
jmsg=mensagen
Else
jmsg=" Mysql Erro "+Str(mysql_errno(*hDB))
EndIf
*ar_cc = json_object_new_array();
*element = json_object_new_object();
json_object_object_add(*element, "cod_cco", json_object_new_string(cod_main));
json_object_object_add(*element, "jmsg", json_object_new_string(jmsg));
json_object_array_add(*ar_cc, *element);
*jsonmsg = json_object_new_object();
json_object_object_add(*jsonmsg, "conta_corrente", *ar_cc);
json =PeekS(json_object_to_json_string(*jsonmsg))
json_object_put(*ar_cc)
json_object_put(*element)
json_object_put(*jsonmsg)
html_c+json
Case #DELETAR
If deleta_cco()=#True
html_c+mensagen
Else
html_c+" Mysql Erro "+Str(mysql_errno(*hDB))
EndIf
Default
html_c+"<script> javascript:history.back(); </script>"
EndSelect
;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
desconecta_db()
close_cgi()
;Delay(6000)
End
Code: Select all
; CGI using native PB
;---------------------------------
; Tested on Windows with SAMBAR server
; Tested on linux hosting with apache
;---------------------------------
Global PASSWD.s
;{ Header Variables
;
Structure cgi_var
Name.s
Value.s
Filename.s
CType.s
EndStructure
;; MODIFICADO POR LAZARUSoft
;---OPERACÇÕES
#BUSCAR = 1
#SALVAR = 2
#DELETAR = 3
#CARREGAR = 4
Global cod_main.s
;
Global NewList html_var.cgi_var()
;
#TEXTPLAIN = 1
#MULTIPART = 2
#POST = 1
#GET = 2
#MYXML=0
;
Global *Buffer,ContentLength,DATA_TYPE,DATA_METHOD,MP_BOUNDARY.s,EOL$,DBLEOL$;, MOSTRA.s
EOL$ = Chr(13)+Chr(10) ;/ Note #CRLF$ = EOL$ , i did that because of pointer memory search
DBLEOL$ = EOL$+EOL$
Global html_c.s
;/ This is the top header before we post back to the browser, for example if you want to send out
;/ a jpeg file use
;/ OutputContentType.s="Content-type: image/jpeg" + #CRLF$ + CRLF$ + JPEGFILE$
;/ If you are using linux i suggest to use a "../tempfolder/"
;Folder.s="../upload/"; "C:\" or "../upload/" ;
Folder.s = "" ; this will save the file where the cgi-bin directory runs
;}
;{ // Enviroment Variables
Global CGI_AUTH_TYPE.s
Global CGI_CONTENT_LENGTH.s
Global CGI_CONTENT_TYPE.s
Global CGI_DOCUMENT_ROOT.s
Global CGI_GATEWAY_INTERFACE.s
Global CGI_PATH_INFO.s
Global CGI_PATH_TRANSLATED.s
Global CGI_QUERY_STRING.s
Global CGI_REMOTE_ADDR.s
Global CGI_REMOTE_HOST.s
Global CGI_REMOTE_IDENT.s
Global CGI_REMOTE_PORT.s
Global CGI_REMOTE_USER.s
Global CGI_REQUEST_URI.s
Global CGI_REQUEST_METHOD.s
Global CGI_SCRIPT_NAME.s
Global CGI_SCRIPT_FILENAME.s
Global CGI_SERVER_ADMIN.s
Global CGI_SERVER_NAME.s
Global CGI_SERVER_PORT.s
Global CGI_SERVER_PROTOCOL.s
Global CGI_SERVER_SIGNATURE.s
Global CGI_SERVER_SOFTWARE.s
Global CGI_HTTP_ACCEPT.s
Global CGI_HTTP_ACCEPT_ENCODING.s
Global CGI_HTTP_ACCEPT_LANGUAGE.s
Global CGI_HTTP_COOKIE.s
Global CGI_HTTP_FORWARDED.s
Global CGI_HTTP_HOST.s
Global CGI_HTTP_PRAGMA.s
Global CGI_HTTP_REFERER.s
Global CGI_HTTP_USER_AGENT.s
;}
Procedure.l InMem(StartPos.l, *MainMem, MainLen.l, *FindMem, FindLen.l)
If StartPos < 1 : StartPos = 1 : EndIf
FoundPos.l = 0
For MainArrayLoop.l = StartPos - 1 To MainLen -1
If MainArrayLoop + FindLen = MainLen
;End reached
Break
EndIf
If CompareMemory(*MainMem + MainArrayLoop, *FindMem, FindLen) = 1
FoundPos = MainArrayLoop + 1
Break
EndIf
Next
ProcedureReturn FoundPos
EndProcedure
;
Procedure.l GetNum(thechar.l)
; Handle 0-9
If thechar >= 48 And thechar <= 57
ProcedureReturn thechar - 48
; Handle a-f
ElseIf thechar >= 97 And thechar <= 102
ProcedureReturn 10 + (thechar - 97)
; Handle A-F
ElseIf thechar >= 65 And thechar <= 70
ProcedureReturn 10 + (thechar - 65)
Else
;Debug "Non hex character passed to GetNum()"
ProcedureReturn -1
EndIf
EndProcedure
;
Procedure.l ValH(nums.s)
Define.l strlen = 0, pos =0, answer = 0
strlen = Len(nums)
pos = strlen
While pos > 0
answer = answer + Pow(16, pos -1) * GetNum(Asc(Mid(nums, strlen - pos+1, 1)))
pos = pos - 1
Wend
ProcedureReturn answer
EndProcedure
;
Procedure.l IsHex(thechar.l)
If (thechar >= 48 And thechar <= 57) Or (thechar >= 97 And thechar <= 102) Or (thechar >= 65 And thechar <= 70)
ProcedureReturn 1
Else
ProcedureReturn 0
EndIf
EndProcedure
;
Procedure.s URLDecode(str.s)
Define.s ret = str, temp = ""
Define.l currentPos = 1, prevPos = 1
Define.s byte
ReplaceString(str, "+", " ", 2)
currentPos = FindString(str, "%", currentPos)
While currentPos > 0
temp = temp + Mid(str, prevPos, currentPos - prevPos)
;Debug temp
byte = Mid(str, currentPos+1, 2)
; Debug "'"+byte+"'"
If Len(byte) <> 2
Break
EndIf
If IsHex(Asc(Mid(byte, 1, 1))) And IsHex(Asc(Mid(byte, 2, 1))) And byte <> "00"
temp = temp + Chr(ValH(LCase(byte)))
;Debug "'"+Chr(ValH(LCase(byte)))+"'"
currentPos = currentPos + 3
Else
temp = temp + "%" + byte
currentPos = currentPos + 3
EndIf
prevPos = currentPos
currentPos = FindString(str, "%", currentPos)
Wend
If temp <> ""
temp = temp + Mid(str, prevPos, Len(str))
ret = temp
EndIf
ProcedureReturn ret
EndProcedure
;
Procedure get_post_vars()
Define.s query = ""
If DATA_METHOD = #POST
query = PeekS(*Buffer,ContentLength,#PB_UTF8)
ElseIf DATA_METHOD = #GET
query =CGI_QUERY_STRING
EndIf
;
If Len(query)
Define.l args = 0, i = 0
args = CountString(query, "&") + 1
While i < args
Define.s tem
i = i + 1
tem = StringField(query, i, "&")
AddElement(html_var())
html_var()\Name = URLDecode(StringField(tem, 1, "="))
html_var()\Value = URLDecode(StringField(tem, 2, "="))
Wend
EndIf
EndProcedure
;
Procedure get_cgi_env_var()
CGI_AUTH_TYPE = GetEnvironmentVariable("AUTH_TYPE")
CGI_CONTENT_LENGTH = GetEnvironmentVariable("CONTENT_LENGTH")
CGI_CONTENT_TYPE = GetEnvironmentVariable("CONTENT_TYPE")
CGI_DOCUMENT_ROOT = GetEnvironmentVariable("DOCUMENT_ROOT")
CGI_GATEWAY_INTERFACE = GetEnvironmentVariable("GATEWAY_INTERFACE")
CGI_PATH_INFO = GetEnvironmentVariable("PATH_INFO")
CGI_PATH_TRANSLATED = GetEnvironmentVariable("PATH_TRANSLATED")
CGI_QUERY_STRING = GetEnvironmentVariable("QUERY_STRING")
CGI_REMOTE_ADDR = GetEnvironmentVariable("REMOTE_ADDR")
CGI_REMOTE_HOST = GetEnvironmentVariable("REMOTE_HOST")
CGI_REMOTE_IDENT = GetEnvironmentVariable("REMOTE_IDENT")
CGI_REMOTE_PORT = GetEnvironmentVariable("REMOTE_PORT") ;; 3465
CGI_REMOTE_USER = GetEnvironmentVariable("REMOTE_USER")
CGI_REQUEST_URI = GetEnvironmentVariable("REQUEST_URI")
CGI_REQUEST_METHOD = GetEnvironmentVariable("REQUEST_METHOD")
CGI_SCRIPT_NAME = GetEnvironmentVariable("SCRIPT_NAME") ; /cgi-bin/join.pl
CGI_SCRIPT_FILENAME = GetEnvironmentVariable("SCRIPT_FILENAME") ; /home/httpd/cgi-bin/join.pl
CGI_SERVER_ADMIN = GetEnvironmentVariable("SERVER_ADMIN") ; webadmin@myhost.mycompany.org
CGI_SERVER_NAME = GetEnvironmentVariable("SERVER_NAME")
CGI_SERVER_PORT = GetEnvironmentVariable("SERVER_PORT")
CGI_SERVER_PROTOCOL = GetEnvironmentVariable("SERVER_PROTOCOL")
CGI_SERVER_SIGNATURE = GetEnvironmentVariable("SERVER_SIGNATURE")
CGI_SERVER_SOFTWARE = GetEnvironmentVariable("SERVER_SOFTWARE");Apache/1.3.12 (Unix) (Red Hat/Linux) PHP/3.0.15 mod_perl/1.21
CGI_HTTP_ACCEPT = GetEnvironmentVariable("HTTP_ACCEPT")
CGI_HTTP_ACCEPT_ENCODING = GetEnvironmentVariable("HTTP_ACCEPT_ENCODING") ; gzip, deflate
CGI_HTTP_ACCEPT_LANGUAGE = GetEnvironmentVariable("HTTP_ACCEPT_LANGUAGE")
CGI_HTTP_COOKIE = GetEnvironmentVariable("HTTP_COOKIE")
CGI_HTTP_FORWARDED = GetEnvironmentVariable("HTTP_FORWARDED") ; by http://proxy-nt1.yourcompany.org:8080 (Netscape-Proxy/3.5)
CGI_HTTP_HOST = GetEnvironmentVariable("HTTP_HOST") ; yourwebhost.yourcompany.org
CGI_HTTP_PRAGMA = GetEnvironmentVariable("HTTP_PRAGMA")
CGI_HTTP_REFERER = GetEnvironmentVariable("HTTP_REFERER") ;http://ctdp.tripod.com/independent/web/cgi/cgimanual/index.html
CGI_HTTP_USER_AGENT = GetEnvironmentVariable("HTTP_USER_AGENT");; Mozilla/4.0 (compatible; MSIE 4.01; Windows 95)
EndProcedure
Procedure init_cgi() ;// Must come first
OpenConsole() ;
EnableGraphicalConsole(0) ;
get_cgi_env_var();
;
ContentLength = Val(CGI_CONTENT_LENGTH) ;length of read data
If ContentLength
*Buffer = AllocateMemory(ContentLength) ;We read the buffer now
Result= ReadConsoleData(*Buffer, ContentLength)
EndIf
If LCase(CGI_CONTENT_TYPE)="text/plain" Or LCase(CGI_CONTENT_TYPE)="application/x-www-form-urlencoded"
DATA_TYPE = #TEXTPLAIN
ElseIf Left(LCase(CGI_CONTENT_TYPE),Len("multipart/form-data"))="multipart/form-data"
DATA_TYPE = #MULTIPART ;// In multipart we have BOUNDARY signatures to seperate each file/value
MP_BOUNDARY="--"+StringField(CGI_CONTENT_TYPE,2,"=") ; adding -- to start of signature
EndIf
;
If LCase(CGI_REQUEST_METHOD)="post"
DATA_METHOD = #POST
EndIf
If LCase(CGI_REQUEST_METHOD)="get"
DATA_METHOD = #GET
EndIf
;
get_post_vars(); pega atributos GET E POST
;
EndProcedure
;;
Procedure.s GET_CAMPO(nome_c.s)
ForEach html_var()
objnome.s =html_var()\Name
objvalor.s =html_var()\Value
If LCase(nome_c)=LCase(objnome)
ProcedureReturn objvalor
Break
EndIf
Next
ProcedureReturn #NUL$
EndProcedure
;
Procedure close_cgi(pdf.b=#False)
If *Buffer
FreeMemory(*Buffer)
*Buffer =#NUL
EndIf
;
If pdf=#False
utf8len.l = StringByteLength(html_c, #PB_UTF8)
*utf8 = AllocateMemory(utf8len+1)
PokeS(*utf8, html_c, -1, #PB_UTF8)
WriteConsoleData(*utf8, utf8len)
Else
utf8len.l = StringByteLength(html_c)
*utf8 = AllocateMemory(utf8len+1)
PokeS(*utf8, html_c, -1)
WriteConsoleData(*utf8, utf8len)
EndIf
;
If *utf8
FreeMemory(*utf8)
*utf8=#NUL
EndIf
; ClearConsole()
CloseConsole()
EndProcedure
accept suggestions waiting.....