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.

      *> manifest constants for libcurl
      *> Usage: COPY occurlsym  inside data division
      *>  Taken from include/curl/curl.h 2013-12-19

      *> Functional enums
       01 CURL_MAX_HTTP_HEADER CONSTANT AS     102400.

       78 CURL_GLOBAL_ALL                      VALUE 3.

       78 CURLOPT_FOLLOWLOCATION               VALUE 52.
       78 CURLOPT_WRITEDATA                    VALUE 10001.
       78 CURLOPT_URL                          VALUE 10002.
       78 CURLOPT_USERAGENT                    VALUE 10018.
       78 CURLOPT_WRITEFUNCTION                VALUE 20011.
       78 CURLOPT_COOKIEFILE                   VALUE 10031.
       78 CURLOPT_COOKIEJAR                    VALUE 10082.
       78 CURLOPT_COOKIELIST                   VALUE 10135.

      *> Informationals
       78 CURLINFO_COOKIELIST                  VALUE 4194332.

      *> Result codes
       78 CURLE_OK                             VALUE 0.
      *> Error codes
       78 CURLE_UNSUPPORTED_PROTOCOL           VALUE 1.
       78 CURLE_FAILED_INIT                    VALUE 2.
       78 CURLE_URL_MALFORMAT                  VALUE 3.
       78 CURLE_OBSOLETE4                      VALUE 4.
       78 CURLE_COULDNT_RESOLVE_PROXY          VALUE 5.
       78 CURLE_COULDNT_RESOLVE_HOST           VALUE 6.
       78 CURLE_COULDNT_CONNECT                VALUE 7.
       78 CURLE_FTP_WEIRD_SERVER_REPLY         VALUE 8.
       78 CURLE_REMOTE_ACCESS_DENIED           VALUE 9.
       78 CURLE_OBSOLETE10                     VALUE 10.
       78 CURLE_FTP_WEIRD_PASS_REPLY           VALUE 11.
       78 CURLE_OBSOLETE12                     VALUE 12.
       78 CURLE_FTP_WEIRD_PASV_REPLY           VALUE 13.
       78 CURLE_FTP_WEIRD_227_FORMAT           VALUE 14.
       78 CURLE_FTP_CANT_GET_HOST              VALUE 15.
       78 CURLE_OBSOLETE16                     VALUE 16.
       78 CURLE_FTP_COULDNT_SET_TYPE           VALUE 17.
       78 CURLE_PARTIAL_FILE                   VALUE 18.
       78 CURLE_FTP_COULDNT_RETR_FILE          VALUE 19.
       78 CURLE_OBSOLETE20                     VALUE 20.
       78 CURLE_QUOTE_ERROR                    VALUE 21.
       78 CURLE_HTTP_RETURNED_ERROR            VALUE 22.
       78 CURLE_WRITE_ERROR                    VALUE 23.
       78 CURLE_OBSOLETE24                     VALUE 24.
       78 CURLE_UPLOAD_FAILED                  VALUE 25.
       78 CURLE_READ_ERROR                     VALUE 26.
       78 CURLE_OUT_OF_MEMORY                  VALUE 27.
       78 CURLE_OPERATION_TIMEDOUT             VALUE 28.
       78 CURLE_OBSOLETE29                     VALUE 29.
       78 CURLE_FTP_PORT_FAILED                VALUE 30.
       78 CURLE_FTP_COULDNT_USE_REST           VALUE 31.
       78 CURLE_OBSOLETE32                     VALUE 32.
       78 CURLE_RANGE_ERROR                    VALUE 33.
       78 CURLE_HTTP_POST_ERROR                VALUE 34.
       78 CURLE_SSL_CONNECT_ERROR              VALUE 35.
       78 CURLE_BAD_DOWNLOAD_RESUME            VALUE 36.
       78 CURLE_FILE_COULDNT_READ_FILE         VALUE 37.
       78 CURLE_LDAP_CANNOT_BIND               VALUE 38.
       78 CURLE_LDAP_SEARCH_FAILED             VALUE 39.
       78 CURLE_OBSOLETE40                     VALUE 40.
       78 CURLE_FUNCTION_NOT_FOUND             VALUE 41.
       78 CURLE_ABORTED_BY_CALLBACK            VALUE 42.
       78 CURLE_BAD_FUNCTION_ARGUMENT          VALUE 43.
       78 CURLE_OBSOLETE44                     VALUE 44.
       78 CURLE_INTERFACE_FAILED               VALUE 45.
       78 CURLE_OBSOLETE46                     VALUE 46.
       78 CURLE_TOO_MANY_REDIRECTS             VALUE 47.
       78 CURLE_UNKNOWN_TELNET_OPTION          VALUE 48.
       78 CURLE_TELNET_OPTION_SYNTAX           VALUE 49.
       78 CURLE_OBSOLETE50                     VALUE 50.
       78 CURLE_PEER_FAILED_VERIFICATION       VALUE 51.
       78 CURLE_GOT_NOTHING                    VALUE 52.
       78 CURLE_SSL_ENGINE_NOTFOUND            VALUE 53.
       78 CURLE_SSL_ENGINE_SETFAILED           VALUE 54.
       78 CURLE_SEND_ERROR                     VALUE 55.
       78 CURLE_RECV_ERROR                     VALUE 56.
       78 CURLE_OBSOLETE57                     VALUE 57.
       78 CURLE_SSL_CERTPROBLEM                VALUE 58.
       78 CURLE_SSL_CIPHER                     VALUE 59.
       78 CURLE_SSL_CACERT                     VALUE 60.
       78 CURLE_BAD_CONTENT_ENCODING           VALUE 61.
       78 CURLE_LDAP_INVALID_URL               VALUE 62.
       78 CURLE_FILESIZE_EXCEEDED              VALUE 63.
       78 CURLE_USE_SSL_FAILED                 VALUE 64.
       78 CURLE_SEND_FAIL_REWIND               VALUE 65.
       78 CURLE_SSL_ENGINE_INITFAILED          VALUE 66.
       78 CURLE_LOGIN_DENIED                   VALUE 67.
       78 CURLE_TFTP_NOTFOUND                  VALUE 68.
       78 CURLE_TFTP_PERM                      VALUE 69.
       78 CURLE_REMOTE_DISK_FULL               VALUE 70.
       78 CURLE_TFTP_ILLEGAL                   VALUE 71.
       78 CURLE_TFTP_UNKNOWNID                 VALUE 72.
       78 CURLE_REMOTE_FILE_EXISTS             VALUE 73.
       78 CURLE_TFTP_NOSUCHUSER                VALUE 74.
       78 CURLE_CONV_FAILED                    VALUE 75.
       78 CURLE_CONV_REQD                      VALUE 76.
       78 CURLE_SSL_CACERT_BADFILE             VALUE 77.
       78 CURLE_REMOTE_FILE_NOT_FOUND          VALUE 78.
       78 CURLE_SSH                            VALUE 79.
       78 CURLE_SSL_SHUTDOWN_FAILED            VALUE 80.
       78 CURLE_AGAIN                          VALUE 81.

      *> Error strings
       01 LIBCURL_ERRORS.
          02 CURLEVALUES.
             03 FILLER PIC X(30) VALUE "CURLE_UNSUPPORTED_PROTOCOL    ".
             03 FILLER PIC X(30) VALUE "CURLE_FAILED_INIT             ".
             03 FILLER PIC X(30) VALUE "CURLE_URL_MALFORMAT           ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE4               ".
             03 FILLER PIC X(30) VALUE "CURLE_COULDNT_RESOLVE_PROXY   ".
             03 FILLER PIC X(30) VALUE "CURLE_COULDNT_RESOLVE_HOST    ".
             03 FILLER PIC X(30) VALUE "CURLE_COULDNT_CONNECT         ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_SERVER_REPLY  ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_ACCESS_DENIED    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE10              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_PASS_REPLY    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE12              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_PASV_REPLY    ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_WEIRD_227_FORMAT    ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_CANT_GET_HOST       ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE16              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_COULDNT_SET_TYPE    ".
             03 FILLER PIC X(30) VALUE "CURLE_PARTIAL_FILE            ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_COULDNT_RETR_FILE   ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE20              ".
             03 FILLER PIC X(30) VALUE "CURLE_QUOTE_ERROR             ".
             03 FILLER PIC X(30) VALUE "CURLE_HTTP_RETURNED_ERROR     ".
             03 FILLER PIC X(30) VALUE "CURLE_WRITE_ERROR             ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE24              ".
             03 FILLER PIC X(30) VALUE "CURLE_UPLOAD_FAILED           ".
             03 FILLER PIC X(30) VALUE "CURLE_READ_ERROR              ".
             03 FILLER PIC X(30) VALUE "CURLE_OUT_OF_MEMORY           ".
             03 FILLER PIC X(30) VALUE "CURLE_OPERATION_TIMEDOUT      ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE29              ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_PORT_FAILED         ".
             03 FILLER PIC X(30) VALUE "CURLE_FTP_COULDNT_USE_REST    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE32              ".
             03 FILLER PIC X(30) VALUE "CURLE_RANGE_ERROR             ".
             03 FILLER PIC X(30) VALUE "CURLE_HTTP_POST_ERROR         ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CONNECT_ERROR       ".
             03 FILLER PIC X(30) VALUE "CURLE_BAD_DOWNLOAD_RESUME     ".
             03 FILLER PIC X(30) VALUE "CURLE_FILE_COULDNT_READ_FILE  ".
             03 FILLER PIC X(30) VALUE "CURLE_LDAP_CANNOT_BIND        ".
             03 FILLER PIC X(30) VALUE "CURLE_LDAP_SEARCH_FAILED      ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE40              ".
             03 FILLER PIC X(30) VALUE "CURLE_FUNCTION_NOT_FOUND      ".
             03 FILLER PIC X(30) VALUE "CURLE_ABORTED_BY_CALLBACK     ".
             03 FILLER PIC X(30) VALUE "CURLE_BAD_FUNCTION_ARGUMENT   ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE44              ".
             03 FILLER PIC X(30) VALUE "CURLE_INTERFACE_FAILED        ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE46              ".
             03 FILLER PIC X(30) VALUE "CURLE_TOO_MANY_REDIRECTS      ".
             03 FILLER PIC X(30) VALUE "CURLE_UNKNOWN_TELNET_OPTION   ".
             03 FILLER PIC X(30) VALUE "CURLE_TELNET_OPTION_SYNTAX    ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE50              ".
             03 FILLER PIC X(30) VALUE "CURLE_PEER_FAILED_VERIFICATION".
             03 FILLER PIC X(30) VALUE "CURLE_GOT_NOTHING             ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_ENGINE_NOTFOUND     ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_ENGINE_SETFAILED    ".
             03 FILLER PIC X(30) VALUE "CURLE_SEND_ERROR              ".
             03 FILLER PIC X(30) VALUE "CURLE_RECV_ERROR              ".
             03 FILLER PIC X(30) VALUE "CURLE_OBSOLETE57              ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CERTPROBLEM         ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CIPHER              ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CACERT              ".
             03 FILLER PIC X(30) VALUE "CURLE_BAD_CONTENT_ENCODING    ".
             03 FILLER PIC X(30) VALUE "CURLE_LDAP_INVALID_URL        ".
             03 FILLER PIC X(30) VALUE "CURLE_FILESIZE_EXCEEDED       ".
             03 FILLER PIC X(30) VALUE "CURLE_USE_SSL_FAILED          ".
             03 FILLER PIC X(30) VALUE "CURLE_SEND_FAIL_REWIND        ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_ENGINE_INITFAILED   ".
             03 FILLER PIC X(30) VALUE "CURLE_LOGIN_DENIED            ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_NOTFOUND           ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_PERM               ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_DISK_FULL        ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_ILLEGAL            ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_UNKNOWNID          ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_FILE_EXISTS      ".
             03 FILLER PIC X(30) VALUE "CURLE_TFTP_NOSUCHUSER         ".
             03 FILLER PIC X(30) VALUE "CURLE_CONV_FAILED             ".
             03 FILLER PIC X(30) VALUE "CURLE_CONV_REQD               ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_CACERT_BADFILE      ".
             03 FILLER PIC X(30) VALUE "CURLE_REMOTE_FILE_NOT_FOUND   ".
             03 FILLER PIC X(30) VALUE "CURLE_SSH                     ".
             03 FILLER PIC X(30) VALUE "CURLE_SSL_SHUTDOWN_FAILED     ".
             03 FILLER PIC X(30) VALUE "CURLE_AGAIN                   ".
       01 FILLER REDEFINES LIBCURL_ERRORS.
          02 CURLEMSG OCCURS 81 TIMES PIC X(30).

