293 lines
9.0 KiB
COBOL
293 lines
9.0 KiB
COBOL
COBOL >>SOURCE FORMAT IS FIXED
|
|
identification division.
|
|
program-id. curl-rosetta.
|
|
|
|
environment division.
|
|
configuration section.
|
|
repository.
|
|
function read-url
|
|
function all intrinsic.
|
|
|
|
data division.
|
|
working-storage section.
|
|
|
|
copy "gccurlsym.cpy".
|
|
|
|
01 web-page pic x(16777216).
|
|
01 curl-status usage binary-long.
|
|
|
|
01 cli pic x(7) external.
|
|
88 helping values "-h", "-help", "help", spaces.
|
|
88 displaying value "display".
|
|
88 summarizing value "summary".
|
|
|
|
*> ***************************************************************
|
|
procedure division.
|
|
accept cli from command-line
|
|
if helping then
|
|
display "./curl-rosetta [help|display|summary]"
|
|
goback
|
|
end-if
|
|
|
|
*>
|
|
*> Read a web resource into fixed ram.
|
|
*> Caller is in charge of sizing the buffer,
|
|
*> (or getting trickier with the write callback)
|
|
*> Pass URL and working-storage variable,
|
|
*> get back libcURL error code or 0 for success
|
|
|
|
move read-url("http://www.rosettacode.org", web-page)
|
|
to curl-status
|
|
|
|
perform check
|
|
perform show
|
|
|
|
goback.
|
|
*> ***************************************************************
|
|
|
|
*> Now tesing the result, relying on the gccurlsym
|
|
*> GnuCOBOL Curl Symbol copy book
|
|
check.
|
|
if curl-status not equal zero then
|
|
display
|
|
curl-status " "
|
|
CURLEMSG(curl-status) upon syserr
|
|
end-if
|
|
.
|
|
|
|
*> And display the page
|
|
show.
|
|
if summarizing then
|
|
display "Length: " stored-char-length(web-page)
|
|
end-if
|
|
if displaying then
|
|
display trim(web-page trailing) with no advancing
|
|
end-if
|
|
.
|
|
|
|
REPLACE ALSO ==:EXCEPTION-HANDLERS:== BY
|
|
==
|
|
*> informational warnings and abends
|
|
soft-exception.
|
|
display space upon syserr
|
|
display "--Exception Report-- " upon syserr
|
|
display "Time of exception: " current-date upon syserr
|
|
display "Module: " module-id upon syserr
|
|
display "Module-path: " module-path upon syserr
|
|
display "Module-source: " module-source upon syserr
|
|
display "Exception-file: " exception-file upon syserr
|
|
display "Exception-status: " exception-status upon syserr
|
|
display "Exception-location: " exception-location upon syserr
|
|
display "Exception-statement: " exception-statement upon syserr
|
|
.
|
|
|
|
hard-exception.
|
|
perform soft-exception
|
|
stop run returning 127
|
|
.
|
|
==.
|
|
|
|
end program curl-rosetta.
|
|
*> ***************************************************************
|
|
|
|
*> ***************************************************************
|
|
*>
|
|
*> The function hiding all the curl details
|
|
*>
|
|
*> Purpose: Call libcURL and read into memory
|
|
*> ***************************************************************
|
|
identification division.
|
|
function-id. read-url.
|
|
|
|
environment division.
|
|
configuration section.
|
|
repository.
|
|
function all intrinsic.
|
|
|
|
data division.
|
|
working-storage section.
|
|
|
|
copy "gccurlsym.cpy".
|
|
|
|
replace also ==:CALL-EXCEPTION:== by
|
|
==
|
|
on exception
|
|
perform hard-exception
|
|
==.
|
|
|
|
01 curl-handle usage pointer.
|
|
01 callback-handle usage procedure-pointer.
|
|
01 memory-block.
|
|
05 memory-address usage pointer sync.
|
|
05 memory-size usage binary-long sync.
|
|
05 running-total usage binary-long sync.
|
|
01 curl-result usage binary-long.
|
|
|
|
01 cli pic x(7) external.
|
|
88 helping values "-h", "-help", "help", spaces.
|
|
88 displaying value "display".
|
|
88 summarizing value "summary".
|
|
|
|
linkage section.
|
|
01 url pic x any length.
|
|
01 buffer pic x any length.
|
|
01 curl-status usage binary-long.
|
|
|
|
*> ***************************************************************
|
|
procedure division using url buffer returning curl-status.
|
|
if displaying or summarizing then
|
|
display "Read: " url upon syserr
|
|
end-if
|
|
|
|
*> initialize libcurl, hint at missing library if need be
|
|
call "curl_global_init" using by value CURL_GLOBAL_ALL
|
|
on exception
|
|
display
|
|
"need libcurl, link with -lcurl" upon syserr
|
|
stop run returning 1
|
|
end-call
|
|
|
|
*> initialize handle
|
|
call "curl_easy_init" returning curl-handle
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
if curl-handle equal NULL then
|
|
display "no curl handle" upon syserr
|
|
stop run returning 1
|
|
end-if
|
|
|
|
*> Set the URL
|
|
call "curl_easy_setopt" using
|
|
by value curl-handle
|
|
by value CURLOPT_URL
|
|
by reference concatenate(trim(url trailing), x"00")
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
|
|
*> follow all redirects
|
|
call "curl_easy_setopt" using
|
|
by value curl-handle
|
|
by value CURLOPT_FOLLOWLOCATION
|
|
by value 1
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
|
|
*> set the call back to write to memory
|
|
set callback-handle to address of entry "curl-write-callback"
|
|
call "curl_easy_setopt" using
|
|
by value curl-handle
|
|
by value CURLOPT_WRITEFUNCTION
|
|
by value callback-handle
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
|
|
*> set the curl handle data handling structure
|
|
set memory-address to address of buffer
|
|
move length(buffer) to memory-size
|
|
move 1 to running-total
|
|
|
|
call "curl_easy_setopt" using
|
|
by value curl-handle
|
|
by value CURLOPT_WRITEDATA
|
|
by value address of memory-block
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
|
|
*> some servers demand an agent
|
|
call "curl_easy_setopt" using
|
|
by value curl-handle
|
|
by value CURLOPT_USERAGENT
|
|
by reference concatenate("libcurl-agent/1.0", x"00")
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
|
|
*> let curl do all the hard work
|
|
call "curl_easy_perform" using
|
|
by value curl-handle
|
|
returning curl-result
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
|
|
*> the call back will handle filling ram, return the result code
|
|
move curl-result to curl-status
|
|
|
|
*> curl clean up, more important if testing cookies
|
|
call "curl_easy_cleanup" using
|
|
by value curl-handle
|
|
returning omitted
|
|
:CALL-EXCEPTION:
|
|
end-call
|
|
|
|
goback.
|
|
|
|
:EXCEPTION-HANDLERS:
|
|
|
|
end function read-url.
|
|
*> ***************************************************************
|
|
|
|
*> ***************************************************************
|
|
*> Supporting libcurl callback
|
|
identification division.
|
|
program-id. curl-write-callback.
|
|
|
|
environment division.
|
|
configuration section.
|
|
repository.
|
|
function all intrinsic.
|
|
|
|
data division.
|
|
working-storage section.
|
|
01 real-size usage binary-long.
|
|
|
|
*> libcURL will pass a pointer to this structure in the callback
|
|
01 memory-block based.
|
|
05 memory-address usage pointer sync.
|
|
05 memory-size usage binary-long sync.
|
|
05 running-total usage binary-long sync.
|
|
|
|
01 content-buffer pic x(65536) based.
|
|
01 web-space pic x(16777216) based.
|
|
01 left-over usage binary-long.
|
|
|
|
linkage section.
|
|
01 contents usage pointer.
|
|
01 element-size usage binary-long.
|
|
01 element-count usage binary-long.
|
|
01 memory-structure usage pointer.
|
|
|
|
*> ***************************************************************
|
|
procedure division
|
|
using
|
|
by value contents
|
|
by value element-size
|
|
by value element-count
|
|
by value memory-structure
|
|
returning real-size.
|
|
|
|
set address of memory-block to memory-structure
|
|
compute real-size = element-size * element-count end-compute
|
|
|
|
*> Fence off the end of buffer
|
|
compute
|
|
left-over = memory-size - running-total
|
|
end-compute
|
|
if left-over > 0 and < real-size then
|
|
move left-over to real-size
|
|
end-if
|
|
|
|
*> if there is more buffer, and data not zero length
|
|
if (left-over > 0) and (real-size > 1) then
|
|
set address of content-buffer to contents
|
|
set address of web-space to memory-address
|
|
|
|
move content-buffer(1:real-size)
|
|
to web-space(running-total:real-size)
|
|
|
|
add real-size to running-total
|
|
else
|
|
display "curl buffer sizing problem" upon syserr
|
|
end-if
|
|
|
|
goback.
|
|
end program curl-write-callback.
|