Print the content of a specified URL to the console using HTTP requests, tested with GnuCOBOL and a copybook.


Works with: OpenCOBOL
Works with: IBM Enterprise COBOL for z/OS
       IDENTIFICATION DIVISION.
       PROGRAM-ID.  LUHNTEST.
       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       data division.
       WORKING-STORAGE SECTION.
       01  inp-card.
         03  inp-card-ch      pic x(01) occurs 20 times.
       01  ws-result          pic 9(01).
         88  pass-luhn-test             value 0.

       PROCEDURE DIVISION.
           move "49927398716"       to inp-card
           perform test-card
           move "49927398717"       to inp-card
           perform test-card
           move "1234567812345678"  to inp-card
           perform test-card
           move "1234567812345670"  to inp-card
           perform test-card
           stop run
           .
       test-card.
           call "LUHN" using inp-card, ws-result
           if pass-luhn-test
             display "input=" inp-card "pass"
           else
             display "input=" inp-card "fail"
           .

       END PROGRAM LUHNTEST.
       IDENTIFICATION DIVISION.
       PROGRAM-ID.  LUHN.
       ENVIRONMENT DIVISION.
       INPUT-OUTPUT SECTION.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  maxlen           pic 9(02) comp value 16.
       01  inplen           pic 9(02) comp value 0.
       01  i                pic 9(02) comp value 0.
       01  j                pic 9(02) comp value 0.
       01  l                pic 9(02) comp value 0.
       01  dw               pic 9(02) comp value 0.
       01  ws-total         pic 9(03) comp value 0.
       01  ws-prod          pic 99.
       01  filler redefines ws-prod.
         03  ws-prod-tens   pic 9.
         03  ws-prod-units  pic 9.
       01  ws-card.
         03  filler           occurs 16 times depending on maxlen.
           05  ws-card-ch     pic x(01).
           05  ws-card-digit redefines ws-card-ch  pic 9(01).
       LINKAGE SECTION.
       01  inp-card.
         03  inp-card-ch      pic x(01) occurs 20 times.
       01  ws-result          pic 9(01).
         88  pass-luhn-test             value 0.

       PROCEDURE DIVISION using inp-card, ws-result.
           perform varying i from 1 by +1
           until i > maxlen
           or    inp-card-ch (i) = space
           end-perform
           compute l = i - 1
           compute inplen = l
           perform varying j from 1 by +1
           until j > inplen
             if l < 1
               move "0"             to ws-card-ch (j)
             else
               move inp-card-ch (l) to ws-card-ch (j)
               compute l = l - 1
             end-if
           end-perform
           move 0 to ws-total
           perform varying i from 1 by +1
           until i > inplen
             compute dw = 2 - (i - 2 * function integer (i / 2))
             compute ws-prod = ws-card-digit (i) * dw
             compute ws-total = ws-total
                              + ws-prod-tens
                              + ws-prod-units
           end-perform
           compute ws-result = ws-total - 10 * function integer (ws-total / 10)
           goback
           .
       END PROGRAM LUHN.

The code validates credit card numbers using the Luhn test. It reverses the input number, calculates the sum of odd and even positioned digits (with even digits being doubled and if the result is greater than nine, the digits of the result are summed). If the total sum ends in zero, the number is deemed valid. The code tests this functionality on four given numbers.


IDENTIFICATION DIVISION.
PROGRAM-ID. REPEAT-PROGRAM.
DATA DIVISION.
WORKING-STORAGE SECTION.
77  HAHA         PIC A(10).
PROCEDURE DIVISION.
    MOVE ALL 'ha' TO HAHA.
    DISPLAY HAHA.
    STOP RUN.

The code takes a string and a number as input and repeats the string that number of times. It also has the functionality to repeat a single character to create a new string.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Int-Arithmetic.

       DATA DIVISION.
       WORKING-STORAGE SECTION.

       01 A      PIC S9(10).
       01 B      PIC S9(10).
       01 Result PIC S9(10).

       PROCEDURE DIVISION.
           DISPLAY "First number: " WITH NO ADVANCING
           ACCEPT A
           DISPLAY "Second number: " WITH NO ADVANCING
           ACCEPT B

*          *> Note: The various ADD/SUBTRACT/etc. statements can be
*          *> replaced with COMPUTE statements, which allow those
*          *> operations to be defined similarly to other languages,
*          *> e.g. COMPUTE Result = A + B

           ADD A TO B GIVING Result
           DISPLAY "A + B = " Result

           SUBTRACT B FROM A GIVING Result
           DISPLAY "A - B = " Result

           MULTIPLY A BY B GIVING Result
           DISPLAY "A * B = " Result

*          *> Division here truncates towards zero. DIVIDE can take a
*          *> ROUNDED clause, which will round the result to the nearest
*          *> integer.
           DIVIDE A BY B GIVING Result
           DISPLAY "A / B = " Result

           COMPUTE Result = A ^ B
           DISPLAY "A ^ B = " Result

*          *> Matches sign of first argument.
           DISPLAY "A % B = " FUNCTION REM(A, B)

           GOBACK
           .

take two integers as input from the user and display their sum, difference, product, integer quotient, remainder, and exponentiation. The code also indicates the rounding direction for the quotient and the sign of the remainder. It does not include error handling. A bonus feature is the inclusion of the `divmod` operator example.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. testing.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  occurrences             PIC 99.

       PROCEDURE DIVISION.
           INSPECT "the three truths" TALLYING occurrences FOR ALL "th"
           DISPLAY occurrences

           MOVE 0 TO occurrences
           INSPECT "ababababab" TALLYING occurrences FOR ALL "abab"
           DISPLAY occurrences

           MOVE 0 TO occurrences
           INSPECT "abaabba*bbaba*bbab" TALLYING occurrences
               FOR ALL "a*b"
           DISPLAY occurrences

           GOBACK
           .

The code defines a function to count the number of non-overlapping occurrences of a specific substring within a given string. The function takes two arguments: the main string and the substring to search for. It returns an integer representing the count of non-overlapping occurrences. The function does not count overlapping substrings and matches from left-to-right or right-to-left for the highest number of non-overlapping matches.


Translation of: C
Works with: OpenCOBOL version 2.0
       >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. towers-of-hanoi.

PROCEDURE DIVISION.
    CALL "move-disk" USING 4, 1, 2, 3
    .
END PROGRAM towers-of-hanoi.

IDENTIFICATION DIVISION.
PROGRAM-ID. move-disk RECURSIVE.

DATA DIVISION.
LINKAGE SECTION.
01  n                         PIC 9 USAGE COMP.
01  from-pole                 PIC 9 USAGE COMP.
01  to-pole                   PIC 9 USAGE COMP.
01  via-pole                  PIC 9 USAGE COMP.

PROCEDURE DIVISION USING n, from-pole, to-pole, via-pole.
    IF n > 0
       SUBTRACT 1 FROM n
       CALL "move-disk" USING CONTENT n, from-pole, via-pole, to-pole
       DISPLAY "Move disk from pole " from-pole " to pole " to-pole
       CALL "move-disk" USING CONTENT n, via-pole, to-pole, from-pole
    END-IF
    .
END PROGRAM move-disk.

IDENTIFICATION DIVISION.
PROGRAM-ID. towers-of-hanoi.

PROCEDURE DIVISION.
    CALL "move-disk" USING 4, 1, 2, 3
    .
END PROGRAM towers-of-hanoi.

IDENTIFICATION DIVISION.
PROGRAM-ID. move-disk RECURSIVE.

DATA DIVISION.
LINKAGE SECTION.
01  n                         PIC 9 USAGE COMP.
01  from-pole                 PIC 9 USAGE COMP.
01  to-pole                   PIC 9 USAGE COMP.
01  via-pole                  PIC 9 USAGE COMP.

PROCEDURE DIVISION USING n, from-pole, to-pole, via-pole.
    IF n > 0
       SUBTRACT 1 FROM n
       CALL "move-disk" USING CONTENT n, from-pole, via-pole, to-pole
       ADD 1 TO n
       DISPLAY "Move disk number "n " from pole " from-pole " to pole " to-pole
       SUBTRACT 1 FROM n
       CALL "move-disk" USING CONTENT n, via-pole, to-pole, from-pole
    END-IF
    .
END PROGRAM move-disk.

ANSI-74 solution[edit]

Works with: CIS COBOL version 4.2Works with: GnuCOBOL version 3.0-rc1.0
       IDENTIFICATION DIVISION.
       PROGRAM-ID. ITERATIVE-TOWERS-OF-HANOI.
       AUTHOR. SOREN ROUG.
       DATE-WRITTEN. 2019-06-28.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER. LINUX.
       OBJECT-COMPUTER. KAYPRO4.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       77  NUM-DISKS                   PIC 9 VALUE 4.
       77  N1                          PIC 9 COMP.
       77  N2                          PIC 9 COMP.
       77  FROM-POLE                   PIC 9 COMP.
       77  TO-POLE                     PIC 9 COMP.
       77  VIA-POLE                    PIC 9 COMP.
       77  FP-TMP                      PIC 9 COMP.
       77  TO-TMP                      PIC 9 COMP.
       77  P-TMP                       PIC 9 COMP.
       77  TMP-P                       PIC 9 COMP.
       77  I                           PIC 9 COMP.
       77  DIV                         PIC 9 COMP.
       01  STACKNUMS.
           05  NUMSET OCCURS 3 TIMES.
               10  DNUM                PIC 9 COMP.
       01  GAMESET.
           05  POLES OCCURS 3 TIMES.
               10  STACK OCCURS 10 TIMES.
                   15  POLE            PIC 9 USAGE COMP.

       PROCEDURE DIVISION.
       HANOI.
           DISPLAY "TOWERS OF HANOI PUZZLE WITH ", NUM-DISKS, " DISKS.".
           ADD NUM-DISKS, 1 GIVING N1.
           ADD NUM-DISKS, 2 GIVING N2.
           MOVE 1 TO DNUM (1).
           MOVE N1 TO DNUM (2), DNUM (3).
           MOVE N1 TO POLE (1, N1), POLE (2, N1), POLE (3, N1).
           MOVE 1 TO POLE (1, N2).
           MOVE 2 TO POLE (2, N2).
           MOVE 3 TO POLE (3, N2).
           MOVE 1 TO I.
           PERFORM INIT-PUZZLE UNTIL I = N1.
           MOVE 1 TO FROM-POLE.
           DIVIDE 2 INTO NUM-DISKS GIVING DIV.
           MULTIPLY 2 BY DIV.
           IF DIV NOT = NUM-DISKS PERFORM INITODD ELSE PERFORM INITEVEN.
           PERFORM MOVE-DISK UNTIL DNUM (3) NOT > 1.
           DISPLAY "TOWERS OF HANOI PUZZLE COMPLETED!".
           STOP RUN.
       INIT-PUZZLE.
           MOVE I TO POLE (1, I).
           MOVE 0 TO POLE (2, I), POLE (3, I).
           ADD 1 TO I.
       INITEVEN.
           MOVE 2 TO TO-POLE.
           MOVE 3 TO VIA-POLE.
       INITODD.
           MOVE 3 TO TO-POLE.
           MOVE 2 TO VIA-POLE.
       MOVE-DISK.
           MOVE DNUM (FROM-POLE) TO FP-TMP.
           MOVE POLE (FROM-POLE, FP-TMP) TO I.
           DISPLAY "MOVE DISK FROM ", POLE (FROM-POLE, N2),
               " TO ", POLE (TO-POLE, N2).
           ADD 1 TO DNUM (FROM-POLE).
           MOVE VIA-POLE TO TMP-P.
           SUBTRACT 1 FROM DNUM (TO-POLE).
           MOVE DNUM (TO-POLE) TO TO-TMP.
           MOVE I TO POLE (TO-POLE, TO-TMP).
           DIVIDE 2 INTO I GIVING DIV.
           MULTIPLY 2 BY DIV.
           IF I NOT = DIV PERFORM MOVE-TO-VIA ELSE
               PERFORM MOVE-FROM-VIA.
       MOVE-TO-VIA.
           MOVE TO-POLE TO VIA-POLE.
           MOVE DNUM (FROM-POLE) TO FP-TMP.
           MOVE DNUM (TMP-P) TO P-TMP.
           IF POLE (FROM-POLE, FP-TMP) > POLE (TMP-P, P-TMP)
               PERFORM MOVE-FROM-TO
           ELSE MOVE TMP-P TO TO-POLE.
       MOVE-FROM-TO.
           MOVE FROM-POLE TO TO-POLE.
           MOVE TMP-P TO FROM-POLE.
           MOVE DNUM (FROM-POLE) TO FP-TMP.
           MOVE DNUM (TMP-P) TO P-TMP.
       MOVE-FROM-VIA.
           MOVE FROM-POLE TO VIA-POLE.
           MOVE TMP-P TO FROM-POLE.

implement a recursive solution to solve the Towers of Hanoi problem, taking into account the number of disks. However, for early versions of COBOL that do not support recursion, an iterative algorithm adapted from Kolar's Hanoi Tower algorithm no. 1 is used instead.


Complete Program[edit]
Works with: IBM Enterprise COBOL for z/OS

      *******************************************************
       IDENTIFICATION DIVISION.
      *******************************************************
       PROGRAM-ID.      SHELLSRT.
      ************************************************************
      *** SHELLSORT                                           ****
      ************************************************************
       ENVIRONMENT DIVISION.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01 II                        PIC S9(008) COMP-5.
       01 IJ                        PIC S9(008) COMP-5.
       01 IZ                        PIC S9(008) COMP-5.
       01 IA                        PIC S9(008) COMP-5.
       01 STRT1                     PIC S9(008) COMP-5.
       01 STRT2                     PIC S9(008) COMP-5.
       01 LGT                       PIC S9(008) COMP-5.
       01 ORG                       PIC S9(008) COMP-5.
       01 DST                       PIC S9(008) COMP-5.
      *
       01 GAP                       PIC S9(008) COMP-5.
       01 NEGAP                     PIC S9(008) COMP-5.
       01 TEMP                      PIC X(32768).
       77 KEY-RESULT                PIC X.
      *
       LINKAGE SECTION.
       01 SRT-ARRAY                 PIC  X(1000000).
       01 NUM-ITEM                  PIC  9(008) COMP-5.
       01 SRT-DATA.
          03 LGT-ITEM               PIC  9(004) COMP-5.
          03 SRT-KEYS.
             05 SRT-KEY OCCURS 10.
                07 K-START         PIC S9(004) COMP-5.
                07 K-LENGTH        PIC S9(004) COMP-5.
                07 K-ASC           PIC X.
      *
      *    P R O C E D U R E      D I V I S I O N
      *
       PROCEDURE DIVISION USING SRT-ARRAY NUM-ITEM SRT-DATA.

           COMPUTE GAP = NUM-ITEM / 2.
           PERFORM UNTIL GAP < 1
              COMPUTE NEGAP = GAP * -1
              PERFORM VARYING II FROM GAP BY 1
                        UNTIL II GREATER  NUM-ITEM
                 MOVE ' ' TO KEY-RESULT
                 COMPUTE ORG = (II - 1) * LGT-ITEM + 1
                 MOVE SRT-ARRAY(ORG:LGT-ITEM) TO TEMP(1:LGT-ITEM)
                 PERFORM VARYING IJ FROM II BY NEGAP
                           UNTIL IJ NOT GREATER  GAP
                              OR (KEY-RESULT NOT EQUAL '<' AND ' ')
                    COMPUTE IA = IJ - GAP
                    IF IA < 1
                       MOVE 1 TO IA
                    END-IF
                    PERFORM COMPARE-KEYS
                    IF KEY-RESULT = '<'
                       COMPUTE ORG = (IA - 1) * LGT-ITEM + 1
                       COMPUTE DST = (IJ - 1) * LGT-ITEM + 1
                       MOVE SRT-ARRAY(ORG:LGT-ITEM)
                         TO SRT-ARRAY(DST:LGT-ITEM)
                       COMPUTE DST = (IA - 1) * LGT-ITEM + 1
                       MOVE TEMP(1:LGT-ITEM) TO SRT-ARRAY(DST:LGT-ITEM)
                    END-IF
                 END-PERFORM
              END-PERFORM
              IF GAP = 2
                 MOVE 1 TO GAP
              ELSE
                 COMPUTE GAP = GAP / 2.2
              END-IF
           END-PERFORM.
           GOBACK.
      *
       COMPARE-KEYS.
           MOVE ' ' TO KEY-RESULT
           PERFORM VARYING IZ FROM 1 BY 1
                     UNTIL IZ GREATER 10
                        OR (KEY-RESULT NOT EQUAL '=' AND ' ')
              IF SRT-KEY(IZ) GREATER LOW-VALUES
                 COMPUTE STRT1 = (IJ - 1) * LGT-ITEM + K-START(IZ)
                 COMPUTE STRT2 = (IA - 1) * LGT-ITEM + K-START(IZ)
                 MOVE K-LENGTH(IZ) TO LGT
                 IF SRT-ARRAY(STRT1:LGT) > SRT-ARRAY(STRT2:LGT) AND
                    K-ASC(IZ) EQUAL 'A'
                 OR SRT-ARRAY(STRT1:LGT) < SRT-ARRAY(STRT2:LGT) AND
                    K-ASC(IZ) EQUAL 'D'
                    MOVE '>' TO KEY-RESULT
                 END-IF
                 IF SRT-ARRAY(STRT1:LGT) < SRT-ARRAY(STRT2:LGT) AND
                    K-ASC(IZ) EQUAL 'A'
                 OR SRT-ARRAY(STRT1:LGT) > SRT-ARRAY(STRT2:LGT) AND
                    K-ASC(IZ) EQUAL 'D'
                    MOVE '<' TO KEY-RESULT
                 END-IF
              END-IF
           END-PERFORM.
           IF KEY-RESULT = ' '
              MOVE '=' TO KEY-RESULT
           END-IF.

Sorting Process[edit]

       C-PROCESS SECTION.
       C-000.
           DISPLAY "SORT STARTING".

           DIVIDE WC-SIZE BY 2 GIVING WC-GAP.

           PERFORM E-PROCESS-GAP UNTIL WC-GAP = 0.

           DISPLAY "SORT FINISHED".

       C-999.
           EXIT.

       E-PROCESS-GAP SECTION.
       E-000.
           PERFORM F-SELECTION VARYING WB-IX-1 FROM WC-GAP BY 1
                               UNTIL WB-IX-1 > WC-SIZE.

           DIVIDE WC-GAP BY 2.2 GIVING WC-GAP.

       E-999.
           EXIT.

       F-SELECTION SECTION.
       F-000.
           SET WB-IX-2            TO WB-IX-1.
           MOVE WB-ENTRY(WB-IX-1) TO WC-TEMP.

           SET WB-IX-3 TO WB-IX-2.
           SET WB-IX-3 DOWN BY WC-GAP.
           PERFORM G-PASS UNTIL WB-IX-2 NOT > WC-GAP
      * The next line logically reads :
      *                   or wb-entry(wb-ix-2 - wc-gap) not > wc-temp.
                          OR WB-ENTRY(WB-IX-3) NOT > WC-TEMP.

           IF WB-IX-1 NOT = WB-IX-2
              MOVE WC-TEMP TO WB-ENTRY(WB-IX-2).

       F-999.
           EXIT.

       G-PASS SECTION.
      * Note that WB-IX-3 is WC-GAP less than WB-IX-2.
      * Logically this should be :
      *    move wb-entry(wb-ix-2 - wc-gap) to wb-entry(wb-ix-2).
      *    set wb-ix-2 down by wc-gap.
      * Unfortunately wb-entry(wb-ix-2 - wc-gap) is not legal in C2 cobol
       G-000.
           MOVE WB-ENTRY(WB-IX-3) TO WB-ENTRY(WB-IX-2).
           SET WB-IX-2            DOWN BY WC-GAP.
           SET WB-IX-3            DOWN BY WC-GAP.

       G-999.
           EXIT.

implement the Shell sort algorithm to sort an array of elements. The algorithm uses a diminishing increment sort, with the increment size reducing after each pass until it reaches 1. The codes work with any sequence ending in 1 and use a geometric increment sequence with a ratio of about 2.2. The codes are compatible with Cobol/2 and sort arrays using the standard EBCDIC sequence. The user needs to provide an array, array length, and an area detailing row-length and up to 10 sort keys. The codes do not perform boundary checks and do not work properly with signed packed variables.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. loop-do-while.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  i PIC 99 VALUE 0.

       PROCEDURE DIVISION.
           PERFORM WITH TEST AFTER UNTIL FUNCTION MOD(i, 6) = 0
               ADD 1 TO i
               DISPLAY i
           END-PERFORM

           GOBACK
           .

Initialize a value at 0, then enter a loop which continues until the value modulo 6 is not 0. In each iteration, the value is incremented by 1 and then printed. The loop is executed at least once. This is implemented using the COBOL equivalent of a do-while loop, which is PERFORM WITH TEST AFTER UNTIL a certain condition is met.


Byte Length[edit]
FUNCTION BYTE-LENGTH(str)

Works with: GNU Cobol
LENGTH OF str

Works with: GNU Cobol
Works with: Visual COBOL
FUNCTION LENGTH-AN(str)

Character Length[edit]
FUNCTION LENGTH(str)

calculate the character and byte length of a string, considering UTF-8 encoding. It also handles non-BMP code points correctly, providing the actual character counts in code points, not in code unit counts. The code can also provide the string length in graphemes if the language is capable of it.


       identification division.
       program-id. toptail.

       data division.
       working-storage section.
       01 data-field.
          05 value "[this is a test]".

       procedure division.
       sample-main.
       display data-field
      *> Using reference modification, which is (start-position:length)
       display data-field(2:)
       display data-field(1:length of data-field - 1)
       display data-field(2:length of data-field - 2)
       goback.
       end program toptail.

The code demonstrates how to remove the first, last, and both the first and last characters from a string. It works with any valid Unicode code point in UTF-8 or UTF-16, referencing logical characters, not code units. It doesn't necessarily support all Unicode characters for other encodings like 8-bit ASCII or EUC-JP.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. knuth-shuffle.

       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  i                       PIC 9(8).
       01  j                       PIC 9(8).

       01  temp                    PIC 9(8).

       LINKAGE SECTION.
       78  Table-Len               VALUE 10.
       01  ttable-area.
           03  ttable              PIC 9(8) OCCURS Table-Len TIMES.

       PROCEDURE DIVISION USING ttable-area.
           MOVE FUNCTION RANDOM(FUNCTION CURRENT-DATE (11:6)) TO i

           PERFORM VARYING i FROM Table-Len BY -1 UNTIL i = 0
               COMPUTE j =
                   FUNCTION MOD(FUNCTION RANDOM * 10000, Table-Len) + 1

               MOVE ttable (i) TO temp
               MOVE ttable (j) TO ttable (i)
               MOVE temp TO ttable (j)
           END-PERFORM

           GOBACK
           .

implement the Knuth shuffle (also known as the Fisher-Yates shuffle) algorithm. This algorithm randomly shuffles the elements of an array in-place. The shuffling process involves iterating from the last index of the array down to 1, and for each index, swapping the element at that index with an element at a random index within the range of 0 to the current index. If in-place modification of the array is not possible in the used programming language, the algorithm can be adjusted to return a new shuffled array. The algorithm can also be modified to iterate from left to right if needed.


       program-id. last-fri.
       data division.
       working-storage section.
       1 wk-date.
        2 yr pic 9999.
        2 mo pic 99 value 1.
        2 da pic 99 value 1.
       1 rd-date redefines wk-date pic 9(8).
       1 binary.
        2 int-date pic 9(8).
        2 dow pic 9(4).
        2 friday pic 9(4) value 5.
       procedure division.
           display "Enter a calendar year (1601 thru 9999): "
               with no advancing
           accept yr
           if yr >= 1601 and <= 9999
               continue
           else
               display "Invalid year"
               stop run
           end-if
           perform 12 times
               move 1 to da
               add 1 to mo
               if mo > 12              *> to avoid y10k in 9999
                   move 12 to mo
                   move 31 to da
               end-if
               compute int-date = function
                   integer-of-date (rd-date)
               if mo =12 and da = 31   *> to avoid y10k in 9999
                   continue
               else
                   subtract 1 from int-date
               end-if
               compute rd-date = function
                   date-of-integer (int-date)
               compute dow = function mod
                   ((int-date - 1) 7) + 1
               compute dow = function mod ((dow - friday) 7)
               subtract dow from da
               display yr "-" mo "-" da
               add 1 to mo
           end-perform
           stop run
           .
       end program last-fri.

The code takes a year as input and outputs the dates of the last Friday of each month for that given year.


IDENTIFICATION DIVISION.
PROGRAM-ID. GOODBYE-WORLD.

PROCEDURE DIVISION.
DISPLAY 'Goodbye, World!'
    WITH NO ADVANCING
END-DISPLAY
.
STOP RUN.

"Display the string 'Goodbye, World!' without appending a newline at the end."


       IDENTIFICATION DIVISION.
       PROGRAM-ID. CAESAR.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  MSG        PIC X(50)
           VALUE "The quick brown fox jumped over the lazy dog.".
       01  OFFSET     PIC 9(4) VALUE 7 USAGE BINARY.
       01  FROM-CHARS PIC X(52).
       01  TO-CHARS   PIC X(52).
       01  TABL.
           02         PIC X(26) VALUE "abcdefghijklmnopqrstuvwxyz".
           02         PIC X(26) VALUE "ABCDEFGHIJKLMNOPQRSTUVWXYZ".
           02         PIC X(26) VALUE "abcdefghijklmnopqrstuvwxyz".
           02         PIC X(26) VALUE "ABCDEFGHIJKLMNOPQRSTUVWXYZ".

       PROCEDURE DIVISION.
       BEGIN.
           DISPLAY MSG
           PERFORM ENCRYPT
           DISPLAY MSG
           PERFORM DECRYPT
           DISPLAY MSG
           STOP RUN.

       ENCRYPT.
           MOVE TABL (1:52) TO FROM-CHARS
           MOVE TABL (1 + OFFSET:52) TO TO-CHARS
           INSPECT MSG CONVERTING FROM-CHARS TO TO-CHARS.

       DECRYPT.
           MOVE TABL (1 + OFFSET:52) TO FROM-CHARS
           MOVE TABL (1:52) TO TO-CHARS
           INSPECT MSG CONVERTING FROM-CHARS TO TO-CHARS.

       END PROGRAM CAESAR.

implement a Caesar cipher that can both encode and decode. The key for the cipher is an integer from 1 to 25 and rotates the letters of the alphabet either left or right. The cipher replaces each letter with the 1st to 25th next letter in the alphabet, wrapping Z to A. The codes also demonstrate that Caesar cipher is identical to Vigenère cipher with a key of length 1 and Rot-13 is identical to Caesar cipher with key 13. The codes are written in COBOL-85 ASCII or EBCIDIC.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. show-lcm.

       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       REPOSITORY.
           FUNCTION lcm
           .
       PROCEDURE DIVISION.
           DISPLAY "lcm(35, 21) = " FUNCTION lcm(35, 21)
           GOBACK
           .
       END PROGRAM show-lcm.

       IDENTIFICATION DIVISION.
       FUNCTION-ID. lcm.

       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       REPOSITORY.
           FUNCTION gcd
           .
       DATA DIVISION.
       LINKAGE SECTION.
       01  m                       PIC S9(8).
       01  n                       PIC S9(8).
       01  ret                     PIC S9(8).

       PROCEDURE DIVISION USING VALUE m, n RETURNING ret.
           COMPUTE ret = FUNCTION ABS(m * n) / FUNCTION gcd(m, n)
           GOBACK
           .
       END FUNCTION lcm.

       IDENTIFICATION DIVISION.
       FUNCTION-ID. gcd.

       DATA DIVISION.
       LOCAL-STORAGE SECTION.
       01  temp                    PIC S9(8).

       01  x                       PIC S9(8).
       01  y                       PIC S9(8).

       LINKAGE SECTION.
       01  m                       PIC S9(8).
       01  n                       PIC S9(8).
       01  ret                     PIC S9(8).

       PROCEDURE DIVISION USING VALUE m, n RETURNING ret.
           MOVE m to x
           MOVE n to y

           PERFORM UNTIL y = 0
               MOVE x TO temp
               MOVE y TO x
               MOVE FUNCTION MOD(temp, y) TO Y
           END-PERFORM

           MOVE FUNCTION ABS(x) TO ret
           GOBACK
           .
       END FUNCTION gcd.

calculate the least common multiple (LCM) of two integers m and n. The LCM is the smallest positive integer that has both m and n as factors. If either m or n is zero, the LCM is zero. The LCM can be calculated by iterating all the multiples of m until finding one that is also a multiple of n, or by using the formula lcm(m, n) = |m × n| / gcd(m, n), where gcd is the greatest common divisor. The LCM can also be found by merging the prime decompositions of both m and n.


Translation of: C#
Works with: Visual COBOL
01  things occurs 3.
...
set content of things to ("Apple", "Banana", "Coconut")
perform varying thing as string through things
    display thing
end-perform

iterate through each element in a collection in a sequential manner, printing each one. If the language supports it, a "for each" loop is used, otherwise, another type of loop is utilized. This is implemented in Managed COBOL dialect.


      identification division.
       program-id. tokenize.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 period constant as ".".
       01 cmma   constant as ",".

       01 start-with.
          05 value "Hello,How,Are,You,Today".

       01 items.
          05 item pic x(6) occurs 5 times.

       procedure division.
       tokenize-main.
       unstring start-with delimited by cmma
           into item(1) item(2) item(3) item(4) item(5)

       display trim(item(1)) period trim(item(2)) period
               trim(item(3)) period trim(item(4)) period
               trim(item(5))

       goback.
       end program tokenize.

"Tokenizes a string by separating it into an array based on commas, then displays the words to the user separated by a period. The code can handle complex cases with multiple delimiters, capture which delimiter was used for each field, and use a pointer for the starting position. It also includes match tallying."


       IDENTIFICATION DIVISION.
       PROGRAM-ID. GCD.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01 A        PIC 9(10)   VALUE ZEROES.
       01 B        PIC 9(10)   VALUE ZEROES.
       01 TEMP     PIC 9(10)   VALUE ZEROES.

       PROCEDURE DIVISION.
       Begin.
           DISPLAY "Enter first number, max 10 digits."
           ACCEPT A
           DISPLAY "Enter second number, max 10 digits."
           ACCEPT B
           IF A < B
             MOVE B TO TEMP
             MOVE A TO B
             MOVE TEMP TO B
           END-IF

           PERFORM UNTIL B = 0
             MOVE A TO TEMP
             MOVE B TO A
             DIVIDE TEMP BY B GIVING TEMP REMAINDER B
           END-PERFORM
           DISPLAY "The gcd is " A
           STOP RUN.

calculate the greatest common divisor (GCD), also known as the greatest common factor (GCF) or greatest common measure, of two integers. It is related to the task of finding the least common multiple. For more information, refer to the MathWorld and Wikipedia entries on the greatest common divisor.


Intrinsic Functions[edit]

        program-id. is-numeric.
        procedure division.
        display function test-numval-f("abc") end-display
        display function test-numval-f("-123.01E+3") end-display
        if function test-numval-f("+123.123") equal zero then
            display "is numeric" end-display
        else
            display "failed numval-f test" end-display
        end-if
        goback.

Implementation[edit]
Works with: OpenCOBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID. Is-Numeric.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  Numeric-Chars      PIC X(10) VALUE "0123456789".

       01  Success            CONSTANT 0.
       01  Failure            CONSTANT 128.

       LOCAL-STORAGE SECTION.
       01  I                  PIC 99.

       01  Num-Decimal-Points PIC 99.
       01  Num-Valid-Chars    PIC 99.

       LINKAGE SECTION.
       01  Str                PIC X(30).

       PROCEDURE DIVISION USING Str.
           IF Str = SPACES
               MOVE Failure TO Return-Code
               GOBACK
           END-IF

           MOVE FUNCTION TRIM(Str) TO Str

           INSPECT Str TALLYING Num-Decimal-Points FOR ALL "."
           IF Num-Decimal-Points > 1
               MOVE Failure TO Return-Code
               GOBACK
           ELSE
               ADD Num-Decimal-Points TO Num-Valid-Chars
           END-IF

           IF Str (1:1) = "-" OR "+"
               ADD 1 TO Num-Valid-Chars
           END-IF

           PERFORM VARYING I FROM 1 BY 1 UNTIL I > 10
               INSPECT Str TALLYING Num-Valid-Chars
                   FOR ALL Numeric-Chars (I:1) BEFORE SPACE
           END-PERFORM

           INSPECT Str TALLYING Num-Valid-Chars FOR TRAILING SPACES

           IF Num-Valid-Chars = FUNCTION LENGTH(Str)
               MOVE Success TO Return-Code
           ELSE
               MOVE Failure TO Return-Code
           END-IF

           GOBACK
           .

implement a boolean function to check if a given string is a numeric string, including floating point and negative numbers. The function utilizes COBOL's intrinsic functions TEST-NUMVAL, TEST-NUMVAL-C, and TEST-NUMVAL-F (for drafts supporting the 20XX standard) to validate the string. The function returns 0 if the string is valid, otherwise, it returns the position of the first incorrect character.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Trig.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  Pi-Third   USAGE COMP-2.
       01  Degree     USAGE COMP-2.

       01  60-Degrees USAGE COMP-2.

       01  Result     USAGE COMP-2.

       PROCEDURE DIVISION.
           COMPUTE Pi-Third = FUNCTION PI / 3

           DISPLAY "Radians:"
           DISPLAY "  Sin(π / 3)  = " FUNCTION SIN(Pi-Third)
           DISPLAY "  Cos(π / 3)  = " FUNCTION COS(Pi-Third)
           DISPLAY "  Tan(π / 3)  = " FUNCTION TAN(Pi-Third)
           DISPLAY "  Asin(0.5)   = " FUNCTION ASIN(0.5)
           DISPLAY "  Acos(0.5)   = " FUNCTION ACOS(0.5)
           DISPLAY "  Atan(0.5)   = " FUNCTION ATAN(0.5)

           COMPUTE Degree = FUNCTION PI / 180
           COMPUTE 60-Degrees = Degree * 60

           DISPLAY "Degrees:"
           DISPLAY "  Sin(60°)  = " FUNCTION SIN(60-Degrees)
           DISPLAY "  Cos(60°)  = " FUNCTION COS(60-Degrees)
           DISPLAY "  Tan(60°)  = " FUNCTION TAN(60-Degrees)
           COMPUTE Result = FUNCTION ASIN(0.5) / 60
           DISPLAY "  Asin(0.5) = " Result
           COMPUTE Result = FUNCTION ACOS(0.5) / 60
           DISPLAY "  Acos(0.5) = " Result
           COMPUTE Result = FUNCTION ATAN(0.5) / 60
           DISPLAY "  Atan(0.5) = " Result

           GOBACK
           .

demonstrate the usage of trigonometric functions (sine, cosine, tangent, and their inverses) with the same angle in both radians and degrees. It also includes the conversion of the results of inverse functions to radians and degrees. If the language lacks these functions, the code calculates them using known approximations or identities.


       identification division.
       program-id. signals.
       data division.
       working-storage section.
       01 signal-flag  pic 9 external.
          88 signalled value 1.
       01 half-seconds usage binary-long.
       01 start-time   usage binary-c-long.
       01 end-time     usage binary-c-long.
       01 handler      usage program-pointer.
       01 SIGINT       constant as 2.

       procedure division.
       call "gettimeofday" using start-time null
       set handler to entry "handle-sigint"
       call "signal" using by value SIGINT by value handler

       perform until exit
           if signalled then exit perform end-if
           call "CBL_OC_NANOSLEEP" using 500000000
           if signalled then exit perform end-if
           add 1 to half-seconds
           display half-seconds
       end-perform

       call "gettimeofday" using end-time null
       subtract start-time from end-time
       display "Program ran for " end-time " seconds"
       goback.
       end program signals.

       identification division.
       program-id. handle-sigint.
       data division.
       working-storage section.
       01 signal-flag  pic 9 external.

       linkage section.
       01 the-signal   usage binary-long.

       procedure division using by value the-signal returning omitted.
       move 1 to signal-flag
       goback.
       end program handle-sigint.

The code outputs an integer every half second. It handles SIGINT or SIGQUIT signals, often generated by user's ctrl-C or ctrl-\ commands. On receiving these signals, it stops outputting integers, displays the total runtime in seconds, and then terminates. The code is compatible with GnuCOBOL 2.0.


       PROGRAM-ID. increment-num-str.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  str                    PIC X(5) VALUE "12345".
       01  num                    REDEFINES str PIC 9(5).

       PROCEDURE DIVISION.
           DISPLAY str
           ADD 1 TO num
           DISPLAY str

           GOBACK
           .

       PROGRAM-ID. increment-num-str.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  num-str                PIC 9(5) VALUE 12345.

       PROCEDURE DIVISION.
           DISPLAY num-str
           ADD 1 TO num-str
           DISPLAY num-str

           GOBACK
           .

Code summarization: The code increments a numerical string, storing the contents as characters due to the implicit definition of num-str as USAGE DISPLAY.


"Code calculates the median value of a vector of floating-point numbers, handling even number of elements by returning the average of the two middle values. It uses the selection algorithm for efficient computation. It also includes tasks for calculating various statistical measures such as mean, mode, standard deviation, and others."


Canonical version[edit]
Works with: OpenCOBOL
      * FIZZBUZZ.COB
      * cobc -x -g FIZZBUZZ.COB
      *
       IDENTIFICATION        DIVISION.
       PROGRAM-ID.           fizzbuzz.
       DATA                  DIVISION.
       WORKING-STORAGE       SECTION.
       01 CNT      PIC 9(03) VALUE 1.
       01 REM      PIC 9(03) VALUE 0.
       01 QUOTIENT PIC 9(03) VALUE 0.
       PROCEDURE             DIVISION.
      *
       PERFORM UNTIL CNT > 100
         DIVIDE 15 INTO CNT GIVING QUOTIENT REMAINDER REM
         IF REM = 0
           THEN
             DISPLAY "FizzBuzz " WITH NO ADVANCING
           ELSE
             DIVIDE 3 INTO CNT GIVING QUOTIENT REMAINDER REM
             IF REM = 0
               THEN
                 DISPLAY "Fizz " WITH NO ADVANCING
               ELSE
                 DIVIDE 5 INTO CNT GIVING QUOTIENT REMAINDER REM
                 IF REM = 0
                   THEN
                     DISPLAY "Buzz " WITH NO ADVANCING
                   ELSE
                     DISPLAY CNT " " WITH NO ADVANCING
                 END-IF
             END-IF
         END-IF
         ADD 1 TO CNT
       END-PERFORM
       DISPLAY ""
       STOP RUN.

Simpler version[edit]

Works with: OpenCOBOL
Identification division.
Program-id. fizz-buzz.

Data division.
Working-storage section.

01 num pic 999.

Procedure division.
    Perform varying num from 1 by 1 until num > 100
        if function mod (num, 15) = 0 then display "fizzbuzz"
        else if function mod (num, 3) = 0 then display "fizz"
        else if function mod (num, 5) = 0 then display "buzz"
        else display num
    end-perform.
    Stop run.

Evaluate Version[edit]

Works with: OpenCOBOL
       IDENTIFICATION DIVISION.
       PROGRAM-ID.  FIZZBUZZ.
       ENVIRONMENT DIVISION.
       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  X PIC 999.
       01  Y PIC 999.
       01  REM3 PIC 999.
       01  REM5 PIC 999.
       PROCEDURE DIVISION.
           PERFORM VARYING X FROM 1 BY 1 UNTIL X > 100
               DIVIDE X BY 3 GIVING Y REMAINDER REM3
               DIVIDE X BY 5 GIVING Y REMAINDER REM5
            EVALUATE REM3 ALSO REM5
              WHEN ZERO ALSO ZERO
                DISPLAY "FizzBuzz"
              WHEN ZERO ALSO ANY
                DISPLAY "Fizz"
              WHEN ANY ALSO ZERO
                DISPLAY "Buzz"
              WHEN OTHER
                DISPLAY X
            END-EVALUATE
           END-PERFORM
           STOP RUN
           .

Chase the Fizz[edit]
Works with: OpenCOBOL

         >>SOURCE FORMAT FREE
identification division.
program-id. fizzbuzz.
data division.
working-storage section.
01  i pic 999.
01  fizz pic 999 value 3.
01  buzz pic 999 value 5.
procedure division.
start-fizzbuzz.
    perform varying i from 1 by 1 until i > 100
        evaluate i also i
        when fizz also buzz
            display 'fizzbuzz'
            add 3 to fizz
            add 5 to buzz
        when fizz also any
            display 'fizz'
            add 3 to fizz
        when buzz also any
            display 'buzz'
            add 5 to buzz
        when other
            display i
        end-evaluate
    end-perform
    stop run
    .
end program fizzbuzz.

print integers from 1 to 100, replacing multiples of three with 'Fizz', multiples of five with 'Buzz', and multiples of both three and five with 'FizzBuzz'.


IDENTIFICATION DIVISION.
PROGRAM-ID. MANDELBROT-SET-PROGRAM.
DATA DIVISION.
WORKING-STORAGE SECTION.
01  COMPLEX-ARITHMETIC.
    05 X               PIC S9V9(9).
    05 Y               PIC S9V9(9).
    05 X-A             PIC S9V9(6).
    05 X-B             PIC S9V9(6).
    05 Y-A             PIC S9V9(6).
    05 X-A-SQUARED     PIC S9V9(6).
    05 Y-A-SQUARED     PIC S9V9(6).
    05 SUM-OF-SQUARES  PIC S9V9(6).
    05 ROOT            PIC S9V9(6).
01  LOOP-COUNTERS.
    05 I               PIC 99.
    05 J               PIC 99.
    05 K               PIC 999.
77  PLOT-CHARACTER     PIC X.
PROCEDURE DIVISION.
CONTROL-PARAGRAPH.
    PERFORM OUTER-LOOP-PARAGRAPH
    VARYING I FROM 1 BY 1 UNTIL I IS GREATER THAN 24.
    STOP RUN.
OUTER-LOOP-PARAGRAPH.
    PERFORM INNER-LOOP-PARAGRAPH
    VARYING J FROM 1 BY 1 UNTIL J IS GREATER THAN 64.
    DISPLAY ''.
INNER-LOOP-PARAGRAPH.
    MOVE SPACE TO PLOT-CHARACTER.
    MOVE ZERO  TO X-A.
    MOVE ZERO  TO Y-A.
    MULTIPLY J   BY   0.0390625   GIVING X.
    SUBTRACT 1.5 FROM X.
    MULTIPLY I   BY   0.083333333 GIVING Y.
    SUBTRACT 1 FROM Y.
    PERFORM ITERATION-PARAGRAPH VARYING K FROM 1 BY 1
    UNTIL K IS GREATER THAN 100 OR PLOT-CHARACTER IS EQUAL TO '#'.
    DISPLAY PLOT-CHARACTER WITH NO ADVANCING.
ITERATION-PARAGRAPH.
    MULTIPLY X-A BY X-A GIVING X-A-SQUARED.
    MULTIPLY Y-A BY Y-A GIVING Y-A-SQUARED.
    SUBTRACT Y-A-SQUARED FROM X-A-SQUARED GIVING X-B.
    ADD      X   TO X-B.
    MULTIPLY X-A BY Y-A GIVING Y-A.
    MULTIPLY Y-A BY 2   GIVING Y-A.
    SUBTRACT Y   FROM Y-A.
    MOVE     X-B TO   X-A.
    ADD X-A-SQUARED TO Y-A-SQUARED GIVING SUM-OF-SQUARES.
    MOVE FUNCTION SQRT (SUM-OF-SQUARES) TO ROOT.
    IF ROOT IS GREATER THAN 2 THEN MOVE '#' TO PLOT-CHARACTER.

generate and draw the Mandelbrot set using various algorithms and functions.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. array-sum-and-product.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       78  Array-Size              VALUE 10.
       01  array-area              VALUE "01020304050607080910".
           03  array               PIC 99 OCCURS Array-Size TIMES.

       01  array-sum               PIC 9(8).
       01  array-product           PIC 9(10) VALUE 1.

       01  i                       PIC 99.

       PROCEDURE DIVISION.
           PERFORM VARYING i FROM 1 BY 1 UNTIL Array-Size < i
               ADD array (i) TO array-sum
               MULTIPLY array (i) BY array-product
           END-PERFORM

           DISPLAY "Sum:     " array-sum
           DISPLAY "Product: " array-product

           GOBACK
           .

Calculate the sum and product of all integers in an array.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. leap-year.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  examples VALUE "19001994199619972000".
           03  year PIC 9(4) OCCURS 5 TIMES
               INDEXED BY year-index.

       01  remainders.
           03 400-rem   PIC 9(4).
           03 100-rem   PIC 9(4).
           03 4-rem     PIC 9(4).

       PROCEDURE DIVISION.
           PERFORM VARYING year-index FROM 1 BY 1 UNTIL 5 < year-index
               MOVE FUNCTION MOD(year (year-index), 400) TO 400-rem
               MOVE FUNCTION MOD(year (year-index), 100) TO 100-rem
               MOVE FUNCTION MOD(year (year-index), 4) TO 4-rem

               IF 400-rem = 0 OR ((100-rem NOT = 0) AND 4-rem = 0)
                   DISPLAY year (year-index) " is a leap year."
               ELSE
                   DISPLAY year (year-index) " is not a leap year."
               END-IF
           END-PERFORM

           GOBACK
           .

       program-id. leap-yr.
           *> Given a year, where 1601 <= year <= 9999
           *> Determine if the year is a leap year
       data division.
       working-storage section.
       1 input-year pic 9999.
       1 binary.
        2 int-date pic 9(8).
        2 cal-mo-day pic 9(4).
       procedure division.
           display "Enter calendar year (1601 thru 9999): "
               with no advancing
           accept input-year
           if input-year >= 1601 and <= 9999
           then
                   *> if the 60th day of a year is Feb 29
                   *> then the year is a leap year
               compute int-date = function integer-of-day
                   ( input-year * 1000 + 60 )
               compute cal-mo-day = function mod (
                   (function date-of-integer ( int-date )) 10000 )
               display "Year " input-year space with no advancing
               if cal-mo-day = 229
                   display "is a leap year"
               else
                   display "is NOT a leap year"
               end-if
           else
               display "Input date is not within range"
           end-if
           stop run
           .
       end program leap-yr.

determine if a specified year is a leap year in the Gregorian calendar using Date Intrinsic Functions.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. DEPARTMENT-NUMBERS.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01 BANNER        PIC X(24) VALUE "POLICE  SANITATION  FIRE".
       01 COMBINATION.
          03 FILLER     PIC X(5)  VALUE SPACES.
          03 POLICE     PIC 9.
          03 FILLER     PIC X(11) VALUE SPACES.
          03 SANITATION PIC 9.
          03 FILLER     PIC X(5)  VALUE SPACES.
          03 FIRE       PIC 9.
       01 TOTAL         PIC 99.

       PROCEDURE DIVISION.
       BEGIN.
           DISPLAY BANNER.
           PERFORM POLICE-LOOP VARYING POLICE FROM 2 BY 2
           UNTIL POLICE IS GREATER THAN 6.
           STOP RUN.

       POLICE-LOOP.
           PERFORM SANITATION-LOOP VARYING SANITATION FROM 1 BY 1
           UNTIL SANITATION IS GREATER THAN 7.

       SANITATION-LOOP.
           PERFORM FIRE-LOOP VARYING FIRE FROM 1 BY 1
           UNTIL FIRE IS GREATER THAN 7.

       FIRE-LOOP.
           ADD POLICE, SANITATION, FIRE GIVING TOTAL.
           IF POLICE IS NOT EQUAL TO SANITATION
               AND POLICE IS NOT EQUAL TO FIRE
               AND SANITATION IS NOT EQUAL TO FIRE
               AND TOTAL IS EQUAL TO 12,
               DISPLAY COMBINATION.

all possible combinations of unique numbers between 1 and 7 (inclusive) for three different departments (police, sanitation, fire) that add up to 12, with the police department number being an even number.


Translation of: C#
MOVE "Hello" TO src
MOVE src TO dst

"Implements functionality to copy a string's content and create an additional reference to an existing string where applicable."


Works with: GNU Cobol
       >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. random-element.

DATA DIVISION.
WORKING-STORAGE SECTION.
01  nums-area                           VALUE "123456789".
    03  nums                            PIC 9 OCCURS 9 TIMES.

01  random-idx                          PIC 9 COMP.

PROCEDURE DIVISION.
    COMPUTE random-idx = FUNCTION RANDOM(FUNCTION CURRENT-DATE (9:7)) * 9 + 1
    DISPLAY nums (random-idx)
    .
END PROGRAM random-element.

demonstrate how to select a random element from a list.


        >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. binary-search.

DATA DIVISION.
WORKING-STORAGE SECTION.
01  nums-area                           VALUE "01040612184356".
    03  nums                            PIC 9(2)
                                        OCCURS 7 TIMES
                                        ASCENDING KEY nums
                                        INDEXED BY nums-idx.
PROCEDURE DIVISION.
    SEARCH ALL nums
        WHEN nums (nums-idx) = 4
            DISPLAY "Found 4 at index " nums-idx
    END-SEARCH
    .
END PROGRAM binary-search.

The code implements a binary search algorithm on a sorted integer array. It takes the starting point, ending point of a range, and a "secret value" as inputs. The search can be either recursive or iterative. It divides the range into halves and continues to narrow down the search field until the "secret value" is found. It also handles multiple values equal to the given value and indicates whether the element was found or not. The code also includes a fix for potential overflow bugs.


Works with: OpenCOBOL
Works with: Visual COBOL

       IDENTIFICATION DIVISION.
       PROGRAM-ID. accept-all-args.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  args                   PIC X(50).

       PROCEDURE DIVISION.
       main-line.
           ACCEPT args FROM COMMAND-LINE
           DISPLAY args

           GOBACK
           .

       IDENTIFICATION DIVISION.
       PROGRAM-ID. accept-args-one-at-a-time.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  arg                 PIC X(50) VALUE SPACES.

       PROCEDURE DIVISION.
           ACCEPT arg FROM ARGUMENT-VALUE
           PERFORM UNTIL arg = SPACES
               DISPLAY arg
               MOVE SPACES TO arg
               ACCEPT arg FROM ARGUMENT-VALUE
           END-PERFORM

           GOBACK
           .

Works with: OpenCOBOL
Works with: gnuCOBOL
       *>Created By Zwiegnet 8/19/2004

        IDENTIFICATION DIVISION.
        PROGRAM-ID. arguments.

        ENVIRONMENT DIVISION.

        DATA DIVISION.

        WORKING-STORAGE SECTION.

        01 command1 PIC X(50).
        01 command2 PIC X(50).
        01 command3 PIC X(50).

        PROCEDURE DIVISION.

        PERFORM GET-ARGS.

        *> Display Usage for Failed Checks
        ARGUSAGE.
        display "Usage: <command1> <command2> <command3>"
        STOP RUN.

        *> Evaluate Arguments
        GET-ARGS.
        ACCEPT command1 FROM ARGUMENT-VALUE
        IF command1 = SPACE OR LOW-VALUES THEN
        PERFORM ARGUSAGE
        ELSE
        INSPECT command1 REPLACING ALL SPACES BY LOW-VALUES

        ACCEPT command2 from ARGUMENT-VALUE
        IF command2 = SPACE OR LOW-VALUES THEN
        PERFORM ARGUSAGE
        ELSE
        INSPECT command2 REPLACING ALL SPACES BY LOW-VALUES

        ACCEPT command3 from ARGUMENT-VALUE
        IF command3 = SPACE OR LOW-VALUES THEN
        PERFORM ARGUSAGE
        ELSE
                INSPECT command3 REPLACING ALL SPACES BY LOW-VALUES

        *> Display Final Output
        display command1 " " command2 " " command3

        STOP RUN.

.

retrieve and print the list of command-line arguments passed to the program. It provides methods for retrieving all arguments at once or one at a time, with arguments being split by whitespace if not enclosed in quotes. It also handles passing arguments from UNIX/Linux Systems to COBOL, despite the COBOL standard not specifying methods for retrieving command-line arguments.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Nth-Root.
       AUTHOR.  Bill Gunshannon.
       INSTALLATION.
       DATE-WRITTEN.  4 Feb 2020.
      ************************************************************
      ** Program Abstract:
      **   Compute the Nth Root of a positive real number.
      **
      **   Takes values from console.  If Precision is left
      **   blank defaults to 0.001.
      **
      **   Enter 0 for first value to terminate program.
      ************************************************************

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT Root-File ASSIGN TO "Root-File"
                 ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.

       FILE SECTION.

       FD  Root-File
           DATA RECORD IS Parameters.
       01  Parameters.
           05 Root                       PIC 9(5).
           05 Num                        PIC 9(5)V9(5).
           05 Precision                  PIC 9V9(9).

       WORKING-STORAGE SECTION.

       01  TEMP0                         PIC 9(9)V9(9).
       01  TEMP1                         PIC 9(9)V9(9).
       01  RESULTS.
           05  Field1                        PIC ZZZZZ.ZZZZZ.
           05  FILLER                        PIC X(5).
           05  Field2                        PIC ZZZZ9.
           05  FILLER                        PIC X(14).
           05  Field3                        PIC 9.999999999.

       01  HEADER.
           05  FILLER                        PIC X(72)
               VALUE "   Number           Root           Precision.".

       01  Disp-Root                         PIC ZZZZZ.ZZZZZ.

       PROCEDURE DIVISION.

       Main-Program.
           PERFORM FOREVER

              PERFORM Get-Input
              IF Precision = 0.0
                  THEN MOVE 0.001 to Precision
              END-IF

              PERFORM Compute-Root

              MOVE Root TO Field2
              MOVE Num TO Field1
              MOVE Precision TO Field3
              DISPLAY HEADER
              DISPLAY RESULTS
              DISPLAY " "
              MOVE TEMP1 TO Disp-Root
              DISPLAY "The Root is: " Disp-Root
           END-PERFORM.

       Get-Input.
           DISPLAY "Input Base Number: " WITH NO ADVANCING
           ACCEPT Num
           IF Num EQUALS ZERO
              THEN
                   DISPLAY "Good Bye."
                   STOP RUN
           END-IF
           DISPLAY "Input Root: " WITH NO ADVANCING
           ACCEPT Root
           DISPLAY "Input Desired Precision: " WITH NO ADVANCING
           ACCEPT Precision.

       Compute-Root.
          MOVE Root TO TEMP0
          DIVIDE Num BY Root GIVING TEMP1

          PERFORM UNTIL FUNCTION ABS(TEMP0 - TEMP1)
                                    LESS THAN Precision
               MOVE TEMP1 TO TEMP0
               COMPUTE TEMP1 = (( Root - 1.0) * TEMP1 + Num /
                                        TEMP1 ** (Root - 1.0)) / Root
          END-PERFORM.

       END-PROGRAM.

Implement the principal nth root algorithm for a positive real number A.


       identification division.
       program-id. hostname.

       data division.
       working-storage section.
       01 hostname pic x(256).
       01 nullpos  pic 999 value 1.

       procedure division.
       call "gethostname" using hostname by value length of hostname
       string hostname delimited by low-value into hostname
           with pointer nullpos
       display "Host: " hostname(1 : nullpos - 1)
       goback.
       end program hostname.

"Determines and outputs the hostname of the current system where the routine is running."


"Generate a game that randomly selects four digits and prompts the user to create an arithmetic expression with these digits that equals 24. The code checks and evaluates the user's expression, allowing for addition, subtraction, multiplication, and division operations. The code does not allow the formation of multiple digit numbers from the given digits."


Works with: GNU Cobol version 2.0
       >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. run-length-encoding.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
    FUNCTION encode
    FUNCTION decode
    .
DATA DIVISION.
WORKING-STORAGE SECTION.
01  input-str                           PIC A(100).
01  encoded                             PIC X(200).
01  decoded                             PIC X(200).

PROCEDURE DIVISION.
    ACCEPT input-str
    MOVE encode(FUNCTION TRIM(input-str)) TO encoded
    DISPLAY "Encoded: " FUNCTION TRIM(encoded)
    DISPLAY "Decoded: " FUNCTION TRIM(decode(encoded))
    .
END PROGRAM run-length-encoding.

IDENTIFICATION DIVISION.
FUNCTION-ID. encode.

DATA DIVISION.
LOCAL-STORAGE SECTION.
01  str-len                             PIC 9(3) COMP.

01  i                                   PIC 9(3) COMP.

01  current-char                        PIC A.

01  num-chars                           PIC 9(3) COMP.
01  num-chars-disp                      PIC Z(3).

01  encoded-pos                         PIC 9(3) COMP VALUE 1.

LINKAGE SECTION.
01  str                                 PIC X ANY LENGTH.

01  encoded                             PIC X(200).

PROCEDURE DIVISION USING str RETURNING encoded.
    MOVE FUNCTION LENGTH(str) TO str-len
    MOVE str (1:1) TO current-char
    MOVE 1 TO num-chars
    PERFORM VARYING i FROM 2 BY 1 UNTIL i > str-len
        IF str (i:1) <> current-char
            CALL "add-num-chars" USING encoded, encoded-pos,
                CONTENT current-char, num-chars

            MOVE str (i:1) TO current-char
            MOVE 1 TO num-chars
        ELSE
            ADD 1 TO num-chars
        END-IF
    END-PERFORM

    CALL "add-num-chars" USING encoded, encoded-pos, CONTENT current-char,
        num-chars
    .
END FUNCTION encode.

IDENTIFICATION DIVISION.
PROGRAM-ID. add-num-chars.

DATA DIVISION.
WORKING-STORAGE SECTION.
01  num-chars-disp                      PIC Z(3).

LINKAGE SECTION.
01  str                                 PIC X(200).

01  current-pos                         PIC 9(3) COMP.

01  char-to-encode                      PIC X.

01  num-chars                           PIC 9(3) COMP.

PROCEDURE DIVISION USING str, current-pos, char-to-encode, num-chars.
    MOVE num-chars TO num-chars-disp
    MOVE FUNCTION TRIM(num-chars-disp) TO str (current-pos:3)
    ADD FUNCTION LENGTH(FUNCTION TRIM(num-chars-disp)) TO current-pos
    MOVE char-to-encode TO str (current-pos:1)
    ADD 1 TO current-pos
    .
END PROGRAM add-num-chars.

IDENTIFICATION DIVISION.
FUNCTION-ID. decode.

DATA DIVISION.
LOCAL-STORAGE SECTION.
01  encoded-pos                         PIC 9(3) COMP VALUE 1.
01  decoded-pos                         PIC 9(3) COMP VALUE 1.

01  num-of-char                         PIC 9(3) COMP VALUE 0.

LINKAGE SECTION.
01  encoded                             PIC X(200).

01  decoded                             PIC X(100).

PROCEDURE DIVISION USING encoded RETURNING decoded.
    PERFORM VARYING encoded-pos FROM 1 BY 1
            UNTIL encoded (encoded-pos:2) = SPACES OR encoded-pos > 200
        IF encoded (encoded-pos:1) IS NUMERIC
            COMPUTE num-of-char = num-of-char * 10
                + FUNCTION NUMVAL(encoded (encoded-pos:1))
        ELSE
            PERFORM UNTIL num-of-char = 0
                MOVE encoded (encoded-pos:1) TO decoded (decoded-pos:1)
                ADD 1 TO decoded-pos
                SUBTRACT 1 FROM num-of-char
            END-PERFORM
        END-IF
    END-PERFORM
    .
END FUNCTION decode.

implement a run-length encoding and decoding system for strings containing uppercase characters. The system compresses repeated characters by storing the length of the run and provides a function to reverse the compression.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Concat.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  Str  PIC X(7) VALUE "Hello, ".
       01  Str2 PIC X(15).

       PROCEDURE DIVISION.
           DISPLAY "Str  : " Str
           STRING Str " World!" DELIMITED BY SIZE INTO Str2
           DISPLAY "Str2 : " Str2

           GOBACK
           .

       ...
       PROCEDURE DIVISION.
           DISPLAY "Str  : " Str
           MOVE FUNCTION CONCATENATE(Str, " World!") TO Str2
           DISPLAY "Str2 : " Str2

           GOBACK
           .

*      *> Using a '&'.
       01  Long-Str-Val     PIC X(200) VALUE "Lorem ipsum dolor sit "
           & "amet, consectetuer adipiscing elit, sed diam nonummy "
           & "nibh euismod tincidunt ut laoreet dolore magna aliquam "
           & "erat volutpat.".

*      *> Using a '-' in column 7. Note the first two literals have no
*      *> closing quotes.
       01  Another-Long-Str PIC X(200) VALUE " Ut wisi enim ad minim
      -    "veniam, quis nostrud exerci tation ullamcorper suscipit
      -    "lobortis nisl ut aliquip ex ea commodo consequat".

- Initializes a string variable with a text value.
- Creates a second string variable that combines the original string variable with another string literal.
- Displays the content of the variables.
- Demonstrates string concatenation using the STRING verb and the CONCATENATE intrinsic function.
- Shows additional methods for concatenating string literals.


      *> TECTONICS
      *>   wget http://wiki.puzzlers.org/pub/wordlists/unixdict.txt
      *>   or visit https://sourceforge.net/projects/souptonuts/files
      *>   or snag ftp://ftp.openwall.com/pub/wordlists/all.gz
      *>      for a 5 million all language word file (a few phrases)
      *>   cobc -xj anagrams.cob [-DMOSTWORDS -DMOREWORDS -DALLWORDS]
      *> ***************************************************************
       identification division.
       program-id. anagrams.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       input-output section.
       file-control.
           select words-in
           assign to wordfile
           organization is line sequential
           status is words-status
           .

       REPLACE ==:LETTERS:== BY ==42==.

       data division.
       file section.
       fd words-in record is varying from 1 to :LETTERS: characters
                             depending on word-length.
       01 word-record.
          05 word-data         pic x occurs 0 to :LETTERS: times
                                     depending on word-length.

       working-storage section.
       >>IF ALLWORDS DEFINED
       01 wordfile     constant as "/usr/local/share/dict/all.words".
       01 max-words    constant as 4802100.

       >>ELSE-IF MOSTWORDS DEFINED
       01 wordfile     constant as "/usr/local/share/dict/linux.words".
       01 max-words    constant as 628000.

       >>ELSE-IF MOREWORDS DEFINED
       01 wordfile     constant as "/usr/share/dict/words".
       01 max-words    constant as 100000.

       >>ELSE
       01 wordfile     constant as "unixdict.txt".
       01 max-words    constant as 26000.
       >>END-IF

      *> The 5 million word file needs to restrict the word length
       >>IF ALLWORDS DEFINED
       01 max-letters          constant as 26.
       >>ELSE
       01 max-letters          constant as :LETTERS:.
       >>END-IF

       01 word-length          pic 99 comp-5.
       01 words-status         pic xx.
          88 ok-status         values '00' thru '09'.
          88 eof-status        value '10'.

      *> sortable word by letter table
       01 letter-index         usage index.
       01 letter-table.
          05 letters           occurs 1 to max-letters times
                               depending on word-length
                               ascending key letter
                               indexed by letter-index.
             10 letter         pic x.

      *> table of words
       01 sorted-index         usage index.
       01 word-table.
          05 word-list         occurs 0 to max-words times
                               depending on word-tally
                               ascending key sorted-word
                               indexed by sorted-index.
             10 match-count    pic 999 comp-5.
             10 this-word      pic x(max-letters).
             10 sorted-word    pic x(max-letters).
       01 sorted-display       pic x(10).

       01 interest-table.
          05 interest-list     pic 9(8) comp-5
                               occurs 0 to max-words times
                               depending on interest-tally.

       01 outer                pic 9(8) comp-5.
       01 inner                pic 9(8) comp-5.
       01 starter              pic 9(8) comp-5.
       01 ender                pic 9(8) comp-5.
       01 word-tally           pic 9(8) comp-5.
       01 interest-tally       pic 9(8) comp-5.
       01 tally-display        pic zz,zzz,zz9.

       01 most-matches         pic 99 comp-5.
       01 matches              pic 99 comp-5.
       01 match-display        pic z9.

      *> timing display
       01 time-stamp.
          05 filler            pic x(11).
          05 timer-hours       pic 99.
          05 filler            pic x.
          05 timer-minutes     pic 99.
          05 filler            pic x.
          05 timer-seconds     pic 99.
          05 filler            pic x.
          05 timer-subsec      pic v9(6).
       01 timer-elapsed        pic 9(6)v9(6).
       01 timer-value          pic 9(6)v9(6).
       01 timer-display        pic zzz,zz9.9(6).

      *> ***************************************************************
       procedure division.
       main-routine.

       >>IF ALLWORDS DEFINED
           display "** Words limited to " max-letters " letters **"
       >>END-IF

       perform show-time

       perform load-words
       perform find-most
       perform display-result

       perform show-time
       goback
       .

      *> ***************************************************************
       load-words.
       open input words-in
       if not ok-status then
           display "error opening " wordfile upon syserr
           move 1 to return-code
           goback
       end-if

       perform until exit
           read words-in
           if eof-status then exit perform end-if
           if not ok-status then
               display wordfile " read error: " words-status upon syserr
           end-if

           if word-length equal zero then exit perform cycle end-if

       >>IF ALLWORDS DEFINED
           move min(word-length, max-letters) to word-length
       >>END-IF

           add 1 to word-tally
           move word-record to this-word(word-tally) letter-table
           sort letters ascending key letter
           move letter-table to sorted-word(word-tally)
       end-perform

       move word-tally to tally-display
       display trim(tally-display) " words" with no advancing

       close words-in
       if not ok-status then
           display "error closing " wordfile upon syserr
           move 1 to return-code
       end-if

      *> sort word list by anagram check field
       sort word-list ascending key sorted-word
       .

      *> first entry in a list will end up with highest match count
       find-most.
       perform varying outer from 1 by 1 until outer > word-tally
           move 1 to matches
           add 1 to outer giving starter
           perform varying inner from starter by 1
                   until sorted-word(inner) not equal sorted-word(outer)
               add 1 to matches
           end-perform
           if matches > most-matches then
               move matches to most-matches
               initialize interest-table all to value
               move 0 to interest-tally
           end-if
           move matches to match-count(outer)
           if matches = most-matches then
               add 1 to interest-tally
               move outer to interest-list(interest-tally)
           end-if
       end-perform
       .

      *> only display the words with the most anagrams
       display-result.
       move interest-tally to tally-display
       move most-matches to match-display
       display ", most anagrams: " trim(match-display)
               ", with " trim(tally-display) " set" with no advancing
       if interest-tally not equal 1 then
           display "s" with no advancing
       end-if
       display " of interest"

       perform varying outer from 1 by 1 until outer > interest-tally
           move sorted-word(interest-list(outer)) to sorted-display
           display sorted-display
                   " [" trim(this-word(interest-list(outer)))
              with no advancing
           add 1 to interest-list(outer) giving starter
           add most-matches to interest-list(outer) giving ender
           perform varying inner from starter by 1
               until inner = ender
                   display ", " trim(this-word(inner))
                      with no advancing
           end-perform
           display "]"
       end-perform
       .

      *> elapsed time
       show-time.
       move formatted-current-date("YYYY-MM-DDThh:mm:ss.ssssss")
         to time-stamp
       compute timer-value = timer-hours * 3600 + timer-minutes * 60
                             + timer-seconds + timer-subsec
       if timer-elapsed = 0 then
           display time-stamp
           move timer-value to timer-elapsed
       else
           if timer-value < timer-elapsed then
               add 86400 to timer-value
           end-if
           subtract timer-elapsed from timer-value
           move timer-value to timer-display
           display time-stamp ", " trim(timer-display) " seconds"
       end-if
       .

       end program anagrams.

find the largest sets of anagrams from the word list provided at http://wiki.puzzlers.org/pub/wordlists/unixdict.txt using GnuCOBOL 2.0. The output display of all words is trimmed for width.


identification division.
program-id. countdown.
environment division.
data division.
working-storage section.
01	counter 		pic 99.
	88	counter-done	value 0.
01	counter-disp	pic Z9.
procedure division.
	perform with test after varying counter from 10 by -1 until counter-done
		move counter to counter-disp
		display counter-disp
	end-perform
	stop run.

The code performs a countdown from 10 to 0 using a downward for loop.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Display-Odd-Nums.

       DATA DIVISION.
       WORKING-STORAGE SECTION.
       01  I PIC 99.

       PROCEDURE DIVISION.
           PERFORM VARYING I FROM 1 BY 2 UNTIL 10 < I
               DISPLAY I
           END-PERFORM

           GOBACK
           .

demonstrate a for-loop with a step-value greater than one.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. Ackermann.

       DATA DIVISION.
       LINKAGE SECTION.
       01  M          USAGE UNSIGNED-LONG.
       01  N          USAGE UNSIGNED-LONG.

       01  Return-Val USAGE UNSIGNED-LONG.

       PROCEDURE DIVISION USING M N Return-Val.
           EVALUATE M ALSO N
               WHEN 0 ALSO ANY
                   ADD 1 TO N GIVING Return-Val

               WHEN NOT 0 ALSO 0
                   SUBTRACT 1 FROM M
                   CALL "Ackermann" USING BY CONTENT M BY CONTENT 1
                       BY REFERENCE Return-Val

               WHEN NOT 0 ALSO NOT 0
                   SUBTRACT 1 FROM N
                   CALL "Ackermann" USING BY CONTENT M BY CONTENT N
                       BY REFERENCE Return-Val

                   SUBTRACT 1 FROM M
                   CALL "Ackermann" USING BY CONTENT M
                       BY CONTENT Return-Val BY REFERENCE Return-Val
           END-EVALUATE

           GOBACK
           .

Implement the Ackermann function which is a recursive function that takes two non-negative arguments and returns a value based on the specified conditions. The function should ideally support arbitrary precision due to its rapid growth.


       identification division.
       program-id. array-concat.

       environment division.
       configuration section.
       repository.
           function all intrinsic.

       data division.
       working-storage section.
       01 table-one.
          05 int-field pic 999 occurs 0 to 5 depending on t1.
       01 table-two.
          05 int-field pic 9(4) occurs 0 to 10 depending on t2.

       77 t1           pic 99.
       77 t2           pic 99.

       77 show         pic z(4).

       procedure division.
       array-concat-main.
       perform initialize-tables
       perform concatenate-tables
       perform display-result
       goback.

       initialize-tables.
           move 4 to t1
           perform varying tally from 1 by 1 until tally > t1
               compute int-field of table-one(tally) = tally * 3
           end-perform

           move 3 to t2
           perform varying tally from 1 by 1 until tally > t2
               compute int-field of table-two(tally) = tally * 6
           end-perform
       .

       concatenate-tables.
           perform varying tally from 1 by 1 until tally > t1
               add 1 to t2
               move int-field of table-one(tally)
                 to int-field of table-two(t2)
           end-perform
       .

       display-result.
           perform varying tally from 1 by 1 until tally = t2
               move int-field of table-two(tally) to show
               display trim(show) ", " with no advancing
           end-perform
           move int-field of table-two(tally) to show
           display trim(show)
       .

       end program array-concat.

demonstrate how to concatenate two arrays.


       IDENTIFICATION DIVISION.
       PROGRAM-ID. MD5.
       AUTHOR.  Bill Gunshannon
       INSTALLATION.  Home.
       DATE-WRITTEN.  16 December 2021.
      ************************************************************
      ** Program Abstract:
      **   Use the md5sum utility and pass the HASH back using
      **     a temp file.  Not elegant, but it works.
      ************************************************************

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT Tmp-MD5 ASSIGN TO "/tmp/MD5"
                 ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.

       FILE SECTION.

       FD  Tmp-MD5
           DATA RECORD IS MD5-Rec.
       01  MD5-Rec       PIC X(32).

       WORKING-STORAGE SECTION.

       01 Eof                   PIC X     VALUE 'F'.
       01 Str1.
          05  Pre-cmd   PIC X(8)
              VALUE 'echo -n '.
          05  Str1-complete.
              10  Str1-Part1  PIC X(26)
                  VALUE  'The quick brown fox jumps'.
              10  Str1-Part2  PIC X(19)
                  VALUE  ' over the lazy dog'.
          05  Post-cmd    PIC X(20)
              VALUE  ' | md5sum > /tmp/MD5'.
       01  Str1-MD5          PIC X(32).

       PROCEDURE DIVISION.

       Main-Program.

           DISPLAY Str1-complete.
           PERFORM Get-MD5.
           DISPLAY Str1-MD5.

           STOP RUN.

       Get-MD5.

           CALL "SYSTEM" USING Str1.
           OPEN INPUT Tmp-MD5.
           READ Tmp-MD5 INTO Str1-MD5.
           CLOSE Tmp-MD5.
           CALL "CBL_DELETE_FILE" USING '/tmp/MD5'.

       IDENTIFICATION DIVISION.
       PROGRAM-ID. MD5-DEMO.
       AUTHOR.  Bill Gunshannon
       INSTALLATION.  Home.
       DATE-WRITTEN.  16 December 2021.
      ************************************************************
      ** Program Abstract:
      **   Use the md5sum utility and pass the HASH back using
      **     a temp file.  Not elegant, but it works.
      **   Same program but made MD5 a User Defined Function
      **     instead of a procedure.
      ************************************************************

       ENVIRONMENT DIVISION.

       CONFIGURATION SECTION.

       REPOSITORY.
          FUNCTION MD5.

       DATA DIVISION.

       WORKING-STORAGE SECTION.

       01 Eof                   PIC X     VALUE 'F'.
       01 Str1.
          05  Pre-cmd   PIC X(8)
              VALUE 'echo -n '.
          05  Str1-complete.
              10  Str1-Part1  PIC X(26)
                  VALUE  'The quick brown fox jumps'.
              10  Str1-Part2  PIC X(19)
                  VALUE  ' over the lazy dog'.
          05  Post-cmd    PIC X(20)
              VALUE  ' | md5sum > /tmp/MD5'.
       01  Str1-MD5          PIC X(32).

       PROCEDURE DIVISION.

       Main-Program.

           DISPLAY Str1-complete.
      *    PERFORM Get-MD5.
           MOVE FUNCTION MD5(Str1) TO Str1-MD5.
           DISPLAY Str1-MD5.

           STOP RUN.

        END PROGRAM MD5-DEMO.

       IDENTIFICATION DIVISION.
       FUNCTION-ID. MD5.

       ENVIRONMENT DIVISION.

       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT Tmp-MD5 ASSIGN TO "/tmp/MD5"
                 ORGANIZATION IS LINE SEQUENTIAL.

       DATA DIVISION.

       FILE SECTION.

       FD  Tmp-MD5
           DATA RECORD IS MD5-Rec.
       01  MD5-Rec       PIC X(32).

       LINKAGE SECTION.
       01  Str1        PIC X(128).
       01  Str1-MD5    PIC X(32).

       PROCEDURE DIVISION USING Str1 RETURNING Str1-MD5.

           CALL "SYSTEM" USING FUNCTION TRIM(Str1).
           OPEN INPUT Tmp-MD5.
           READ Tmp-MD5 INTO Str1-MD5.
           CLOSE Tmp-MD5.
           CALL "CBL_DELETE_FILE" USING '/tmp/MD5'.
           GO-BACK.

        END FUNCTION MD5.

implement an MD5 encoding for a given string. The codes also include an optional validation using test values from IETF RFC (1321) for MD5. However, due to known weaknesses of MD5, alternatives like SHA-256 or SHA-3 are recommended for production-grade cryptography. If the solution is a library, refer to MD5/Implementation for a scratch implementation.


Translation of: Delphi
Works with: GNU Cobol version 2.0
       >>SOURCE FREE
IDENTIFICATION DIVISION.
PROGRAM-ID. count-in-octal.

ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
REPOSITORY.
    FUNCTION dec-to-oct
    .
DATA DIVISION.
WORKING-STORAGE SECTION.
01  i                                   PIC 9(18).

PROCEDURE DIVISION.
    PERFORM VARYING i FROM 1 BY 1 UNTIL i = 0
        DISPLAY FUNCTION dec-to-oct(i)
    END-PERFORM
    .
END PROGRAM count-in-octal.

IDENTIFICATION DIVISION.
FUNCTION-ID. dec-to-oct.

DATA DIVISION.
LOCAL-STORAGE SECTION.
01  rem                                 PIC 9.

01  dec                                 PIC 9(18).

LINKAGE SECTION.
01  dec-arg                             PIC 9(18).

01  oct                                 PIC 9(18).

PROCEDURE DIVISION USING dec-arg RETURNING oct.
    MOVE dec-arg TO dec *> Copy is made to avoid modifying reference arg.
    PERFORM WITH TEST AFTER UNTIL dec = 0
        MOVE FUNCTION REM(dec, 8) TO rem
        STRING rem, oct DELIMITED BY SPACES INTO oct
        DIVIDE 8 INTO dec
    END-PERFORM
    .
END FUNCTION dec-to-oct.

generate a sequential count in octal, starting from zero and incrementing by one on each line until the program is terminated or the maximum numeric type value is reached.