├── Makefile.example ├── README.md ├── default.tex └── src ├── Makefile ├── actions.f90 ├── define.f90 ├── fson.f90 ├── fson_path_m.f90 ├── fson_string_m.f90 ├── fson_value_m.f90 ├── hash.f90 ├── inline.f90 ├── libcurl.c ├── mainmpi.f90 ├── sleep.c ├── strings.f90 ├── tgAPI.f90 ├── wfile.f90 ├── wrank.f90 └── wsleep.f90 /Makefile.example: -------------------------------------------------------------------------------- 1 | #MPIDIR = /usr/lib64/mpich-3.2/bin/ 2 | MPIDIR = /usr/lib64/openmpi/bin/ 3 | 4 | FCMPI = $(MPIDIR)mpifort 5 | FC = gfortran 6 | CC = gcc 7 | FLAGS = "-std=f2008 -ffree-line-length-none -fbackslash" 8 | EXE = inline 9 | CHECKRANGE = -fno-range-check 10 | OPTHASH = -O3 11 | OPT = -O2 12 | 13 | MPIRUN = $(MPIDIR)mpiexec 14 | NPROC = 11 15 | #FOR RUNNING WITH OPENMPI 16 | MPIPROC = --oversubscribe -np $(NPROC) 17 | #FOR RUNNING WITH MPICH 18 | #MPIPROC = -np $(NPROC) 19 | ZIP = zip 20 | 21 | VERSION = 0.00 22 | 23 | PROXY = 24 | BOTKEY = #BOT KEY 25 | BOTURL = #BOT IP OR BOT URL 26 | 27 | 28 | default: 29 | rm -rf build || true 30 | mkdir build 31 | cp ./src/* ./build/ 32 | time $(MAKE) -C build default FC=$(FCMPI) CC=$(CC) EXE=$(EXE) FLAGS=$(FLAGS) CHECKRANGE=$(CHECKRANGE) OPTHASH=$(OPTHASH) OPT=$(OPT) PROXY=$(PROXY) BOTKEY=$(BOTKEY) VERSION=$(VERSION) URLBOT=$(BOTURL) 33 | rm -rf ./build 34 | $(MAKE) zip 35 | $(MPIRUN) $(MPIPROC) ./$(EXE) 36 | 37 | test: 38 | rm -rf build || true 39 | mkdir build 40 | cp ./src/* ./build/ 41 | $(MAKE) -C build test FC=$(FC) EXE=$(EXE) FLAGS=$(FLAGS) CHECKRANGE=$(CHECKRANGE) OPTHASH=$(OPTHASH) OPT=$(OPT) 42 | rm -rf ./build 43 | ./$(EXE) 44 | 45 | zip: 46 | rm -f $(EXE)_v$(VERSION).zip || true 47 | zip $(EXE)_v$(VERSION).zip Makefile.example *.tex ./src ./libs -r9 48 | 49 | run: 50 | $(MPIRUN) $(MPIPROC) ./$(EXE) -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Simple Telegram Bot written on FORTRAN for generating LaTeX pictures in private messages and inline mode 2 | -------------------------------------------------------------------------------- /default.tex: -------------------------------------------------------------------------------- 1 | \documentclass[varwidth,border={2pt 2pt 2pt 2pt}]{standalone} 2 | \thispagestyle{empty} 3 | %usepackage% 4 | \begin{document} 5 | $ \displaystyle 6 | %latex_text% 7 | $ 8 | \end{document} -------------------------------------------------------------------------------- /src/Makefile: -------------------------------------------------------------------------------- 1 | VERSION = "UNDERFINED" 2 | 3 | default: 4 | $(MAKE) fson 5 | $(FC) -c hash.f90 $(FLAGS) $(CHECKRANGE) $(OPTHASH) 6 | $(CC) -c sleep.c $(OPT) 7 | $(CC) -c libcurl.c $(OPT) -DPROXY="\"$(PROXY)\"" 8 | $(FC) -c define.f90 $(FLAGS) $(OPT) -cpp -DBOTKEY="\"$(BOTKEY)\"" -DURLBOTKEY="\"$(URLBOT)\"" 9 | $(FC) -c wsleep.f90 $(FLAGS) $(OPT) -fall-intrinsics 10 | $(FC) -c strings.f90 $(FLAGS) $(OPT) 11 | $(FC) -c inline.f90 $(FLAGS) $(OPT) 12 | $(FC) -c tgAPI.f90 $(FLAGS) $(OPT) 13 | $(FC) -c wfile.f90 $(FLAGS) $(OPT) 14 | $(FC) -c actions.f90 $(FLAGS) $(OPT) -DVERSION="\"$(VERSION)\"" -cpp 15 | $(FC) -c wrank.f90 $(FLAGS) $(OPT) 16 | $(FC) -c mainmpi.f90 $(FLAGS) $(OPT) -fall-intrinsics 17 | $(FC) *.o $(FLAGS) -o ../$(EXE) -lcurl 18 | 19 | fson: 20 | $(FC) -c fson_string_m.f90 $(OPT) 21 | $(FC) -c fson_value_m.f90 $(OPT) 22 | $(FC) -c fson_path_m.f90 $(OPT) 23 | $(FC) -c fson.f90 $(OPT) -fbackslash 24 | -------------------------------------------------------------------------------- /src/actions.f90: -------------------------------------------------------------------------------- 1 | module actions 2 | implicit none 3 | contains 4 | subroutine inputLaTeX(ID, MESSID, LATEX, filenm, strerr) 5 | use wfile, only : latexdefault, writelog, savelatex, generatelatex 6 | implicit none 7 | character(len=:), allocatable, intent(out) :: filenm, strerr 8 | character(len=*), intent(in) :: ID, MESSID, LATEX 9 | character(len=:), allocatable :: default, packages, fullfile, stat 10 | integer :: ind1, ind2, lenpack, lendata 11 | call LatexDefault(default) 12 | call getPackages(ID, MESSID, packages) 13 | call writeLog(ID, MESSID, LATEX) 14 | lenpack = len_trim('%usepackage%') 15 | ind1 = index(default, '%usepackage%') 16 | lendata = len_trim('%latex_text%') 17 | ind2 = index(default, '%latex_text%') 18 | fullfile = default(:ind1-1) // packages // default(ind1+lenpack:ind2-1) // LATEX // default(ind2+lendata:) 19 | call saveLaTeX(fullfile, filenm) 20 | call generateLaTeX(filenm, stat) 21 | if(len_trim(stat) .ne. 2) then 22 | strerr = stat 23 | else 24 | strerr = "" 25 | filenm = filenm // '.png' 26 | end if 27 | call writeLog(ID, MESSID, filenm) 28 | end subroutine 29 | 30 | subroutine getPackages(ID, MESSID, settings, isMessage) 31 | use wfile, wgetPackages => getPackages 32 | implicit none 33 | character(len=*), intent(in) :: ID, MESSID 34 | character(len=:), allocatable :: settings 35 | logical , optional :: isMessage 36 | call getUserData(ID, MESSID) 37 | if(present(isMessage)) then 38 | call wgetPackages(ID, settings, .TRUE.) 39 | else 40 | call wgetPackages(ID, settings) 41 | end if 42 | end subroutine 43 | 44 | subroutine reset(ID, MESSID) 45 | use wfile, only : wreset => reset 46 | implicit none 47 | character(len=*), intent(in) :: ID, MESSID 48 | call wreset(ID, MESSID) 49 | end subroutine 50 | 51 | subroutine addPackage(ID, MESSID, package) 52 | use wfile, only : appendHeadline 53 | implicit none 54 | character(len=*), intent(in) :: ID, MESSID, package 55 | call appendHeadline(ID, MESSID, '\\usepackage', package) 56 | end subroutine 57 | 58 | subroutine addPreambula(ID, MESSID, message) 59 | use wfile, only : appendHeadline 60 | implicit none 61 | character(len=*), intent(in) :: ID, MESSID, message 62 | call appendHeadline(ID, MESSID, '', message) 63 | end subroutine 64 | 65 | subroutine removePackage(ID, MESSID, num_package, text) 66 | use wfile, wgetPackages => getPackages 67 | implicit none 68 | character(len=*), intent(in) :: ID, MESSID, num_package 69 | character(len=:), allocatable, intent(out) :: text 70 | integer(4) :: val, stat, line, skip 71 | character(len=:), allocatable :: settings, strtmp 72 | character(len=5) :: sline 73 | val = 0 74 | line = 1 75 | skip = 1 76 | read(num_package, *, iostat=stat) val 77 | call wgetPackages(ID, settings, .TRUE.) 78 | if(stat.eq.0) then 79 | text = 'Number was read, but function is not implemented yet' 80 | strtmp = '' 81 | do while (index(settings(skip:), '\n').ne.0) 82 | write (sline, '(I5)') line 83 | if(line.ne.val) then 84 | strtmp = strtmp // settings(skip:skip + index(settings(skip:), '\n')-1) 85 | end if 86 | skip = skip + index(settings(skip:), '\n') 87 | line = line + 1 88 | end do 89 | call setHeadlines(ID, MESSID, strtmp) 90 | text = 'Now, your file is: ```\n' // strtmp // '```' 91 | else 92 | text = 'Sorry, It is not a number\nYour file with line numbersis: ```' 93 | do while (index(settings(skip:), '\n').ne.0) 94 | write (sline, '(I5)') line 95 | strtmp = settings(:skip-1) // sline // ': ' // settings(skip:) 96 | settings = strtmp 97 | skip = skip + index(settings(skip:), '\n') 98 | line = line + 1 99 | end do 100 | text = text // settings // '```\n If you want to remove some string, input this line number.' 101 | end if 102 | end subroutine 103 | 104 | subroutine start(str) 105 | implicit none 106 | character(len=:), allocatable :: str 107 | str = 'Hi!' // NEW_LINE('') // 'I am a simple *Fortran* bot!' 108 | end subroutine 109 | 110 | subroutine ip(ID, MESSID, text) 111 | character(len=*), intent(in) :: ID, MESSID 112 | character(len=*), intent(out) :: text 113 | integer :: idmess 114 | character(len=1024) :: msg 115 | read (MESSID, '(I10)') idmess 116 | if(idmess .ne. 336838433) then 117 | text = 'You do not access to this command' 118 | else 119 | text = 'Something went wrong' 120 | call execute_command_line('ifconfig', cmdmsg=msg) 121 | print *, msg 122 | text = trim(msg) 123 | end if 124 | end subroutine 125 | 126 | subroutine help(str) 127 | implicit none 128 | character(len=:), allocatable :: str 129 | str = 'I can convert your text into LaTeX pictire' 130 | end subroutine 131 | 132 | subroutine debug() 133 | end subroutine 134 | 135 | subroutine fox(key) 136 | use strings, only : ItC 137 | character(len=:), allocatable, intent(out) :: key 138 | real(4) :: randreal 139 | integer(4) :: fileid 140 | call random_number(randreal) 141 | fileid = 1 + floor(randreal*(5)) 142 | key = './foxes/' // ItC(fileid) // '.jpg' 143 | end subroutine 144 | 145 | subroutine generateResponse(userid, updateid, command, inputtext, resulttype, key, error) 146 | use wfile, only : writelog, checkfiles, setHeadlines 147 | implicit none 148 | integer(4), intent(in) :: userid, updateid, command 149 | character(len=*), intent(in) :: inputtext 150 | integer(4), intent(out) :: resulttype 151 | character(len=:), allocatable, intent(out) :: key, error 152 | character(len=12) :: suserid, supdateid, scommand 153 | write (suserid, "(I12)") userid 154 | write (supdateid, "(I12)") updateid 155 | write (scommand, "(I12)") command 156 | call checkFiles(suserid, supdateid) 157 | error = "" 158 | if(command.le.-3) then 159 | key = 'Something went wrong :(' 160 | resulttype = 0 161 | else if(command.eq.-2) then 162 | key = 'files not supported yet' 163 | resulttype = 0 164 | else if(command.eq.-1) then 165 | call inputlatex(suserid, supdateid, inputtext, key, error) 166 | resulttype = 1 167 | else if(command.eq.0) then 168 | call start(key) 169 | resulttype = 3 170 | else if(command.eq.1) then 171 | call help(key) 172 | resulttype = 0 173 | else if(command.eq.2) then 174 | call reset(suserid, supdateid) 175 | key = 'Resetting your settings' 176 | resulttype = 0 177 | else if(command.eq.3) then 178 | call getPackages(suserid, supdateid, key, .TRUE.) 179 | resulttype = 0 180 | else if(command.eq.4) then 181 | if (len(trim(inputtext)).eq.0) then 182 | key = 'Usage "/addpackage PACKAGE". It will be generated as "\\usepackagePACKAGE" ' 183 | else 184 | call addPackage(suserid, supdateid, inputtext) 185 | key = 'Package was added' 186 | end if 187 | resulttype = 0 188 | else if(command.eq.5) then 189 | call removePackage(suserid, supdateid, inputtext, key) 190 | resulttype = 3 191 | else if(command.eq.6) then 192 | call inputlatex(suserid, supdateid, inputtext, key, error) 193 | resulttype = 1 194 | if(index(key, 'png').eq.0) then 195 | resulttype = 2 196 | key = key // '.log' 197 | end if 198 | else if(command.eq.7) then 199 | call fox(key) 200 | resulttype = 1 201 | else if(command.eq.8) then 202 | key = 'Command not implemented yet' 203 | resulttype = 0 204 | else if(command.eq.9) then 205 | key = '``` VERSION ' // VERSION // NEW_LINE('') // 'COMPILED AT ' // __TIMESTAMP__ // '```' 206 | resulttype = 3 207 | else if(command.eq.10) then 208 | if (len(trim(inputtext)).eq.0) then 209 | key = 'Usage "/preambula text". It will be generated as "text" near \\usepackages ' 210 | else 211 | call addPreambula(suserid, supdateid, inputtext) 212 | key = 'Preambula was added' 213 | end if 214 | resulttype = 0 215 | else if(command.eq.11) then 216 | if(len(trim(inputtext)).eq.0) then 217 | key = 'Usage "/setpreambula text". It changed your preabula to text' 218 | else 219 | call setHeadlines(suserid, supdateid, inputtext) 220 | key = 'Preambula was changed' 221 | end if 222 | resulttype = 0 223 | else if(command.eq.12) then 224 | call ip(suserid, supdateid, key) 225 | resulttype = 0 226 | else if(command.ge.13) then 227 | key = 'Unsupported command' 228 | resulttype = 0 229 | else 230 | key = 'How do you do this?' 231 | resulttype = 0 232 | end if 233 | call writelog(suserid, supdateid, scommand) 234 | call writelog(suserid, supdateid, inputtext) 235 | call writelog(suserid, supdateid, key) 236 | call writelog(suserid, supdateid, error) 237 | end subroutine 238 | 239 | subroutine inlineresponse(userid, supdateid, command, inputtext) 240 | use wfile, only : writelog, checkfiles 241 | use define, only : URLBOT 242 | use inline 243 | use tgAPI, only : answerInlineQuery 244 | integer(4), intent(in) :: userid, command 245 | character(len=*), intent(in) :: supdateid, inputtext 246 | integer(4) :: resulttype 247 | character(len=:), allocatable :: key, error 248 | character(len=12) :: suserid, scommand 249 | character(len=:), allocatable :: result, text, message 250 | integer(4) :: stat 251 | write (suserid, "(I12)") userid 252 | write (scommand, "(I12)") command 253 | call checkFiles(suserid, supdateid(1:7)) 254 | error = "" 255 | key = "" 256 | if(command.le.-2) then 257 | key = "Something went wrong" 258 | resulttype = 0 259 | else if(command.eq.-1) then 260 | call inputlatex(suserid, trim(supdateid(1:7)), inputtext, key, error) 261 | if(index(key, 'png').eq.0) then 262 | resulttype = 0 263 | key = key // '.log' 264 | else 265 | key = URLBOT // key(2:) 266 | end if 267 | resulttype = 1 268 | else if(command.eq.0) then 269 | call fox(key) 270 | key = URLBOT // key(2:) 271 | resulttype = 1 272 | else 273 | key = "Something went wrong" 274 | resulttype = 0 275 | end if 276 | if(resulttype.eq.1) then 277 | call InlineQueryResultPhoto(id="0", photo_url=key, thumb_url=key, json_str=text) 278 | call ResultArray([text], result) 279 | print *, text, supdateid, suserid 280 | call answerInlineQuery(inline_query_id=trim(supdateid), results=result, is_personal=.true., status=stat) 281 | else 282 | call InputTextMessageContent(message_text="Something went wrong :(", json_str=message) 283 | call InlineQueryResultArticle(id="0", Title="ERROR IN LaTeX", input_message_content=message, json_str=text) 284 | call ResultArray([text], result) 285 | call answerInlineQuery(inline_query_id=trim(supdateid), results=result, is_personal=.true., status=stat) 286 | print *, text, supdateid, suserid 287 | end if 288 | call writelog(suserid, supdateid(1:7), scommand) 289 | call writelog(suserid, supdateid(1:7), inputtext) 290 | call writelog(suserid, supdateid(1:7), key) 291 | end subroutine 292 | end module -------------------------------------------------------------------------------- /src/define.f90: -------------------------------------------------------------------------------- 1 | module define 2 | implicit none 3 | integer :: count_inline, count_sender 4 | integer :: workermode, inlinemode 5 | 6 | character(len=*) :: START_ERROR 7 | character(len=*) :: URLBOT, BOT_USERNAME 8 | character(len=*) :: TGBOTKEY 9 | 10 | parameter(count_inline = 3, count_sender=4) 11 | parameter(workermode = 0, inlinemode = 1) 12 | 13 | parameter(START_ERROR="THIS PROGRAM CANNOT WORK\nTHREADS NOT ENOUGH\nNEEDS, AT LEAST, 11") ! updater + parser + count_worker (1) + count_inline + queue+sender + count_sender 14 | parameter(URLBOT = "https://" // URLBOTKEY, BOT_USERNAME = "testfortranapibot") 15 | parameter(TGBOTKEY = BOTKEY) 16 | end module -------------------------------------------------------------------------------- /src/fson.f90: -------------------------------------------------------------------------------- 1 | ! Copyright (c) 2012 Joseph A. Levin 2 | ! 3 | ! Permission is hereby granted, free of charge, to any person obtaining a copy of this 4 | ! software and associated documentation files (the "Software"), to deal in the Software 5 | ! without restriction, including without limitation the rights to use, copy, modify, merge, 6 | ! publish, distribute, sublicense, and/or sell copies of the Software, and to permit 7 | ! persons to whom the Software is furnished to do so, subject to the following conditions: 8 | ! 9 | ! The above copyright notice and this permission notice shall be included in all copies or 10 | ! substantial portions of the Software. 11 | ! 12 | ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, 13 | ! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 14 | ! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 15 | ! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT 16 | ! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 17 | ! DEALINGS IN THE SOFTWARE. 18 | 19 | 20 | ! FSON MODULE 21 | ! 22 | ! File: fson.f95 23 | ! Author: Joseph A. Levin 24 | ! 25 | ! Created on March 6, 2012, 7:48 PM 26 | ! 27 | 28 | module fson 29 | use fson_value_m, fson_print => fson_value_print, fson_destroy => fson_value_destroy 30 | use fson_string_m 31 | use fson_path_m, fson_get => fson_path_get, fson_check => fson_path_check 32 | 33 | implicit none 34 | 35 | private 36 | 37 | public :: fson_parse, fson_value, fson_get, fson_print, fson_destroy, fson_check 38 | 39 | ! FILE IOSTAT CODES 40 | integer, parameter :: end_of_file = -1 41 | integer, parameter :: end_of_record = -2 42 | 43 | ! PARSING STATES 44 | integer, parameter :: STATE_LOOKING_FOR_VALUE = 1 45 | integer, parameter :: STATE_IN_OBJECT = 2 46 | integer, parameter :: STATE_IN_PAIR_NAME = 3 47 | integer, parameter :: STATE_IN_PAIR_VALUE = 4 48 | 49 | ! POP/PUSH CHARACTER 50 | integer :: pushed_index = 0 51 | character (len = 10) :: pushed_char 52 | 53 | contains 54 | 55 | ! 56 | ! FSON PARSE 57 | ! 58 | function fson_parse(file, unit, str) result(p) 59 | type(fson_value), pointer :: p 60 | integer, optional, intent(inout) :: unit 61 | character(len = *), optional, intent(in) :: file 62 | character(len = *), optional, intent(in) :: str 63 | character(len=:),allocatable :: strBuffer 64 | logical :: unit_available 65 | integer :: u 66 | ! init the pointer to null 67 | nullify(p) 68 | 69 | ! select the file unit to use 70 | if (present(unit) .and. present(file)) then 71 | u = unit 72 | elseif (present(file)) then 73 | ! find the first available unit 74 | unit_available = .false. 75 | u = 20 76 | 77 | do while (.not.unit_available) 78 | inquire(unit = u, exist = unit_available) 79 | u = u + 1 80 | end do 81 | elseif (present(str)) then 82 | strBuffer = str 83 | u = 0 84 | else 85 | print *, "ERROR: Need a file or a string" 86 | call exit (1) 87 | end if 88 | 89 | ! open the file 90 | if (present(file)) then 91 | open (unit = u, file = file, status = "old", action = "read", form = "formatted", position = "rewind") 92 | end if 93 | 94 | ! create the value and associate the pointer 95 | p => fson_value_create() 96 | 97 | ! parse as a value 98 | call parse_value(unit = u, value = p, str = strBuffer) 99 | 100 | ! close the file 101 | if( .not. present(unit)) then 102 | close (u) 103 | end if 104 | 105 | if(allocated(strBuffer)) deallocate(strBuffer) 106 | 107 | end function fson_parse 108 | 109 | ! 110 | ! PARSE_VALUE 111 | ! 112 | recursive subroutine parse_value(unit, str, value) 113 | integer, intent(inout) :: unit 114 | character(*), intent(inout) :: str 115 | type(fson_value), pointer :: value 116 | logical :: eof 117 | character :: c 118 | 119 | ! pop the next non whitespace character off the file 120 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 121 | 122 | if (eof) then 123 | return 124 | else 125 | select case (c) 126 | case ("{") 127 | ! start object 128 | value % value_type = TYPE_OBJECT 129 | call parse_object(unit, str, value) 130 | case ("[") 131 | ! start array 132 | value % value_type = TYPE_ARRAY 133 | call parse_array(unit, str, value) 134 | case ("]") 135 | ! end an empty array 136 | call push_char(c) 137 | nullify(value) 138 | case ('"') 139 | ! string 140 | value % value_type = TYPE_STRING 141 | value % value_string => parse_string(unit, str) 142 | case ("t") 143 | !true 144 | value % value_type = TYPE_LOGICAL 145 | call parse_for_chars(unit, str, "rue") 146 | value % value_logical = .true. 147 | case ("f") 148 | !false 149 | value % value_type = TYPE_LOGICAL 150 | value % value_logical = .false. 151 | call parse_for_chars(unit, str, "alse") 152 | case ("n", "N") 153 | value % value_type = TYPE_NULL 154 | call parse_for_chars(unit, str, "ull") 155 | case("-", "0": "9") 156 | call push_char(c) 157 | call parse_number(unit, str, value) 158 | case default 159 | print *, "ERROR: Unexpected character while parsing value. '", c, "' ASCII=", iachar(c) 160 | call exit (1) 161 | end select 162 | end if 163 | 164 | end subroutine parse_value 165 | 166 | ! 167 | ! PARSE OBJECT 168 | ! 169 | recursive subroutine parse_object(unit, str, parent) 170 | integer, intent(inout) :: unit 171 | character(*), intent(inout) :: str 172 | type(fson_value), pointer :: parent, pair 173 | 174 | 175 | logical :: eof 176 | character :: c 177 | 178 | ! pair name 179 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 180 | if (eof) then 181 | print *, "ERROR: Unexpected end of file while parsing start of object." 182 | call exit (1) 183 | else if ("}" == c) then 184 | ! end of an empty object 185 | return 186 | else if ('"' == c) then 187 | pair => fson_value_create() 188 | pair % name => parse_string(unit, str) 189 | else 190 | print *, "ERROR: Expecting string: '", c, "'" 191 | call exit (1) 192 | end if 193 | 194 | ! pair value 195 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 196 | if (eof) then 197 | print *, "ERROR: Unexpected end of file while parsing object member. 1" 198 | call exit (1) 199 | else if (":" == c) then 200 | ! parse the value 201 | call parse_value(unit, str, pair) 202 | call fson_value_add(parent, pair) 203 | else 204 | print *, "ERROR: Expecting : and then a value. ", c 205 | call exit (1) 206 | end if 207 | 208 | ! another possible pair 209 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 210 | if (eof) then 211 | return 212 | else if ("," == c) then 213 | ! read the next member 214 | call parse_object(unit = unit, str=str, parent = parent) 215 | else if ("}" == c) then 216 | return 217 | else 218 | print *, "ERROR: Expecting end of object.", c 219 | call exit (1) 220 | end if 221 | 222 | end subroutine parse_object 223 | 224 | ! 225 | ! PARSE ARRAY 226 | ! 227 | recursive subroutine parse_array(unit, str, array) 228 | 229 | implicit none 230 | integer, intent(inout) :: unit 231 | character(*), intent(inout) :: str 232 | type(fson_value), pointer :: array, element 233 | 234 | logical :: eof, finished 235 | character :: c 236 | 237 | finished = .false. 238 | do while (.not. finished) 239 | 240 | ! try to parse an element value 241 | element => fson_value_create() 242 | call parse_value(unit, str, element) 243 | 244 | ! parse value will disassociate an empty array value 245 | if (associated(element)) then 246 | call fson_value_add(array, element) 247 | end if 248 | 249 | ! pop the next character 250 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 251 | 252 | if (eof) then 253 | finished = .true. 254 | else if ("]" == c) then 255 | ! end of array 256 | finished = .true. 257 | end if 258 | 259 | end do 260 | 261 | end subroutine parse_array 262 | 263 | ! 264 | ! PARSE STRING 265 | ! 266 | function parse_string(unit, str) result(string) 267 | integer, intent(inout) :: unit 268 | character(*), intent(inout) :: str 269 | type(fson_string), pointer :: string 270 | 271 | logical :: eof, escape 272 | character :: c 273 | 274 | string => fson_string_create() 275 | escape = .false. 276 | 277 | do 278 | c = pop_char(unit, str, eof = eof, skip_ws = .false.) 279 | if (eof) then 280 | print *, "Expecting end of string" 281 | call exit(1) 282 | else if (escape) then 283 | select case(c) 284 | case('u', 'U', 'x') 285 | call fson_string_append(string,char(0)) 286 | call fson_string_append(string,c) 287 | case('n') 288 | call fson_string_append(string,'\n') 289 | case('b') 290 | call fson_string_append(string,'\b') 291 | case('f') 292 | call fson_string_append(string,'\f') 293 | case('r') 294 | call fson_string_append(string,'\r') 295 | case('t') 296 | call fson_string_append(string,'\t') 297 | case default 298 | call fson_string_append(string,c) 299 | end select 300 | escape = .false. 301 | else 302 | if (c == '\') then 303 | escape = .true. 304 | else if (c == '"') then 305 | exit 306 | else 307 | call fson_string_append(string,c) 308 | end if 309 | end if 310 | end do 311 | end function parse_string 312 | 313 | ! 314 | ! PARSE FOR CHARACTERS 315 | ! 316 | subroutine parse_for_chars(unit, str, chars) 317 | integer, intent(in) :: unit 318 | character(*), intent(inout) :: str 319 | character(len = *), intent(in) :: chars 320 | integer :: i, length 321 | logical :: eof 322 | character :: c 323 | 324 | length = len_trim(chars) 325 | 326 | do i = 1, length 327 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 328 | if (eof) then 329 | print *, "ERROR: Unexpected end of file while parsing array." 330 | call exit (1) 331 | else if (c .ne. chars(i:i)) then 332 | print *, "ERROR: Unexpected character.'", c,"'", chars(i:i) 333 | call exit (1) 334 | end if 335 | end do 336 | 337 | end subroutine parse_for_chars 338 | 339 | ! 340 | ! PARSE NUMBER 341 | ! 342 | subroutine parse_number(unit, str, value) 343 | integer, intent(inout) :: unit 344 | character(*), intent(inout) :: str 345 | type(fson_value), pointer :: value 346 | logical :: eof, negative, decimal, scientific 347 | character :: c 348 | integer :: exp, digit_count 349 | integer(kind=8) :: integral 350 | double precision :: frac 351 | 352 | 353 | ! first character is either - or a digit 354 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 355 | if (eof) then 356 | print *, "ERROR: Unexpected end of file while parsing number." 357 | call exit (1) 358 | else if ("-" == c) then 359 | negative = .true. 360 | else 361 | negative = .false. 362 | call push_char(c) 363 | end if 364 | 365 | 366 | ! parse the integral 367 | integral = parse_integer(unit, str) 368 | 369 | decimal = .false. 370 | scientific = .false. 371 | exp = 0 372 | frac = 0.0d0 373 | 374 | do 375 | ! first character is either - or a digit 376 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 377 | if (eof) then 378 | print *, "ERROR: Unexpected end of file while parsing number." 379 | call exit (1) 380 | else 381 | select case (c) 382 | case (".") 383 | ! this is already fractional number 384 | if (decimal) then 385 | ! already found a decimal place 386 | print *, "ERROR: Unexpected second decimal place while parsing number." 387 | call exit(1) 388 | end if 389 | decimal = .true. 390 | frac = parse_integer(unit, str, digit_count, allow_truncate = .true.) 391 | frac = frac / (10.0d0 ** digit_count) 392 | case ("e", "E") 393 | ! this is already an exponent number 394 | if (scientific) then 395 | ! already found a e place 396 | print *, "ERROR: Unexpected second exponent while parsing number." 397 | call exit(1) 398 | end if 399 | scientific = .true. 400 | decimal = .true. 401 | ! this number has an exponent 402 | exp = int(parse_integer(unit, str), kind = 4) 403 | case default 404 | if (decimal) then 405 | ! add the integral 406 | frac = frac + integral 407 | if (scientific) then 408 | ! apply exponent 409 | frac = frac * (10.0d0 ** exp) 410 | end if 411 | ! apply negative 412 | if (negative) then 413 | frac = -frac 414 | end if 415 | value % value_type = TYPE_REAL 416 | value % value_real = real(frac) 417 | value % value_double = frac 418 | else 419 | if (negative) then 420 | ! apply negative 421 | integral = -integral 422 | end if 423 | value % value_type = TYPE_INTEGER 424 | value % value_integer = int(integral, kind = 4) 425 | value % value_long_integer = integral 426 | end if 427 | call push_char(c) 428 | exit 429 | end select 430 | end if 431 | end do 432 | 433 | end subroutine 434 | 435 | ! 436 | ! PARSE INTEGER 437 | ! 438 | integer(kind=8) function parse_integer(unit, str, digit_count, allow_truncate) & 439 | result(integral) 440 | integer, intent(in) :: unit 441 | character(*), intent(inout) :: str 442 | integer, optional, intent(out) :: digit_count 443 | logical, optional, intent(in) :: allow_truncate 444 | logical :: eof, found_sign, found_digit 445 | character :: c 446 | integer :: tmp, icount, isign 447 | logical :: do_truncate, truncating 448 | integer, parameter :: max_integer_length = 18 449 | 450 | if (present(allow_truncate)) then 451 | do_truncate = allow_truncate 452 | else 453 | do_truncate = .false. 454 | end if 455 | 456 | icount = 0 457 | integral = 0 458 | isign = 1 459 | found_sign = .false. 460 | found_digit = .false. 461 | truncating = .false. 462 | do 463 | c = pop_char(unit, str, eof = eof, skip_ws = .true.) 464 | if (eof) then 465 | print *, "ERROR: Unexpected end of file while parsing digit." 466 | call exit (1) 467 | else 468 | select case(c) 469 | case ("+") 470 | if (found_sign.or.found_digit) then 471 | print *, "ERROR: Misformatted number." 472 | call exit(1) 473 | end if 474 | found_sign = .true. 475 | case ("-") 476 | if (found_sign.or.found_digit) then 477 | print *, "ERROR: Misformatted number." 478 | call exit(1) 479 | end if 480 | found_sign = .true. 481 | isign = -1 482 | case ("0":"9") 483 | found_sign = .true. 484 | if ((icount > max_integer_length) .and. (.not. truncating)) then 485 | if (do_truncate) then 486 | truncating = .true. 487 | else 488 | print *, "ERROR: Too many digits for an integer." 489 | call exit(1) 490 | end if 491 | end if 492 | ! digit 493 | read (c, '(i1)') tmp 494 | ! shift 495 | if (.not. truncating) then 496 | if (icount > 0) then 497 | integral = integral * 10 498 | end if 499 | ! add 500 | integral = integral + tmp 501 | ! increase the icount 502 | icount = icount + 1 503 | end if 504 | 505 | case default 506 | if (present(digit_count)) then 507 | digit_count = icount 508 | end if 509 | call push_char(c) 510 | integral = isign * integral 511 | return 512 | end select 513 | end if 514 | end do 515 | 516 | end function parse_integer 517 | 518 | ! 519 | ! POP CHAR 520 | ! 521 | recursive character function pop_char(unit, str, eof, skip_ws) result(popped) 522 | integer, intent(in) :: unit 523 | character(*), intent(inout) :: str 524 | logical, intent(out) :: eof 525 | logical, intent(in), optional :: skip_ws 526 | 527 | integer :: ios 528 | character :: c 529 | logical :: ignore 530 | 531 | eof = .false. 532 | if (.not.present(skip_ws)) then 533 | ignore = .false. 534 | else 535 | ignore = skip_ws 536 | end if 537 | 538 | do 539 | if (pushed_index > 0) then 540 | ! there is a character pushed back on, most likely from the number parsing 541 | c = pushed_char(pushed_index:pushed_index) 542 | pushed_index = pushed_index - 1 543 | ios = 0 544 | else 545 | if (unit .gt. 0) then 546 | read (unit = unit, fmt = "(a)", advance = "no", iostat = ios) c 547 | else 548 | read (unit = str, fmt = "(a)", iostat = ios) c 549 | str = str(2:) 550 | endif 551 | end if 552 | if (ios == end_of_record) then 553 | cycle 554 | else if (ios == end_of_file) then 555 | eof = .true. 556 | exit 557 | else if (iachar(c) <= 31) then 558 | ! non printing ascii characters 559 | cycle 560 | else if (ignore .and. c == " ") then 561 | cycle 562 | else 563 | popped = c 564 | exit 565 | end if 566 | end do 567 | 568 | end function pop_char 569 | 570 | ! 571 | ! PUSH CHAR 572 | ! 573 | subroutine push_char(c) 574 | character, intent(inout) :: c 575 | pushed_index = pushed_index + 1 576 | pushed_char(pushed_index:pushed_index) = c 577 | 578 | end subroutine push_char 579 | 580 | end module fson 581 | -------------------------------------------------------------------------------- /src/fson_path_m.f90: -------------------------------------------------------------------------------- 1 | ! Copyright (c) 2012 Joseph A. Levin 2 | ! 3 | ! Permission is hereby granted, free of charge, to any person obtaining a copy of this 4 | ! software and associated documentation files (the "Software"), to deal in the Software 5 | ! without restriction, including without limitation the rights to use, copy, modify, merge, 6 | ! publish, distribute, sublicense, and/or sell copies of the Software, and to permit 7 | ! persons to whom the Software is furnished to do so, subject to the following conditions: 8 | ! 9 | ! The above copyright notice and this permission notice shall be included in all copies or 10 | ! substantial portions of the Software. 11 | ! 12 | ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, 13 | ! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 14 | ! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 15 | ! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT 16 | ! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 17 | ! DEALINGS IN THE SOFTWARE. 18 | 19 | ! 20 | ! File: fson_path_m.f95 21 | ! Author: Joseph A. Levin 22 | ! 23 | ! Created on March 10, 2012, 11:01 PM 24 | ! 25 | 26 | module fson_path_m 27 | 28 | use fson_value_m 29 | use fson_string_m 30 | 31 | private 32 | 33 | public :: fson_path_get, fson_path_check 34 | 35 | interface fson_path_get 36 | module procedure get_by_path 37 | module procedure get_integer 38 | module procedure get_long_integer 39 | module procedure get_real 40 | module procedure get_double 41 | module procedure get_logical 42 | module procedure get_chars 43 | module procedure get_array_1d_integer 44 | module procedure get_array_2d_integer 45 | module procedure get_array_1d_real 46 | module procedure get_array_2d_real 47 | module procedure get_array_1d_double 48 | module procedure get_array_2d_double 49 | module procedure get_array_1d_logical 50 | module procedure get_array_2d_logical 51 | module procedure get_array_1d_char 52 | module procedure get_array_2d_char 53 | end interface fson_path_get 54 | 55 | interface fson_path_check 56 | module procedure check_path 57 | end interface fson_path_check 58 | 59 | abstract interface 60 | 61 | subroutine array_callback_1d(element, i, count) 62 | use fson_value_m 63 | implicit none 64 | type(fson_value), pointer,intent(in) :: element 65 | integer, intent(in) :: i ! index 66 | integer, intent(in) :: count ! size of array 67 | end subroutine array_callback_1d 68 | 69 | subroutine array_callback_2d(element, i1, i2, count1, count2) 70 | use fson_value_m 71 | implicit none 72 | type(fson_value), pointer,intent(in) :: element 73 | integer, intent(in) :: i1, i2 74 | integer, intent(in) :: count1, count2 75 | end subroutine array_callback_2d 76 | 77 | end interface 78 | 79 | contains 80 | ! 81 | ! GET BY PATH 82 | ! 83 | ! $ = root 84 | ! @ = this 85 | ! . = child object member 86 | ! [] = child array element 87 | ! 88 | recursive subroutine get_by_path(this, path, p) 89 | type(fson_value), pointer :: this, p 90 | character(len=*) :: path 91 | integer :: i, length, child_i 92 | character :: c 93 | logical :: array 94 | 95 | ! default to assuming relative to this 96 | p => this 97 | 98 | child_i = 1 99 | 100 | array = .false. 101 | 102 | length = len_trim(path) 103 | 104 | do i=1, length 105 | c = path(i:i) 106 | select case (c) 107 | case ("$") 108 | ! root 109 | do while (associated (p % parent)) 110 | p => p % parent 111 | end do 112 | child_i = i + 1 113 | case ("@") 114 | ! this 115 | p => this 116 | child_i = i + 1 117 | case (".", "[") 118 | ! get child member from p 119 | if (child_i < i) then 120 | p => fson_value_get(p, path(child_i:i-1)) 121 | else 122 | child_i = i + 1 123 | cycle 124 | end if 125 | 126 | if(.not.associated(p)) then 127 | return 128 | end if 129 | 130 | child_i = i+1 131 | 132 | ! check if this is an array 133 | ! if so set the array flag 134 | if (c == "[") then 135 | ! start looking for the array element index 136 | array = .true. 137 | end if 138 | case ("]") 139 | if (.not.array) then 140 | print *, "ERROR: Unexpected ], not missing preceding [" 141 | call exit(1) 142 | end if 143 | array = .false. 144 | child_i = parse_integer(path(child_i:i-1)) 145 | p => fson_value_get(p, child_i) 146 | 147 | child_i= i + 1 148 | end select 149 | end do 150 | 151 | ! grab the last child if present in the path 152 | if (child_i <= length) then 153 | p => fson_value_get(p, path(child_i:length)) 154 | if(.not.associated(p)) then 155 | return 156 | else 157 | end if 158 | end if 159 | 160 | 161 | end subroutine get_by_path 162 | 163 | logical function check_path(this, path) result(exist) 164 | type(fson_value), pointer :: this, p 165 | character(len=*), optional :: path 166 | exist = .TRUE. 167 | 168 | nullify(p) 169 | if(present(path)) then 170 | call get_by_path(this=this, path=path, p=p) 171 | else 172 | p => this 173 | end if 174 | 175 | if(.not.associated(p)) then 176 | exist = .FALSE. 177 | end if 178 | end function check_path 179 | 180 | ! 181 | ! PARSE INTEGER 182 | ! 183 | integer function parse_integer(chars) result(integral) 184 | character(len=*) :: chars 185 | character :: c 186 | integer :: tmp, i 187 | 188 | integral = 0 189 | do i=1, len_trim(chars) 190 | c = chars(i:i) 191 | select case(c) 192 | case ("0":"9") 193 | ! digit 194 | read (c, '(i1)') tmp 195 | 196 | ! shift 197 | if(i > 1) then 198 | integral = integral * 10 199 | end if 200 | ! add 201 | integral = integral + tmp 202 | 203 | case default 204 | return 205 | end select 206 | end do 207 | 208 | end function parse_integer 209 | 210 | ! 211 | ! GET INTEGER 212 | ! 213 | subroutine get_integer(this, path, value) 214 | type(fson_value), pointer :: this, p 215 | character(len=*), optional :: path 216 | integer :: value 217 | 218 | 219 | nullify(p) 220 | if(present(path)) then 221 | call get_by_path(this=this, path=path, p=p) 222 | else 223 | p => this 224 | end if 225 | 226 | if(.not.associated(p)) then 227 | print *, "Unable to resolve path: ", path 228 | call exit(1) 229 | end if 230 | 231 | 232 | if(p % value_type == TYPE_INTEGER) then 233 | value = p % value_integer 234 | else if (p % value_type == TYPE_REAL) then 235 | value = int(p % value_real) 236 | else if (p % value_type == TYPE_LOGICAL) then 237 | if (p % value_logical) then 238 | value = 1 239 | else 240 | value = 0 241 | end if 242 | else 243 | print *, "Unable to resolve value to integer: ", path 244 | call exit(1) 245 | end if 246 | 247 | end subroutine get_integer 248 | 249 | ! 250 | ! GET LONG INTEGER 251 | ! 252 | subroutine get_long_integer(this, path, value) 253 | type(fson_value), pointer :: this, p 254 | character(len=*), optional :: path 255 | integer(kind = 8) :: value 256 | 257 | nullify(p) 258 | if(present(path)) then 259 | call get_by_path(this=this, path=path, p=p) 260 | else 261 | p => this 262 | end if 263 | 264 | if(.not.associated(p)) then 265 | print *, "Unable to resolve path: ", path 266 | call exit(1) 267 | end if 268 | 269 | if(p % value_type == TYPE_INTEGER) then 270 | value = p % value_long_integer 271 | else if (p % value_type == TYPE_REAL) then 272 | value = int(p % value_real, kind = 8) 273 | else if (p % value_type == TYPE_LOGICAL) then 274 | if (p % value_logical) then 275 | value = 1 276 | else 277 | value = 0 278 | end if 279 | else 280 | print *, "Unable to resolve value to long integer: ", path 281 | call exit(1) 282 | end if 283 | 284 | end subroutine get_long_integer 285 | 286 | ! 287 | ! GET REAL 288 | ! 289 | subroutine get_real(this, path, value) 290 | type(fson_value), pointer :: this, p 291 | character(len=*), optional :: path 292 | real :: value 293 | 294 | 295 | nullify(p) 296 | 297 | if(present(path)) then 298 | call get_by_path(this=this, path=path, p=p) 299 | else 300 | p => this 301 | end if 302 | 303 | if(.not.associated(p)) then 304 | print *, "Unable to resolve path: ", path 305 | call exit(1) 306 | end if 307 | 308 | 309 | if(p % value_type == TYPE_INTEGER) then 310 | value = real(p % value_long_integer) 311 | else if (p % value_type == TYPE_REAL) then 312 | value = p % value_real 313 | else if (p % value_type == TYPE_LOGICAL) then 314 | if (p % value_logical) then 315 | value = 1 316 | else 317 | value = 0 318 | end if 319 | else 320 | print *, "Unable to resolve value to real: ", path 321 | call exit(1) 322 | end if 323 | 324 | end subroutine get_real 325 | 326 | ! 327 | ! GET DOUBLE 328 | ! 329 | subroutine get_double(this, path, value) 330 | type(fson_value), pointer :: this, p 331 | character(len=*), optional :: path 332 | double precision :: value 333 | 334 | 335 | nullify(p) 336 | 337 | if(present(path)) then 338 | call get_by_path(this=this, path=path, p=p) 339 | else 340 | p => this 341 | end if 342 | 343 | if(.not.associated(p)) then 344 | print *, "Unable to resolve path: ", path 345 | call exit(1) 346 | end if 347 | 348 | 349 | if(p % value_type == TYPE_INTEGER) then 350 | value = p % value_long_integer 351 | else if (p % value_type == TYPE_REAL) then 352 | value = p % value_double 353 | else if (p % value_type == TYPE_LOGICAL) then 354 | if (p % value_logical) then 355 | value = 1 356 | else 357 | value = 0 358 | end if 359 | else 360 | print *, "Unable to resolve value to double: ", path 361 | call exit(1) 362 | end if 363 | 364 | end subroutine get_double 365 | 366 | 367 | ! 368 | ! GET LOGICAL 369 | ! 370 | subroutine get_logical(this, path, value) 371 | type(fson_value), pointer :: this, p 372 | character(len=*), optional :: path 373 | logical :: value 374 | 375 | 376 | nullify(p) 377 | 378 | if(present(path)) then 379 | call get_by_path(this=this, path=path, p=p) 380 | else 381 | p => this 382 | end if 383 | 384 | if(.not.associated(p)) then 385 | print *, "Unable to resolve path: ", path 386 | call exit(1) 387 | end if 388 | 389 | 390 | if(p % value_type == TYPE_INTEGER) then 391 | value = (p % value_long_integer > 0) 392 | else if (p % value_type == TYPE_LOGICAL) then 393 | value = p % value_logical 394 | else 395 | print *, "Unable to resolve value to real: ", path 396 | call exit(1) 397 | end if 398 | 399 | end subroutine get_logical 400 | 401 | ! 402 | ! GET CHARS 403 | ! 404 | subroutine get_chars(this, path, value) 405 | type(fson_value), pointer :: this, p 406 | character(len=*), optional :: path 407 | character(len=*) :: value 408 | 409 | nullify(p) 410 | 411 | if(present(path)) then 412 | call get_by_path(this=this, path=path, p=p) 413 | else 414 | p => this 415 | end if 416 | 417 | if(.not.associated(p)) then 418 | print *, "Unable to resolve path: ", path 419 | call exit(1) 420 | end if 421 | 422 | 423 | if(p % value_type == TYPE_STRING) then 424 | call fson_string_copy(p % value_string, value) 425 | else 426 | print *, "Unable to resolve value to characters: ", path 427 | call exit(1) 428 | end if 429 | 430 | end subroutine get_chars 431 | 432 | ! 433 | ! GET ARRAY 1D 434 | ! 435 | 436 | subroutine get_array_1d(this, path, array_callback) 437 | type(fson_value), pointer :: this 438 | character(len = *), optional :: path 439 | procedure(array_callback_1d) :: array_callback 440 | 441 | type(fson_value), pointer :: p, element 442 | integer :: index, count 443 | 444 | nullify(p) 445 | 446 | ! resolve the path to the value 447 | if(present(path)) then 448 | call get_by_path(this=this, path=path, p=p) 449 | else 450 | p => this 451 | end if 452 | 453 | if(.not.associated(p)) then 454 | print *, "Unable to resolve path: ", path 455 | call exit(1) 456 | end if 457 | 458 | if(p % value_type == TYPE_ARRAY) then 459 | count = fson_value_count(p) 460 | element => p % children 461 | do index = 1, count 462 | call array_callback(element, index, count) 463 | element => element % next 464 | end do 465 | else 466 | print *, "Resolved value is not an array. ", path 467 | call exit(1) 468 | end if 469 | 470 | if (associated(p)) nullify(p) 471 | 472 | end subroutine get_array_1d 473 | 474 | ! 475 | ! GET ARRAY INTEGER 1D 476 | ! 477 | subroutine get_array_1d_integer(this, path, arr) 478 | 479 | implicit none 480 | type(fson_value), pointer, intent(in) :: this 481 | character(len=*), intent(in), optional :: path 482 | integer, allocatable, intent(out) :: arr(:) 483 | 484 | if (allocated(arr)) deallocate(arr) 485 | call get_array_1d(this, path, array_callback_1d_integer) 486 | 487 | contains 488 | 489 | subroutine array_callback_1d_integer(element, i, count) 490 | implicit none 491 | type(fson_value), pointer, intent(in) :: element 492 | integer, intent(in) :: i, count 493 | if (.not. allocated(arr)) allocate(arr(count)) 494 | call fson_path_get(element, "", arr(i)) 495 | end subroutine array_callback_1d_integer 496 | 497 | end subroutine get_array_1d_integer 498 | 499 | ! 500 | ! GET ARRAY REAL 1D 501 | ! 502 | subroutine get_array_1d_real(this, path, arr) 503 | 504 | implicit none 505 | type(fson_value), pointer, intent(in) :: this 506 | character(len=*), intent(in), optional :: path 507 | real, allocatable, intent(out) :: arr(:) 508 | 509 | if (allocated(arr)) deallocate(arr) 510 | call get_array_1d(this, path, array_callback_1d_real) 511 | 512 | contains 513 | 514 | subroutine array_callback_1d_real(element, i, count) 515 | implicit none 516 | type(fson_value), pointer, intent(in) :: element 517 | integer, intent(in) :: i, count 518 | if (.not. allocated(arr)) allocate(arr(count)) 519 | call fson_path_get(element, "", arr(i)) 520 | end subroutine array_callback_1d_real 521 | 522 | end subroutine get_array_1d_real 523 | 524 | ! 525 | ! GET ARRAY DOUBLE 1D 526 | ! 527 | subroutine get_array_1d_double(this, path, arr) 528 | 529 | implicit none 530 | type(fson_value), pointer, intent(in) :: this 531 | character(len=*), intent(in), optional :: path 532 | double precision, allocatable, intent(out) :: arr(:) 533 | 534 | if (allocated(arr)) deallocate(arr) 535 | call get_array_1d(this, path, array_callback_1d_double) 536 | 537 | contains 538 | 539 | subroutine array_callback_1d_double(element, i, count) 540 | implicit none 541 | type(fson_value), pointer, intent(in) :: element 542 | integer, intent(in) :: i, count 543 | if (.not. allocated(arr)) allocate(arr(count)) 544 | call fson_path_get(element, "", arr(i)) 545 | end subroutine array_callback_1d_double 546 | 547 | end subroutine get_array_1d_double 548 | 549 | ! 550 | ! GET ARRAY LOGICAL 1D 551 | ! 552 | subroutine get_array_1d_logical(this, path, arr) 553 | 554 | implicit none 555 | type(fson_value), pointer, intent(in) :: this 556 | character(len=*), intent(in), optional :: path 557 | logical, allocatable, intent(out) :: arr(:) 558 | 559 | if (allocated(arr)) deallocate(arr) 560 | call get_array_1d(this, path, array_callback_1d_logical) 561 | 562 | contains 563 | 564 | subroutine array_callback_1d_logical(element, i, count) 565 | implicit none 566 | type(fson_value), pointer, intent(in) :: element 567 | integer, intent(in) :: i, count 568 | if (.not. allocated(arr)) allocate(arr(count)) 569 | call fson_path_get(element, "", arr(i)) 570 | end subroutine array_callback_1d_logical 571 | 572 | end subroutine get_array_1d_logical 573 | 574 | ! 575 | ! GET ARRAY CHAR 1D 576 | ! 577 | subroutine get_array_1d_char(this, path, arr) 578 | 579 | implicit none 580 | type(fson_value), pointer, intent(in) :: this 581 | character(len=*), intent(in), optional :: path 582 | character(len = *), allocatable, intent(out) :: arr(:) 583 | 584 | if (allocated(arr)) deallocate(arr) 585 | call get_array_1d(this, path, array_callback_1d_char) 586 | 587 | contains 588 | 589 | subroutine array_callback_1d_char(element, i, count) 590 | implicit none 591 | type(fson_value), pointer, intent(in) :: element 592 | integer, intent(in) :: i, count 593 | if (.not. allocated(arr)) allocate(arr(count)) 594 | call fson_path_get(element, "", arr(i)) 595 | end subroutine array_callback_1d_char 596 | 597 | end subroutine get_array_1d_char 598 | 599 | 600 | ! 601 | ! GET ARRAY 2D 602 | ! 603 | 604 | subroutine get_array_2d(this, path, array_callback) 605 | type(fson_value), pointer :: this 606 | character(len = *), optional :: path 607 | procedure(array_callback_2d) :: array_callback 608 | 609 | type(fson_value), pointer :: p, element, item 610 | integer :: i1, i2, count1, count2, c 611 | 612 | nullify(p) 613 | 614 | ! resolve the path to the value 615 | if(present(path)) then 616 | call get_by_path(this=this, path=path, p=p) 617 | else 618 | p => this 619 | end if 620 | 621 | if(.not.associated(p)) then 622 | print *, "Unable to resolve path: ", path 623 | call exit(1) 624 | end if 625 | 626 | if(p % value_type == TYPE_ARRAY) then 627 | count1 = fson_value_count(p) 628 | element => p % children 629 | do i1 = 1, count1 630 | if (element % value_type == TYPE_ARRAY) then 631 | c = fson_value_count(element) 632 | if (i1 == 1) then 633 | count2 = c 634 | else if (c /= count2) then 635 | print *, "Resolved value has the wrong number of elements. ", & 636 | &path, "[", i1, "]" 637 | call exit(1) 638 | end if 639 | item => element % children 640 | do i2 = 1, count2 641 | call array_callback(item, i1, i2, count1, count2) 642 | item => item % next 643 | end do 644 | element => element % next 645 | else 646 | print *, "Resolved value is not an array. ", path, "[", i1, "]" 647 | call exit(1) 648 | end if 649 | end do 650 | else 651 | print *, "Resolved value is not an array. ", path 652 | call exit(1) 653 | end if 654 | 655 | if (associated(p)) nullify(p) 656 | 657 | end subroutine get_array_2d 658 | 659 | ! 660 | ! GET ARRAY INTEGER 2D 661 | ! 662 | subroutine get_array_2d_integer(this, path, arr) 663 | 664 | implicit none 665 | type(fson_value), pointer, intent(in) :: this 666 | character(len=*), intent(in), optional :: path 667 | integer, allocatable, intent(out) :: arr(:, :) 668 | 669 | if (allocated(arr)) deallocate(arr) 670 | call get_array_2d(this, path, array_callback_2d_integer) 671 | 672 | contains 673 | 674 | subroutine array_callback_2d_integer(element, i1, i2, count1, count2) 675 | implicit none 676 | type(fson_value), pointer, intent(in) :: element 677 | integer, intent(in) :: i1, i2, count1, count2 678 | if (.not. allocated(arr)) allocate(arr(count1, count2)) 679 | call fson_path_get(element, "", arr(i1, i2)) 680 | end subroutine array_callback_2d_integer 681 | 682 | end subroutine get_array_2d_integer 683 | 684 | ! 685 | ! GET ARRAY REAL 2D 686 | ! 687 | subroutine get_array_2d_real(this, path, arr) 688 | 689 | implicit none 690 | type(fson_value), pointer, intent(in) :: this 691 | character(len=*), intent(in), optional :: path 692 | real, allocatable, intent(out) :: arr(:, :) 693 | 694 | if (allocated(arr)) deallocate(arr) 695 | call get_array_2d(this, path, array_callback_2d_real) 696 | 697 | contains 698 | 699 | subroutine array_callback_2d_real(element, i1, i2, count1, count2) 700 | implicit none 701 | type(fson_value), pointer, intent(in) :: element 702 | integer, intent(in) :: i1, i2, count1, count2 703 | if (.not. allocated(arr)) allocate(arr(count1, count2)) 704 | call fson_path_get(element, "", arr(i1, i2)) 705 | end subroutine array_callback_2d_real 706 | 707 | end subroutine get_array_2d_real 708 | 709 | ! 710 | ! GET ARRAY DOUBLE 2D 711 | ! 712 | subroutine get_array_2d_double(this, path, arr) 713 | 714 | implicit none 715 | type(fson_value), pointer, intent(in) :: this 716 | character(len=*), intent(in), optional :: path 717 | double precision, allocatable, intent(out) :: arr(:, :) 718 | 719 | if (allocated(arr)) deallocate(arr) 720 | call get_array_2d(this, path, array_callback_2d_double) 721 | 722 | contains 723 | 724 | subroutine array_callback_2d_double(element, i1, i2, count1, count2) 725 | implicit none 726 | type(fson_value), pointer, intent(in) :: element 727 | integer, intent(in) :: i1, i2, count1, count2 728 | if (.not. allocated(arr)) allocate(arr(count1, count2)) 729 | call fson_path_get(element, "", arr(i1, i2)) 730 | end subroutine array_callback_2d_double 731 | 732 | end subroutine get_array_2d_double 733 | 734 | ! 735 | ! GET ARRAY LOGICAL 2D 736 | ! 737 | subroutine get_array_2d_logical(this, path, arr) 738 | 739 | implicit none 740 | type(fson_value), pointer, intent(in) :: this 741 | character(len=*), intent(in), optional :: path 742 | logical, allocatable, intent(out) :: arr(:, :) 743 | 744 | if (allocated(arr)) deallocate(arr) 745 | call get_array_2d(this, path, array_callback_2d_logical) 746 | 747 | contains 748 | 749 | subroutine array_callback_2d_logical(element, i1, i2, count1, count2) 750 | implicit none 751 | type(fson_value), pointer, intent(in) :: element 752 | integer, intent(in) :: i1, i2, count1, count2 753 | if (.not. allocated(arr)) allocate(arr(count1, count2)) 754 | call fson_path_get(element, "", arr(i1, i2)) 755 | end subroutine array_callback_2d_logical 756 | 757 | end subroutine get_array_2d_logical 758 | 759 | ! 760 | ! GET ARRAY CHAR 2D 761 | ! 762 | subroutine get_array_2d_char(this, path, arr) 763 | 764 | implicit none 765 | type(fson_value), pointer, intent(in) :: this 766 | character(len=*), intent(in), optional :: path 767 | character(len = *), allocatable, intent(out) :: arr(:, :) 768 | 769 | if (allocated(arr)) deallocate(arr) 770 | call get_array_2d(this, path, array_callback_2d_char) 771 | 772 | contains 773 | 774 | subroutine array_callback_2d_char(element, i1, i2, count1, count2) 775 | implicit none 776 | type(fson_value), pointer, intent(in) :: element 777 | integer, intent(in) :: i1, i2, count1, count2 778 | if (.not. allocated(arr)) allocate(arr(count1, count2)) 779 | call fson_path_get(element, "", arr(i1, i2)) 780 | end subroutine array_callback_2d_char 781 | 782 | end subroutine get_array_2d_char 783 | 784 | end module fson_path_m 785 | -------------------------------------------------------------------------------- /src/fson_string_m.f90: -------------------------------------------------------------------------------- 1 | ! Copyright (c) 2012 Joseph A. Levin 2 | ! 3 | ! Permission is hereby granted, free of charge, to any person obtaining a copy of this 4 | ! software and associated documentation files (the "Software"), to deal in the Software 5 | ! without restriction, including without limitation the rights to use, copy, modify, merge, 6 | ! publish, distribute, sublicense, and/or sell copies of the Software, and to permit 7 | ! persons to whom the Software is furnished to do so, subject to the following conditions: 8 | ! 9 | ! The above copyright notice and this permission notice shall be included in all copies or 10 | ! substantial portions of the Software. 11 | ! 12 | ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, 13 | ! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 14 | ! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 15 | ! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT 16 | ! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 17 | ! DEALINGS IN THE SOFTWARE. 18 | 19 | ! 20 | ! File: string.f95 21 | ! Author: josephalevin 22 | ! 23 | ! Created on March 7, 2012, 7:40 PM 24 | ! 25 | 26 | module fson_string_m 27 | 28 | private 29 | 30 | public :: fson_string, fson_string_create, fson_string_destroy, fson_string_length, fson_string_append, fson_string_clear 31 | public :: fson_string_equals, fson_string_copy 32 | 33 | integer, parameter :: BLOCK_SIZE = 32 34 | 35 | type fson_string 36 | character (len = BLOCK_SIZE) :: chars 37 | integer :: index = 0 38 | type(fson_string), pointer :: next => null() 39 | end type fson_string 40 | 41 | interface fson_string_append 42 | module procedure append_chars, append_string 43 | end interface fson_string_append 44 | 45 | interface fson_string_copy 46 | module procedure copy_chars 47 | end interface fson_string_copy 48 | 49 | interface fson_string_equals 50 | module procedure equals_string 51 | end interface fson_string_equals 52 | 53 | interface fson_string_length 54 | module procedure string_length 55 | end interface fson_string_length 56 | 57 | contains 58 | 59 | ! 60 | ! FSON STRING CREATE 61 | ! 62 | function fson_string_create(chars) result(new) 63 | character(len=*), optional :: chars 64 | type(fson_string), pointer :: new 65 | 66 | nullify(new) 67 | allocate(new) 68 | 69 | ! append chars if available 70 | if(present(chars)) then 71 | call append_chars(new, chars) 72 | end if 73 | 74 | end function fson_string_create 75 | 76 | ! 77 | ! FSON STRING CREATE 78 | ! 79 | recursive subroutine fson_string_destroy(this) 80 | 81 | implicit none 82 | type(fson_string), pointer :: this 83 | 84 | if (associated(this)) then 85 | 86 | if(associated(this % next)) then 87 | call fson_string_destroy(this % next) 88 | end if 89 | 90 | deallocate(this) 91 | nullify (this) 92 | 93 | end if 94 | 95 | end subroutine fson_string_destroy 96 | 97 | ! 98 | ! ALLOCATE BLOCK 99 | ! 100 | subroutine allocate_block(this) 101 | 102 | implicit none 103 | type(fson_string), pointer :: this 104 | type(fson_string), pointer :: new 105 | 106 | if (.not.associated(this % next)) then 107 | nullify(new) 108 | allocate(new) 109 | this % next => new 110 | end if 111 | 112 | end subroutine allocate_block 113 | 114 | 115 | ! 116 | ! APPEND_STRING 117 | ! 118 | subroutine append_string(str1, str2) 119 | type(fson_string), pointer :: str1, str2 120 | integer length, i 121 | 122 | length = string_length(str2) 123 | 124 | do i = 1, length 125 | call append_char(str1, get_char_at(str2, i)) 126 | end do 127 | 128 | 129 | end subroutine append_string 130 | 131 | ! 132 | ! APPEND_CHARS 133 | ! 134 | subroutine append_chars(str, c) 135 | type(fson_string), pointer :: str 136 | character (len = *), intent(in) :: c 137 | integer length, i 138 | 139 | length = len(c) 140 | 141 | do i = 1, length 142 | call append_char(str, c(i:i)) 143 | end do 144 | 145 | 146 | end subroutine append_chars 147 | 148 | ! 149 | ! APPEND_CHAR 150 | ! 151 | recursive subroutine append_char(str, c) 152 | type(fson_string), pointer :: str 153 | character, intent(in) :: c 154 | 155 | if (str % index .GE. BLOCK_SIZE) then 156 | !set down the chain 157 | call allocate_block(str) 158 | call append_char(str % next, c) 159 | 160 | else 161 | ! set local 162 | str % index = str % index + 1 163 | str % chars(str % index:str % index) = c 164 | end if 165 | 166 | end subroutine append_char 167 | 168 | ! 169 | ! COPY CHARS 170 | ! 171 | subroutine copy_chars(this, to) 172 | type(fson_string), pointer :: this 173 | character(len = *), intent(inout) :: to 174 | integer :: length 175 | 176 | length = min(string_length(this), len(to)) 177 | 178 | do i = 1, length 179 | to(i:i) = get_char_at(this, i) 180 | end do 181 | 182 | ! pad with nothing 183 | do i = length + 1, len(to) 184 | to(i:i) = "" 185 | end do 186 | 187 | 188 | end subroutine copy_chars 189 | 190 | 191 | 192 | ! 193 | ! CLEAR 194 | ! 195 | recursive subroutine string_clear(this) 196 | type(fson_string), pointer :: this 197 | 198 | if (associated(this % next)) then 199 | call string_clear(this % next) 200 | deallocate(this % next) 201 | nullify (this % next) 202 | end if 203 | 204 | this % index = 0 205 | 206 | end subroutine string_clear 207 | 208 | ! 209 | ! SIZE 210 | ! 211 | recursive integer function string_length(str) result(count) 212 | type(fson_string), pointer :: str 213 | 214 | count = str % index 215 | 216 | if (str % index == BLOCK_SIZE .AND. associated(str % next)) then 217 | count = count + string_length(str % next) 218 | end if 219 | 220 | end function string_length 221 | 222 | 223 | ! 224 | ! GET CHAR AT 225 | ! 226 | recursive character function get_char_at(this, i) result(c) 227 | type(fson_string), pointer :: this 228 | integer, intent(in) :: i 229 | 230 | if (i .LE. this % index) then 231 | c = this % chars(i:i) 232 | else 233 | c = get_char_at(this % next, i - this % index) 234 | end if 235 | 236 | end function get_char_at 237 | 238 | ! 239 | ! EQUALS STRING 240 | ! 241 | logical function equals_string(this, other) result(equals) 242 | type(fson_string), pointer :: this, other 243 | integer :: i 244 | equals = .false. 245 | 246 | if(fson_string_length(this) .ne. fson_string_length(other)) then 247 | equals = .false. 248 | return 249 | else if(fson_string_length(this) == 0) then 250 | equals = .true. 251 | return 252 | end if 253 | 254 | do i=1, fson_string_length(this) 255 | if(get_char_at(this, i) .ne. get_char_at(other, i)) then 256 | equals = .false. 257 | return 258 | end if 259 | end do 260 | 261 | equals = .true. 262 | 263 | end function equals_string 264 | 265 | end module fson_string_m 266 | -------------------------------------------------------------------------------- /src/fson_value_m.f90: -------------------------------------------------------------------------------- 1 | ! Copyright (c) 2012 Joseph A. Levin 2 | ! 3 | ! Permission is hereby granted, free of charge, to any person obtaining a copy of this 4 | ! software and associated documentation files (the "Software"), to deal in the Software 5 | ! without restriction, including without limitation the rights to use, copy, modify, merge, 6 | ! publish, distribute, sublicense, and/or sell copies of the Software, and to permit 7 | ! persons to whom the Software is furnished to do so, subject to the following conditions: 8 | ! 9 | ! The above copyright notice and this permission notice shall be included in all copies or 10 | ! substantial portions of the Software. 11 | ! 12 | ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR IMPLIED, 13 | ! INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS FOR A PARTICULAR 14 | ! PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE 15 | ! LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT 16 | ! OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 17 | ! DEALINGS IN THE SOFTWARE. 18 | 19 | ! 20 | ! File: value_m.f95 21 | ! Author: josephalevin 22 | ! 23 | ! Created on March 7, 2012, 10:14 PM 24 | ! 25 | 26 | module fson_value_m 27 | 28 | use fson_string_m 29 | 30 | implicit none 31 | 32 | private 33 | 34 | public :: fson_value, fson_value_create, fson_value_destroy, fson_value_add, fson_value_get, fson_value_count, fson_value_print 35 | 36 | !constants for the value types 37 | integer, public, parameter :: TYPE_UNKNOWN = -1 38 | integer, public, parameter :: TYPE_NULL = 0 39 | integer, public, parameter :: TYPE_OBJECT = 1 40 | integer, public, parameter :: TYPE_ARRAY = 2 41 | integer, public, parameter :: TYPE_STRING = 3 42 | integer, public, parameter :: TYPE_INTEGER = 4 43 | integer, public, parameter :: TYPE_REAL = 5 44 | integer, public, parameter :: TYPE_LOGICAL = 6 45 | 46 | 47 | ! 48 | ! FSON VALUE 49 | ! 50 | type fson_value 51 | type(fson_string), pointer :: name => null() 52 | integer :: value_type = TYPE_UNKNOWN 53 | logical :: value_logical 54 | integer :: value_integer 55 | integer(kind = 8) :: value_long_integer 56 | real :: value_real 57 | double precision :: value_double 58 | integer, private :: count = 0 59 | type(fson_string), pointer :: value_string => null() 60 | type(fson_value), pointer :: next => null() 61 | type(fson_value), pointer :: parent => null() 62 | type(fson_value), pointer :: children => null() 63 | type(fson_value), pointer :: tail => null() 64 | end type fson_value 65 | 66 | ! 67 | ! FSON VALUE GET 68 | ! 69 | ! Use either a 1 based index or member name to get the value. 70 | interface fson_value_get 71 | module procedure get_by_index 72 | module procedure get_by_name_chars 73 | module procedure get_by_name_string 74 | end interface fson_value_get 75 | 76 | contains 77 | 78 | ! 79 | ! FSON VALUE CREATE 80 | ! 81 | function fson_value_create() result(new) 82 | type(fson_value), pointer :: new 83 | 84 | nullify(new) 85 | allocate(new) 86 | 87 | end function fson_value_create 88 | 89 | ! 90 | ! FSON VALUE DESTROY 91 | ! 92 | recursive subroutine fson_value_destroy(this, destroy_next) 93 | 94 | implicit none 95 | type(fson_value), pointer :: this 96 | logical, intent(in), optional :: destroy_next 97 | 98 | type(fson_value), pointer :: p 99 | logical :: donext 100 | 101 | if (present(destroy_next)) then 102 | donext = destroy_next 103 | else 104 | donext = .true. 105 | end if 106 | 107 | if (associated(this)) then 108 | 109 | if(associated(this % name)) then 110 | call fson_string_destroy(this % name) 111 | nullify (this % name) 112 | end if 113 | 114 | if(associated(this % value_string)) then 115 | call fson_string_destroy(this % value_string) 116 | nullify (this % value_string) 117 | end if 118 | 119 | if(associated(this % children)) then 120 | do while (this % count > 0) 121 | p => this % children 122 | this % children => this % children % next 123 | this % count = this % count - 1 124 | call fson_value_destroy(p, .false.) 125 | end do 126 | nullify(this % children) 127 | end if 128 | 129 | if ((associated(this % next)) .and. (donext)) then 130 | call fson_value_destroy(this % next) 131 | nullify (this % next) 132 | end if 133 | 134 | if(associated(this % tail)) then 135 | nullify (this % tail) 136 | end if 137 | 138 | deallocate(this) 139 | nullify(this) 140 | 141 | end if 142 | 143 | end subroutine fson_value_destroy 144 | 145 | ! 146 | ! FSON VALUE ADD 147 | ! 148 | ! Adds the member to the linked list 149 | 150 | subroutine fson_value_add(this, member) 151 | 152 | implicit none 153 | type(fson_value), pointer :: this, member 154 | 155 | ! associate the parent 156 | member % parent => this 157 | 158 | ! add to linked list 159 | if (associated(this % children)) then 160 | this % tail % next => member 161 | else 162 | this % children => member 163 | end if 164 | 165 | this % tail => member 166 | this % count = this % count + 1 167 | 168 | end subroutine fson_value_add 169 | 170 | ! 171 | ! FSON_VALUE_COUNT 172 | ! 173 | integer function fson_value_count(this) result(count) 174 | type(fson_value), pointer :: this 175 | 176 | count = this % count 177 | 178 | end function 179 | 180 | ! 181 | ! GET BY INDEX 182 | ! 183 | function get_by_index(this, index) result(p) 184 | type(fson_value), pointer :: this, p 185 | integer, intent(in) :: index 186 | integer :: i 187 | 188 | p => this % children 189 | 190 | do i = 1, index - 1 191 | p => p % next 192 | end do 193 | 194 | end function get_by_index 195 | 196 | ! 197 | ! GET BY NAME CHARS 198 | ! 199 | function get_by_name_chars(this, name) result(p) 200 | type(fson_value), pointer :: this, p 201 | character(len=*), intent(in) :: name 202 | 203 | type(fson_string), pointer :: string 204 | 205 | ! convert the char array into a string 206 | string => fson_string_create(name) 207 | 208 | p => get_by_name_string(this, string) 209 | 210 | call fson_string_destroy(string) 211 | 212 | end function get_by_name_chars 213 | 214 | ! 215 | ! GET BY NAME STRING 216 | ! 217 | function get_by_name_string(this, name) result(p) 218 | type(fson_value), pointer :: this, p 219 | type(fson_string), pointer :: name 220 | integer :: i, count 221 | 222 | if(this % value_type .ne. TYPE_OBJECT) then 223 | nullify(p) 224 | return 225 | end if 226 | 227 | count = fson_value_count(this) 228 | p => this%children 229 | do i = 1, count 230 | if (fson_string_equals(p%name, name)) then 231 | return 232 | end if 233 | p => p%next 234 | end do 235 | 236 | ! didn't find anything 237 | nullify(p) 238 | 239 | end function get_by_name_string 240 | 241 | ! 242 | ! FSON VALUE PRINT 243 | ! 244 | recursive subroutine fson_value_print(this, indent) 245 | type(fson_value), pointer :: this, element 246 | integer, optional, intent(in) :: indent 247 | character (len = 1024) :: tmp_chars 248 | integer :: tab, i, count, spaces 249 | 250 | if (present(indent)) then 251 | tab = indent 252 | else 253 | tab = 0 254 | end if 255 | 256 | spaces = tab * 2 257 | 258 | select case (this % value_type) 259 | case(TYPE_OBJECT) 260 | print *, repeat(" ", spaces), "{" 261 | count = fson_value_count(this) 262 | element => this%children 263 | do i = 1, count 264 | ! get the name 265 | call fson_string_copy(element % name, tmp_chars) 266 | ! print the name 267 | print *, repeat(" ", spaces), '"', trim(tmp_chars), '":' 268 | ! recursive print of the element 269 | call fson_value_print(element, tab + 1) 270 | ! print the separator if required 271 | if (i < count) then 272 | print *, repeat(" ", spaces), "," 273 | end if 274 | element => element%next 275 | end do 276 | 277 | print *, repeat(" ", spaces), "}" 278 | case (TYPE_ARRAY) 279 | print *, repeat(" ", spaces), "[" 280 | count = fson_value_count(this) 281 | element => this%children 282 | do i = 1, count 283 | ! recursive print of the element 284 | call fson_value_print(element, tab + 1) 285 | ! print the separator if required 286 | if (i < count) then 287 | print *, "," 288 | end if 289 | element => element%next 290 | end do 291 | print *, repeat(" ", spaces), "]" 292 | case (TYPE_NULL) 293 | print *, repeat(" ", spaces), "null" 294 | case (TYPE_STRING) 295 | call fson_string_copy(this % value_string, tmp_chars) 296 | print *, repeat(" ", spaces), '"', trim(tmp_chars), '"' 297 | case (TYPE_LOGICAL) 298 | if (this % value_logical) then 299 | print *, repeat(" ", spaces), "true" 300 | else 301 | print *, repeat(" ", spaces), "false" 302 | end if 303 | case (TYPE_INTEGER) 304 | print *, repeat(" ", spaces), this % value_long_integer 305 | case (TYPE_REAL) 306 | print *, repeat(" ", spaces), this % value_double 307 | end select 308 | end subroutine fson_value_print 309 | 310 | 311 | end module fson_value_m 312 | -------------------------------------------------------------------------------- /src/hash.f90: -------------------------------------------------------------------------------- 1 | !> Module for SHA-256 hashing in fortran. 2 | !! 3 | !! @author Mikael Leetmaa 4 | !! @data 05 Jan 2014 5 | !! 6 | module hash 7 | use iso_c_binding 8 | 9 | ! Never use implicit declarations. 10 | implicit none 11 | 12 | ! Keep private what we can. 13 | private 14 | 15 | ! Defines the public interface. 16 | public sha256sum 17 | public dirty_sha256 18 | 19 | ! Public for the sake of unit-testing. 20 | public sha256b 21 | public ms0 22 | public ms1 23 | public cs0 24 | public cs1 25 | public maj 26 | public ch 27 | public swap32 28 | public swap64 29 | public swap64a 30 | public consume_chunk 31 | 32 | contains 33 | 34 | !> SHA-256 interface function. 35 | !! @param str : (in) The message to digest. 36 | !! @return : The SHA-256 digest as a string of length 64. 37 | function sha256sum(str) 38 | implicit none 39 | ! ----------------------------------- 40 | ! Define the interface. 41 | character(len=64) :: sha256sum 42 | character(len=*), intent(in) :: str 43 | ! ----------------------------------- 44 | ! Call the work horse with proper bit swapping. 45 | sha256sum = sha256b(str, 1) 46 | end function sha256sum 47 | 48 | !> Quick and dirty SHA-256 interface function (no bit-swapping). 49 | !! @param str : (in) The message to digest. 50 | !! @return : The SHA-256 digest as a string of length 64. 51 | function dirty_sha256(str) 52 | implicit none 53 | ! ----------------------------------- 54 | ! Define the interface. 55 | character(len=64) :: dirty_sha256 56 | character(len=*), intent(in) :: str 57 | ! ----------------------------------- 58 | ! Call the work horse - no bit swapping. 59 | dirty_sha256 = sha256b(str, 0) 60 | end function dirty_sha256 61 | 62 | !> Calculate the SHA-256 hash of the incomming string. 63 | !! @param str : (in) The message to take digest. 64 | !! @param swap : (in) Flag to indicate if swapping to big-endian 65 | !! input (swap=1) should be used. swap=1 is needed 66 | !! for the routine to pass the standard tests, but 67 | !! decreases speed with a factor 2. 68 | !! @return : The SHA-256 digest as a string of length 64. 69 | function sha256b(str, swap) 70 | implicit none 71 | ! ----------------------------------- 72 | ! Define the interface. 73 | character(len=64) :: sha256b 74 | character(len=*), intent(in) :: str 75 | integer, intent(in) :: swap 76 | ! ----------------------------------- 77 | 78 | ! Helper variables. 79 | integer(kind=c_int64_t) :: length 80 | integer(kind=c_int32_t) :: temp1 81 | integer(kind=c_int32_t) :: temp2 82 | integer(kind=c_int32_t) :: i 83 | integer :: break 84 | integer :: pos0 85 | 86 | ! Parameters for the cruncher. 87 | integer(kind=c_int32_t) :: h0_ref(8) 88 | integer(kind=c_int32_t) :: k0_ref(64) 89 | 90 | ! Work areas. 91 | integer(kind=c_int32_t) :: h0(8) 92 | integer(kind=c_int32_t) :: k0(64) 93 | integer(kind=c_int32_t) :: a0(8) 94 | integer(kind=c_int32_t) :: w0(64) 95 | 96 | ! Set the initial data. 97 | data (h0_ref(i),i=1,8)/& 98 | & z'6a09e667', z'bb67ae85', z'3c6ef372', z'a54ff53a', z'510e527f', z'9b05688c', z'1f83d9ab', z'5be0cd19'/ 99 | 100 | data (k0_ref(i), i=1,64)/& 101 | & z'428a2f98', z'71374491', z'b5c0fbcf', z'e9b5dba5', z'3956c25b', z'59f111f1', z'923f82a4', z'ab1c5ed5',& 102 | & z'd807aa98', z'12835b01', z'243185be', z'550c7dc3', z'72be5d74', z'80deb1fe', z'9bdc06a7', z'c19bf174',& 103 | & z'e49b69c1', z'efbe4786', z'0fc19dc6', z'240ca1cc', z'2de92c6f', z'4a7484aa', z'5cb0a9dc', z'76f988da',& 104 | & z'983e5152', z'a831c66d', z'b00327c8', z'bf597fc7', z'c6e00bf3', z'd5a79147', z'06ca6351', z'14292967',& 105 | & z'27b70a85', z'2e1b2138', z'4d2c6dfc', z'53380d13', z'650a7354', z'766a0abb', z'81c2c92e', z'92722c85',& 106 | & z'a2bfe8a1', z'a81a664b', z'c24b8b70', z'c76c51a3', z'd192e819', z'd6990624', z'f40e3585', z'106aa070',& 107 | & z'19a4c116', z'1e376c08', z'2748774c', z'34b0bcb5', z'391c0cb3', z'4ed8aa4a', z'5b9cca4f', z'682e6ff3',& 108 | & z'748f82ee', z'78a5636f', z'84c87814', z'8cc70208', z'90befffa', z'a4506ceb', z'bef9a3f7', z'c67178f2'/ 109 | 110 | h0 = h0_ref 111 | k0 = k0_ref 112 | ! ----------------------------------- 113 | ! Function body implementation. 114 | 115 | break = 0 116 | pos0 = 1 117 | length = len(trim(str)) 118 | 119 | do while (break .ne. 1) 120 | 121 | ! Get the next 16 32bit words to consume. 122 | call consume_chunk(str, length, w0(1:16), pos0, break, swap) 123 | 124 | ! Extend the first 16 words to fill the work schedule array. 125 | do i=17,64 126 | w0(i) = ms1(w0(i-2)) + w0(i-16) + ms0(w0(i-15)) + w0(i-7) 127 | end do 128 | 129 | ! Initialize the workin variables with the current version of the hash. 130 | a0 = h0 131 | 132 | ! Run the compression loop. 133 | do i=1,64 134 | 135 | temp1 = a0(8) + cs1(a0(5)) + ch(a0(5),a0(6),a0(7)) + k0(i) + w0(i) 136 | temp2 = cs0(a0(1)) + maj(a0(1),a0(2),a0(3)) 137 | 138 | a0(8) = a0(7) 139 | a0(7) = a0(6) 140 | a0(6) = a0(5) 141 | a0(5) = a0(4) + temp1 142 | a0(4) = a0(3) 143 | a0(3) = a0(2) 144 | a0(2) = a0(1) 145 | a0(1) = temp1 + temp2 146 | 147 | end do 148 | 149 | ! Update the state. 150 | h0 = h0 + a0 151 | 152 | end do 153 | 154 | ! Write the result to the output variable. 155 | write(sha256b,'(8z8.8)') h0(1), h0(2), h0(3), h0(4), h0(5), h0(6), h0(7), h0(8) 156 | 157 | end function sha256b 158 | 159 | !> Swap the byte order on a 32bit integer. 160 | !! @param inp : (in) The integer to byte swap. 161 | !! @return : The byte swapped integer. 162 | function swap32(inp) 163 | implicit none 164 | ! ----------------------------------- 165 | ! Define the interface. 166 | integer(kind=c_int32_t) :: swap32 167 | integer(kind=c_int32_t), intent(in) :: inp 168 | ! ----------------------------------- 169 | call mvbits(inp, 24, 8, swap32, 0) 170 | call mvbits(inp, 16, 8, swap32, 8) 171 | call mvbits(inp, 8, 8, swap32, 16) 172 | call mvbits(inp, 0, 8, swap32, 24) 173 | end function swap32 174 | 175 | !> Swap the byte order on a 64 bit integer. 176 | !! @param inp : (in) The integer to byte swap. 177 | !! @return : The byte swapped integer. 178 | function swap64(inp) 179 | implicit none 180 | ! ----------------------------------- 181 | ! Define the interface. 182 | integer(kind=c_int64_t) :: swap64 183 | integer(kind=c_int64_t), intent(in) :: inp 184 | ! ----------------------------------- 185 | call mvbits(inp, 56, 8, swap64, 0) 186 | call mvbits(inp, 48, 8, swap64, 8) 187 | call mvbits(inp, 40, 8, swap64, 16) 188 | call mvbits(inp, 32, 8, swap64, 24) 189 | call mvbits(inp, 24, 8, swap64, 32) 190 | call mvbits(inp, 16, 8, swap64, 40) 191 | call mvbits(inp, 8, 8, swap64, 48) 192 | call mvbits(inp, 0, 8, swap64, 56) 193 | end function swap64 194 | 195 | !> Swap the byte order on a 64bit integer as if 196 | !! each half was a 32bit integer to swap. 197 | !! @param inp : (in) The integer to byte swap. 198 | !! @return : The byte swapped integer. 199 | function swap64a(inp) 200 | implicit none 201 | ! ----------------------------------- 202 | ! Define the interface. 203 | integer(kind=c_int64_t) :: swap64a 204 | integer(kind=c_int64_t), intent(in) :: inp 205 | ! ----------------------------------- 206 | call mvbits(inp, 0, 8, swap64a, 32) 207 | call mvbits(inp, 8, 8, swap64a, 40) 208 | call mvbits(inp, 16, 8, swap64a, 48) 209 | call mvbits(inp, 24, 8, swap64a, 56) 210 | call mvbits(inp, 32, 8, swap64a, 0) 211 | call mvbits(inp, 40, 8, swap64a, 8) 212 | call mvbits(inp, 48, 8, swap64a, 16) 213 | call mvbits(inp, 56, 8, swap64a, 24) 214 | end function swap64a 215 | 216 | !> The 'ch' function in SHA-2. 217 | !! @param a : (in) The a input integer. 218 | !! @param b : (in) The b input integer. 219 | !! @param c : (in) The c input integer. 220 | !! @return : ch(a,b,c), see the code. 221 | function ch(a, b, c) 222 | ! ----------------------------------- 223 | ! Define the interface. 224 | integer(kind=c_int32_t) :: ch 225 | integer(kind=c_int32_t), intent(in) :: a 226 | integer(kind=c_int32_t), intent(in) :: b 227 | integer(kind=c_int32_t), intent(in) :: c 228 | ! ----------------------------------- 229 | ch = ieor(iand(a, b), (iand(not(a), c))) 230 | end function ch 231 | 232 | !> The 'maj' function in SHA-2. 233 | !! @param a : (in) The a input integer. 234 | !! @param b : (in) The b input integer. 235 | !! @param c : (in) The c input integer. 236 | !! @return : maj(a,b,c), see the code. 237 | function maj(a, b, c) 238 | ! ----------------------------------- 239 | ! Define the interface. 240 | integer(kind=c_int32_t) :: maj 241 | integer(kind=c_int32_t), intent(in) :: a 242 | integer(kind=c_int32_t), intent(in) :: b 243 | integer(kind=c_int32_t), intent(in) :: c 244 | ! ----------------------------------- 245 | maj = ieor(iand(a, b), ieor(iand(a, c), iand(b, c))) 246 | end function maj 247 | 248 | !> The '\Sigma_0' function in SHA-2. 249 | !! @param a : (in) The a input integer. 250 | !! @return : cs0(a), see the code. 251 | function cs0(a) 252 | implicit none 253 | ! ----------------------------------- 254 | ! Define the interface. 255 | integer(kind=c_int32_t) :: cs0 256 | integer(kind=c_int32_t), intent(in) :: a 257 | ! ----------------------------------- 258 | cs0 = ieor(ishftc(a, -2), ieor(ishftc(a, -13), ishftc(a, -22))) 259 | end function cs0 260 | 261 | !> The '\Sigma_1' function in SHA-2. 262 | !! @param a : (in) The a input integer. 263 | !! @return : cs1(a), see the code. 264 | function cs1(a) 265 | implicit none 266 | ! ----------------------------------- 267 | ! Define the interface. 268 | integer(kind=c_int32_t) :: cs1 269 | integer(kind=c_int32_t), intent(in) :: a 270 | ! ----------------------------------- 271 | cs1 = ieor(ishftc(a, -6), ieor(ishftc(a, -11), ishftc(a, -25))) 272 | end function cs1 273 | 274 | !> The '\sigma_0' function in SHA-2. 275 | !! @param a : (in) The a input integer. 276 | !! @return : ms0(a), see the code. 277 | function ms0(a) 278 | implicit none 279 | ! ----------------------------------- 280 | ! Define the interface. 281 | integer(kind=c_int32_t) :: ms0 282 | integer(kind=c_int32_t), intent(in) :: a 283 | ! ----------------------------------- 284 | ms0 = ieor(ishftc(a, -7), ieor(ishftc(a, -18), ishft(a, -3))) 285 | end function ms0 286 | 287 | !> The '\sigma_1' function in SHA-2. 288 | !! @param a : (in) The a input integer. 289 | !! @return : ms1(a), see the code. 290 | function ms1(a) 291 | implicit none 292 | ! ----------------------------------- 293 | ! Define the interface. 294 | integer(kind=c_int32_t) :: ms1 295 | integer(kind=c_int32_t), intent(in) :: a 296 | ! ----------------------------------- 297 | ms1 = ieor(ishftc(a, -17), ieor(ishftc(a, -19), ishft(a, -10))) 298 | end function ms1 299 | 300 | !> Copy 16 32bit words of data from str(pos0) to inp(1:16). The 301 | !! data is padded a requiered by the SHA-256 algorithm. 302 | !! @param str : (in) The message to take a chunk from. 303 | !! @param length : (in) The length of the message in 8bit words. 304 | !! @param inp : (inout) The work area to copy the data to. 305 | !! @param pos0 : (inout) Variable to store the start of the next chunk. 306 | !! @param break : (inout) Indicates the position in the work flow. 307 | !! break=0 on entry -> continue to consume a chunk, pad if needed. 308 | !! break=2 on entry -> continue to consume, padding was allready done. 309 | !! break=1 one exit -> the last chunk was consumed. 310 | !! @param swap : (in) Flag to indicate if swapping to big-endian 311 | !! input (swap=1) should be used. swap=1 is needed 312 | !! for the routine to pass the standard tests, but 313 | !! decreases speed with a factor 2. 314 | subroutine consume_chunk(str, length, inp, pos0, break, swap) 315 | implicit none 316 | ! ----------------------------------- 317 | ! Define the interface. 318 | character(len=*), intent(in) :: str 319 | integer(kind=c_int64_t), intent(in) :: length 320 | integer(kind=c_int32_t), intent(inout) :: inp(*) 321 | integer, intent(inout) :: pos0 322 | integer, intent(inout) :: break 323 | integer, intent(in) :: swap 324 | ! ----------------------------------- 325 | ! Internal variables. 326 | character(len=4) :: last_word 327 | integer(kind=c_int64_t) :: rest 328 | integer(kind=c_int32_t) :: to_pad 329 | integer(kind=c_int32_t) :: leftover 330 | integer(kind=c_int32_t) :: space_left 331 | integer(kind=c_int32_t) :: zero 332 | integer(kind=c_int8_t) :: ipad0 333 | integer(kind=c_int8_t) :: ipad1 334 | integer(kind=c_int8_t) :: i 335 | data zero / b'00000000000000000000000000000000'/ 336 | data ipad0 / b'00000000' / 337 | data ipad1 / b'10000000' / 338 | 339 | ! Calculate the rest. 340 | rest = length - pos0 + 1 341 | 342 | ! If we are far from the end. 343 | if (rest .ge. 64) then 344 | 345 | ! Copy the data over. 346 | inp(1:16) = transfer(str(pos0:pos0+64-1), inp(1:16)) 347 | 348 | ! Big-endian. 349 | if (swap .eq. 1) then 350 | do i=1,16 351 | inp(i) = swap32(inp(i)) 352 | end do 353 | end if 354 | 355 | ! Increment the starting position for the next roundx. 356 | pos0 = pos0 + 64 357 | 358 | else 359 | ! Space left in the input chunk. 360 | space_left = 16 361 | 362 | ! number of leftover full 32bit words. 363 | leftover = rest/4 364 | 365 | ! Copy any leftovers. 366 | if (leftover .gt. 0) then 367 | inp(1:leftover) = transfer(str(pos0:pos0+leftover*4-1), inp(1:16)) 368 | 369 | ! Big-endian. 370 | if (swap .eq. 1) then 371 | do i=1,leftover 372 | inp(i) = swap32(inp(i)) 373 | end do 374 | end if 375 | 376 | ! Increment the starting position. 377 | pos0 = pos0 + leftover*4 378 | rest = length - pos0 + 1 379 | space_left = space_left - leftover 380 | 381 | end if 382 | 383 | if (space_left .gt. 0) then 384 | 385 | if (break .ne. 2) then 386 | ! Add any remaining incomplete 32bit word. 387 | if (rest .gt. 0) then 388 | last_word(1:rest) = str(pos0:pos0+rest-1) 389 | ! Increment the pos0. 390 | pos0 = pos0 + rest 391 | end if 392 | 393 | ! Add the '10000000' padding. 394 | last_word(rest+1:rest+1) = transfer(ipad1, last_word(1:1)) 395 | 396 | ! Add zeros for a full 32bit word. 397 | to_pad = 4 - rest - 1 398 | do i=1,to_pad 399 | last_word(rest+1+i:rest+1+i) = transfer(ipad0, last_word(1:1)) 400 | end do 401 | 402 | ! Copy the last full (padded) word over. 403 | inp(17-space_left) = transfer(last_word(1:4), inp(1)) 404 | 405 | if (swap .eq. 1) then 406 | inp(17-space_left) = swap32(inp(17-space_left)) 407 | end if 408 | 409 | ! Decrement the space left. 410 | space_left = space_left - 1 411 | 412 | ! Set the flag to indicate that we have padded. 413 | break = 2 414 | 415 | end if 416 | 417 | ! If not enough space to finnish, add zeros. 418 | if (space_left .eq. 1) then 419 | inp(16) = zero 420 | space_left = 0 421 | end if 422 | 423 | rest = 0 424 | 425 | end if 426 | 427 | ! Continue with the last part if there is enough space left. 428 | if ((rest .eq. 0) .and. (space_left .ge. 2)) then 429 | 430 | ! Add zeros until 64 bits left. 431 | do while (space_left .gt. 2) 432 | inp(17-space_left) = zero 433 | space_left = space_left - 1 434 | end do 435 | 436 | ! Add the two last 32bit words. 437 | inp(15:16) = transfer(swap64a(length*8), inp(15:16)) 438 | 439 | ! Set break flag indicating we are done with the whole message. 440 | break = 1 441 | 442 | end if 443 | 444 | end if 445 | 446 | end subroutine consume_chunk 447 | 448 | end module hash 449 | -------------------------------------------------------------------------------- /src/inline.f90: -------------------------------------------------------------------------------- 1 | module inline 2 | use strings, only : ItC, LtC 3 | implicit none 4 | contains 5 | subroutine InlineQueryResultArticle(id, title, input_message_content, reply_markup, url, hide_url, description, thumb_url, thumb_width, thumb_height, json_str) 6 | character(len=*), intent(in) :: id, title, input_message_content 7 | character(len=*), optional, intent(in) :: url, description, thumb_url, reply_markup 8 | integer, optional, intent(in) :: thumb_width, thumb_height 9 | logical, optional, intent(in) :: hide_url 10 | character(len=:), allocatable, intent(out) :: json_str 11 | json_str = "{" 12 | json_str = json_str // '"type":"article","id":"' // id // '","title":"' // title // '",input_message_content":' // input_message_content 13 | if(present(reply_markup)) json_str = json_str // ',"reply_markup":' // reply_markup 14 | if(present(url)) json_str = json_str // ',"usr":"' // url // '"' 15 | if(present(hide_url)) json_str = json_str // ',"hide_url":' // LtC(hide_url) 16 | if(present(description)) json_str = json_str // ',"description":"' // description // '"' 17 | if(present(thumb_url)) json_str = json_str // ',"thumb_url":"' // thumb_url // '"' 18 | if(present(thumb_width)) json_str = json_str // ',"thumb_width":' // ItC(thumb_width) 19 | if(present(thumb_height)) json_str = json_str // ',"thumb_height":' // ItC(thumb_height) 20 | json_str = json_str // "}" 21 | end subroutine 22 | 23 | subroutine InlineQueryResultPhoto(id, photo_url, thumb_url, photo_width, photo_height, title, description, caption, parse_mode, reply_markup, input_message_content, json_str) 24 | character(len=*), intent(in) :: id, photo_url, thumb_url 25 | integer, optional, intent(in) :: photo_width, photo_height 26 | character(len=*), optional, intent(in) :: title, description, caption, parse_mode, reply_markup, input_message_content 27 | character(len=:), allocatable, intent(out) :: json_str 28 | json_str = "{" 29 | json_str = json_str // '"type":"photo","id":"' // id // '","photo_url":"' // photo_url // '","thumb_url":"' // thumb_url // '"' 30 | if(present(photo_width)) json_str = json_str // ',"photo_width":' // ItC(photo_width) 31 | if(present(photo_height)) json_str = json_str // ',"photo_height":' // ItC(photo_height) 32 | if(present(title)) json_str = json_str // ',"title":"' // title // '"' 33 | if(present(description)) json_str = json_str // ',"description":"' // description // '"' 34 | if(present(caption)) json_str = json_str // ',"caption":"' // caption // '"' 35 | if(present(parse_mode)) json_str = json_str // ',"parse_mode":"' // parse_mode // '"' 36 | if(present(reply_markup)) json_str = json_str // ',"reply_markup":' // reply_markup 37 | if(present(input_message_content)) json_str = json_str // ',"input_message_content":' // input_message_content 38 | json_str = json_str // "}" 39 | end subroutine 40 | 41 | subroutine InputTextMessageContent(message_text, parse_mode, disable_web_page_preview, json_str) 42 | character(len=*), intent(in) :: message_text 43 | character(len=*), optional, intent(in) :: parse_mode 44 | logical, optional, intent(in) :: disable_web_page_preview 45 | character(len=:), allocatable, intent(out) :: json_str 46 | json_str = "{" 47 | json_str = json_str // '"message_text":"' // message_text // '"' 48 | if(present(parse_mode)) json_str = json_str // ',"parse_mode":"' // parse_mode // '"' 49 | if(present(disable_web_page_preview)) json_str = json_str // ',"disable_web_page_preview":' // LtC(disable_web_page_preview) 50 | json_str = json_str // "}" 51 | end subroutine 52 | 53 | subroutine ResultArray(stringarray, json_str) 54 | character(len=*), dimension(:), intent(in) :: stringarray 55 | character(len=:), allocatable, intent(out) :: json_str 56 | integer :: i 57 | json_str = "[" 58 | do i = 1, size(stringarray) 59 | json_str = json_str // stringarray(i) // "," 60 | end do 61 | json_str(len(json_str):len(json_str)) = "]" 62 | end subroutine 63 | end module inline -------------------------------------------------------------------------------- /src/libcurl.c: -------------------------------------------------------------------------------- 1 | #include 2 | #include 3 | #include 4 | #include 5 | 6 | CURL *curl; 7 | 8 | typedef struct string { 9 | size_t len; 10 | char *str; 11 | } string; 12 | 13 | char *proxy = PROXY; 14 | 15 | //thanks @vehlwn for help with this code 16 | void append(string *this, char *buffer, size_t size) 17 | { 18 | size_t newSize = this->len + size; 19 | char *newStr = malloc(newSize); 20 | *newStr = 0; 21 | if(this->str) 22 | strcat(newStr, this->str); 23 | strncat(newStr, buffer, size); 24 | free(this->str); 25 | this->str = newStr; 26 | this->len = newSize; 27 | } 28 | 29 | size_t static write_callback_func(void *buffer, size_t size, size_t nmemb, void *userp) 30 | { 31 | append(((string*)userp), buffer, size*nmemb+1); 32 | return size*nmemb; 33 | } 34 | 35 | void ccurl_get(char *result, char *url, char *message, int *len, int *status) 36 | { 37 | int resp_len=0; 38 | printf("curlget: %s\n", url); 39 | printf("curlget: %s\n", message); 40 | CURLcode res; 41 | 42 | string response; 43 | response.len = 0; 44 | response.str = malloc(1); 45 | response.str[0] = 0; 46 | 47 | if(curl == NULL) curl = curl_easy_init(); 48 | curl_easy_setopt(curl, CURLOPT_URL, url); 49 | curl_easy_setopt(curl, CURLOPT_POSTFIELDS, message); 50 | curl_easy_setopt(curl, CURLOPT_PROXY, proxy); 51 | curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, write_callback_func); 52 | curl_easy_setopt(curl, CURLOPT_WRITEDATA, &response); 53 | res = curl_easy_perform(curl); 54 | //curl_easy_cleanup(curl); 55 | *status = (int)res; 56 | if(res == CURLE_OK) 57 | while(resp_len < response.len - 1) 58 | { 59 | result[resp_len] = response.str[resp_len]; 60 | resp_len++; 61 | } 62 | while(++resp_len < *len) 63 | { 64 | result[resp_len] = ' '; 65 | } 66 | free(response.str); 67 | 68 | } 69 | 70 | void ccurl_sendfile(char *result, char *url, int *count, int *keylen, char keys[*count][*keylen], int *vallen, char values[*count][*vallen], char *type, char *filepath, int *len, int *status) 71 | { 72 | printf("curlsend: %s\n", url); 73 | int resp_len = 0; 74 | string response; 75 | response.len = 0; 76 | response.str = malloc(1); 77 | response.str[0] = 0; 78 | CURLcode res; 79 | curl_mime *form = NULL; 80 | curl_mimepart *field = NULL; 81 | if(curl == NULL) curl = curl_easy_init(); 82 | 83 | form = curl_mime_init(curl); 84 | 85 | field = curl_mime_addpart(form); 86 | curl_mime_name(field, type); 87 | curl_mime_filedata(field, filepath); 88 | 89 | for(int i = 0; i < *count; i++) 90 | { 91 | printf("%s\n", keys[i]); 92 | printf("%s\n", values[i]); 93 | field = curl_mime_addpart(form); 94 | curl_mime_name(field, keys[i]); 95 | curl_mime_data(field, values[i], CURL_ZERO_TERMINATED); 96 | } 97 | 98 | curl_easy_setopt(curl, CURLOPT_URL, url); 99 | curl_easy_setopt(curl, CURLOPT_PROXY, proxy); 100 | curl_easy_setopt(curl, CURLOPT_MIMEPOST, form); 101 | //curl_easy_setopt(curl, CURLOPT_VERBOSE, 1L); 102 | curl_easy_setopt(curl, CURLOPT_WRITEFUNCTION, write_callback_func); 103 | curl_easy_setopt(curl, CURLOPT_WRITEDATA, &response); 104 | res = curl_easy_perform(curl); 105 | //curl_easy_cleanup(curl); 106 | *status = (int)res; 107 | if(res == CURLE_OK) 108 | while(resp_len < response.len - 1) 109 | { 110 | result[resp_len] = response.str[resp_len]; 111 | resp_len++; 112 | } 113 | while(resp_len < *len) 114 | { 115 | result[resp_len] = ' '; 116 | resp_len++; 117 | } 118 | curl_mime_free(form); 119 | free(response.str); 120 | } -------------------------------------------------------------------------------- /src/mainmpi.f90: -------------------------------------------------------------------------------- 1 | program latex2png 2 | use MPI 3 | use wrank 4 | use define 5 | implicit none 6 | integer :: i, mpirank, mpisize, ierr 7 | integer :: maingroup 8 | integer :: workergroup, workergroupsize, workergrouprank, COMM_WORKERGROUP 9 | integer :: sendergroup, sendergroupsize, sendergrouprank, COMM_SENDERGROUP 10 | integer :: inlinegroup, inlinegroupsize, inlinegrouprank, COMM_INLINEGROUP 11 | integer, dimension(:), allocatable :: inlines, workers, senders 12 | 13 | call MPI_INIT(ierr) 14 | call MPI_COMM_RANK(MPI_COMM_WORLD, mpirank, ierr) 15 | call MPI_COMM_SIZE(MPI_COMM_WORLD, mpisize, ierr) 16 | 17 | if(mpisize.lt.(3+count_inline+count_sender+1)) then 18 | print *, START_ERROR 19 | call MPI_ABORT(MPI_COMM_WORLD, 1, ierr) 20 | stop 21 | end if 22 | 23 | if(allocated(inlines)) deallocate(inlines) 24 | if(allocated(workers)) deallocate(workers) 25 | if(allocated(senders)) deallocate(senders) 26 | allocate(inlines(count_inline + 1)) 27 | allocate(senders(count_sender + 1)) 28 | allocate(workers(mpisize - 3 - count_inline - count_sender + 1)) 29 | inlines(1) = 1 30 | senders(1) = 2 31 | workers(1) = 1 32 | 33 | do i = 3, 3 + count_inline 34 | inlines(i-3+2) = i 35 | end do 36 | do i = 3 + count_inline, 3 + count_inline + count_sender 37 | senders(i-3-count_inline+2) = i 38 | end do 39 | do i = 3 + count_inline + count_sender, mpisize 40 | workers(i-3-count_inline-count_sender+2) = i 41 | end do 42 | 43 | call MPI_COMM_GROUP(MPI_COMM_WORLD, maingroup, ierr) 44 | 45 | call MPI_GROUP_INCL(maingroup, size(inlines), inlines, inlinegroup, ierr) 46 | call MPI_COMM_CREATE(MPI_COMM_WORLD, inlinegroup, COMM_INLINEGROUP, ierr) 47 | call MPI_GROUP_SIZE(inlinegroup, inlinegroupsize, ierr) 48 | call MPI_GROUP_RANK(inlinegroup, inlinegrouprank, ierr) 49 | 50 | call MPI_GROUP_INCL(maingroup, size(senders), senders, sendergroup, ierr) 51 | call MPI_COMM_CREATE(MPI_COMM_WORLD, sendergroup, COMM_SENDERGROUP, ierr) 52 | call MPI_GROUP_SIZE(sendergroup, sendergroupsize, ierr) 53 | call MPI_GROUP_RANK(sendergroup, sendergrouprank, ierr) 54 | 55 | call MPI_GROUP_INCL(maingroup, size(workers), workers, workergroup, ierr) 56 | call MPI_COMM_CREATE(MPI_COMM_WORLD, workergroup, COMM_WORKERGROUP, ierr) 57 | call MPI_GROUP_SIZE(workergroup, workergroupsize, ierr) 58 | call MPI_GROUP_RANK(workergroup, workergrouprank, ierr) 59 | 60 | if(mpirank.eq.0) then 61 | call rank0() 62 | else if(mpirank.eq.1) then 63 | call rank1(COMM_WORKERGROUP, COMM_INLINEGROUP) 64 | else if(mpirank.eq.2) then 65 | call rank2(COMM_SENDERGROUP) 66 | else if(any(inlines.eq.mpirank)) then 67 | call rank_inlines(COMM_INLINEGROUP) 68 | else if(any(workers.eq.mpirank)) then 69 | call rank_workers(COMM_WORKERGROUP) 70 | else if(any(senders.eq.mpirank)) then 71 | call rank_senders(COMM_SENDERGROUP) 72 | end if 73 | 74 | call MPI_GROUP_FREE(inlinegroup, ierr) 75 | call MPI_GROUP_FREE(sendergroup, ierr) 76 | call MPI_GROUP_FREE(workergroup, ierr) 77 | call MPI_FINALIZE(ierr) 78 | end program latex2png -------------------------------------------------------------------------------- /src/sleep.c: -------------------------------------------------------------------------------- 1 | #define _POSIX_C_SOURCE 199309L /* shall be >= 199309L */ 2 | 3 | #include 4 | 5 | void csleep_(int *milliseconds) 6 | { 7 | int ms_remaining = (*milliseconds) % 1000; 8 | long usec = ms_remaining * 1000; 9 | struct timespec ts_sleep; 10 | 11 | ts_sleep.tv_sec = (*milliseconds) / 1000; 12 | ts_sleep.tv_nsec = 1000*usec; 13 | nanosleep(&ts_sleep, NULL); 14 | } -------------------------------------------------------------------------------- /src/strings.f90: -------------------------------------------------------------------------------- 1 | module strings 2 | contains 3 | function LtC(l) 4 | implicit none 5 | logical :: l 6 | character(len=:), allocatable :: LtC 7 | if(l.eqv..TRUE.) then 8 | LtC = 'true' 9 | else 10 | LtC = 'false' 11 | end if 12 | end function LtC 13 | 14 | function ItC(i) 15 | implicit none 16 | integer :: i 17 | character(len=:), allocatable :: ItC 18 | character(len=12) :: tmp 19 | write(tmp, '(I0)') i 20 | ItC = trim(tmp) 21 | end function ItC 22 | 23 | function ASCIItoUTF8(ascii) 24 | implicit none 25 | integer, parameter :: u = selected_char_kind('ISO_10646') 26 | character(len=*) :: ascii 27 | character(kind=u, len=:), allocatable :: parse 28 | character(kind=u, len=:), allocatable :: ASCIItoUTF8 29 | integer :: i, escape, length, code 30 | logical :: escaped 31 | character(len=10) :: tmp 32 | character :: this 33 | length = len(ascii) 34 | escaped = .FALSE. 35 | escape = 0 36 | parse = '' 37 | do i = 1, length 38 | this = ascii(i:i) 39 | if(escaped) then 40 | escaped = .FALSE. 41 | select case(this) 42 | case ('x') 43 | escape = 2 44 | tmp = ascii(i+1:i+2) 45 | parse = parse // CHAR(CXtI(tmp), u) 46 | case ('u') 47 | escape = 4 48 | tmp = ascii(i+1:i+4) 49 | parse = parse // CHAR(CXtI(tmp), u) 50 | case ('U') 51 | escape = 8 52 | tmp = ascii(i+1:i+8) 53 | parse = parse // CHAR(CXtI(tmp), u) 54 | case default 55 | print *, 'PARSE ERROR' 56 | escape = 0 57 | tmp = '' 58 | end select 59 | else if(escape.ne.0) then 60 | escape = escape - 1 61 | else if(ICHAR(this).eq.0) then 62 | escaped = .TRUE. 63 | else 64 | parse = parse // CHAR(ICHAR(this), u) 65 | end if 66 | end do 67 | asciitoutf8 = parse 68 | end function 69 | 70 | INTEGER(4) FUNCTION CXtI(STR) RESULT(I) 71 | IMPLICIT NONE 72 | CHARACTER(len=*) :: STR 73 | READ(STR, "(Z8)") I 74 | END FUNCTION 75 | end module -------------------------------------------------------------------------------- /src/tgAPI.f90: -------------------------------------------------------------------------------- 1 | module tgAPI 2 | use ISO_C_BINDING, only: C_INT, C_CHAR, C_NULL_CHAR 3 | use strings, only : ItC, LtC 4 | use define, only : TGBOTKEY 5 | implicit none 6 | character(len=*) :: apibotkey 7 | integer :: maxsizetext 8 | parameter (apibotkey = 'https://api.telegram.org/bot' // TGBOTKEY) 9 | parameter (MAXSIZETEXT = 1048576) 10 | 11 | INTERFACE 12 | SUBROUTINE CCURL_GET(RESULT, URL, MESSAGE, LENGTH, STATUS) BIND(C) 13 | IMPLICIT NONE 14 | CHARACTER, DIMENSION(*) :: RESULT, URL, MESSAGE 15 | INTEGER :: LENGTH, STATUS 16 | END SUBROUTINE 17 | 18 | SUBROUTINE CCURL_SENDFILE(RESULT, URL, COUNT, KEYLEN, KEYS, VALLEN, VALUES, FILETYPE, FILEPATH, LENGTH, STATUS) BIND(C) 19 | CHARACTER, DIMENSION(*) :: RESULT, URL, FILETYPE, FILEPATH 20 | INTEGER :: COUNT, KEYLEN, VALLEN, LENGTH, STATUS 21 | CHARACTER :: KEYS(COUNT, KEYLEN), VALUES(COUNT, KEYLEN) 22 | END SUBROUTINE 23 | END INTERFACE 24 | 25 | contains 26 | subroutine get(subURL, message, result, status) 27 | implicit none 28 | character(len=*), intent(in) :: subURL 29 | character(len=*) , intent(in) :: message 30 | character(len=:), allocatable, intent(out) :: result 31 | integer(4) , intent(out) :: status 32 | character(len=MAXSIZETEXT) :: response 33 | character(len=:), allocatable :: URL 34 | URL = apibotkey // subURL // C_NULL_CHAR 35 | call ccurl_get(response, URL, message // C_NULL_CHAR, MAXSIZETEXT, status) 36 | result = trim(response) 37 | end subroutine 38 | 39 | subroutine post(subURL, message, status) 40 | character(len=*), intent(in) :: subURL 41 | character(len=*) , intent(in) :: message 42 | integer(4) , intent(out) :: status 43 | character(len=MAXSIZETEXT) :: response 44 | character(len=:), allocatable :: URL 45 | URL = apibotkey // subURL // C_NULL_CHAR 46 | call ccurl_get(response, URL, message // C_NULL_CHAR, MAXSIZETEXT, status) 47 | end subroutine 48 | 49 | subroutine sendfile(subURL, keys, values, filetype, filepath, status) 50 | character(len=*) , intent(in) :: subURL 51 | character(len=*) , intent(in) :: filepath, filetype 52 | integer(4) , intent(out) :: status 53 | character(len=:), allocatable, intent(in) :: keys(:), values(:) 54 | character(len=MAXSIZETEXT) :: response 55 | character(len=:), allocatable :: URL 56 | integer(4) , allocatable :: shaper(:) 57 | URL = apibotkey // subURL // C_NULL_CHAR 58 | shaper = shape(keys) 59 | call ccurl_sendfile(response, URL, shaper(1), len(keys(1)), keys, len(values(1)), values, filetype // C_NULL_CHAR, filepath // C_NULL_CHAR, MAXSIZETEXT, status) 60 | print *, trim(response) 61 | end subroutine 62 | 63 | subroutine getMe(result, status) 64 | implicit none 65 | character(len=:), allocatable, intent(out) :: result 66 | integer(4) , optional , intent(out) :: status 67 | !temporary 68 | character(len=:), allocatable :: message 69 | integer(4) :: hidden 70 | message = '' 71 | hidden = 0 72 | call get('/getMe', message, result, hidden) 73 | if(present(status)) status = hidden 74 | end subroutine 75 | 76 | subroutine getUpdates(result, offset, limit, timeout, status) 77 | implicit none 78 | character(len=:), allocatable, intent(out) :: result 79 | integer(4) , optional , intent(in) :: offset, limit, timeout 80 | integer(4) , optional , intent(out) :: status 81 | !temporary 82 | character(len=:), allocatable :: message, strtmp 83 | integer(4) :: hidden 84 | message = '' 85 | hidden = 0 86 | if(present(offset)) then 87 | message = message // '&offset=' // ItC(offset) 88 | end if 89 | if(present(limit)) then 90 | message = message // '&limit=' // ItC(limit) 91 | end if 92 | if(present(timeout)) then 93 | message = message // '&timeout=' // ItC(timeout) 94 | end if 95 | if(len(message).ne.0) then 96 | strtmp = message(2:) 97 | message = strtmp 98 | end if 99 | print *, message 100 | call get('/getUpdates', message, result, hidden) 101 | if(present(status)) status = hidden 102 | end subroutine 103 | 104 | subroutine sendMessage(chat_id, text, parse_mode, disable_web_page_preview, disable_notification, reply_to_message_id, reply_markup, status) 105 | character(len=*) , intent(in) :: chat_id, text 106 | character(len=*), optional, intent(in) :: parse_mode, reply_markup 107 | logical , optional, intent(in) :: disable_web_page_preview, disable_notification 108 | integer(4) , optional, intent(in) :: reply_to_message_id 109 | integer(4) , optional, intent(out) :: status 110 | !tempopary 111 | character(len=:), allocatable :: message 112 | integer(4) :: hidden 113 | hidden = 0 114 | message = 'chat_id=' // chat_id // '&text=' // text 115 | if(present(parse_mode)) then 116 | message = message // '&parse_mode=' // parse_mode 117 | end if 118 | if(present(disable_web_page_preview)) then 119 | message = message // '&disable_web_page_preview=' // LtC(disable_web_page_preview) 120 | end if 121 | if(present(disable_notification)) then 122 | message = message // '&disable_notification=' // LtC(disable_notification) 123 | end if 124 | if(present(reply_to_message_id)) then 125 | message = message // '&reply_to_message_id=' // ItC(reply_to_message_id) 126 | end if 127 | if(present(reply_markup)) then 128 | message = message // '&reply_markup=' // reply_markup 129 | end if 130 | call post('/sendMessage', message, status) 131 | if(present(status)) status = hidden 132 | end subroutine 133 | 134 | subroutine sendPhoto(chat_id, photo, caption, disable_notification, reply_to_message_id, reply_markup, status) 135 | character(len=*) , intent(in) :: chat_id, photo 136 | character(len=*), optional, intent(in) :: caption, reply_markup 137 | logical , optional, intent(in) :: disable_notification 138 | integer(4) , optional, intent(in) :: reply_to_message_id 139 | integer(4) , optional, intent(out) :: status 140 | !tempopary 141 | character(len=:), allocatable :: keys(:), values(:) 142 | integer(4) :: hidden, count, maxlen 143 | hidden = 0 144 | count = 1 145 | maxlen = len(chat_id) 146 | if(present(caption)) then 147 | count = count + 1 148 | maxlen = max(maxlen, len(caption)) 149 | end if 150 | if(present(disable_notification)) then 151 | count = count + 1 152 | maxlen = max(maxlen, len(LtC(disable_notification))) 153 | end if 154 | if(present(reply_to_message_id)) then 155 | count = count + 1 156 | maxlen = max(maxlen, len(ItC(reply_to_message_id))) 157 | end if 158 | if(present(reply_markup)) then 159 | count = count + 1 160 | maxlen = max(maxlen, len(reply_markup)) 161 | end if 162 | allocate(character(len=maxlen+1) :: values(count)) 163 | allocate(character(len=80) :: keys(count)) 164 | count = 1 165 | keys (count) = 'chat_id' // C_NULL_CHAR 166 | values(count) = chat_id // C_NULL_CHAR 167 | if(present(caption)) then 168 | count = count + 1 169 | keys (count) = 'caption' // C_NULL_CHAR 170 | values(count) = caption // C_NULL_CHAR 171 | end if 172 | if(present(disable_notification)) then 173 | count = count + 1 174 | keys (count) = 'disable_notification' // C_NULL_CHAR 175 | values(count) = LtC(disable_notification) // C_NULL_CHAR 176 | end if 177 | if(present(reply_to_message_id)) then 178 | count = count + 1 179 | keys (count) = 'reply_to_message_id' // C_NULL_CHAR 180 | values(count) = ItC(reply_to_message_id) // C_NULL_CHAR 181 | end if 182 | if(present(reply_markup)) then 183 | count = count + 1 184 | keys (count) = 'reply_markup' // C_NULL_CHAR 185 | values(count) = reply_markup // C_NULL_CHAR 186 | end if 187 | !subroutine sendfile(subURL, keys, values, filetype, filepath, status) 188 | call sendfile('/sendPhoto', keys, values, 'photo', photo, hidden) 189 | if(present(status)) status = hidden 190 | end subroutine 191 | 192 | subroutine sendDocument(chat_id, document, caption, disable_notification, reply_to_message_id, reply_markup, status) 193 | character(len=*) , intent(in) :: chat_id, document 194 | character(len=*), optional, intent(in) :: caption, reply_markup 195 | logical , optional, intent(in) :: disable_notification 196 | integer(4) , optional, intent(in) :: reply_to_message_id 197 | integer(4) , optional, intent(out) :: status 198 | !tempopary 199 | character(len=:), allocatable :: keys(:), values(:) 200 | integer(4) :: hidden, count, maxlen 201 | hidden = 0 202 | count = 1 203 | maxlen = len(chat_id) 204 | if(present(caption)) then 205 | count = count + 1 206 | maxlen = max(maxlen, len(caption)) 207 | end if 208 | if(present(disable_notification)) then 209 | count = count + 1 210 | maxlen = max(maxlen, len(LtC(disable_notification))) 211 | end if 212 | if(present(reply_to_message_id)) then 213 | count = count + 1 214 | maxlen = max(maxlen, len(ItC(reply_to_message_id))) 215 | end if 216 | if(present(reply_markup)) then 217 | count = count + 1 218 | maxlen = max(maxlen, len(reply_markup)) 219 | end if 220 | allocate(character(len=maxlen+1) :: values(count)) 221 | allocate(character(len=80) :: keys(count)) 222 | count = 1 223 | keys (count) = 'chat_id' // C_NULL_CHAR 224 | values(count) = chat_id // C_NULL_CHAR 225 | if(present(caption)) then 226 | count = count + 1 227 | keys (count) = 'caption' // C_NULL_CHAR 228 | values(count) = caption // C_NULL_CHAR 229 | end if 230 | if(present(disable_notification)) then 231 | count = count + 1 232 | keys (count) = 'disable_notification' // C_NULL_CHAR 233 | values(count) = LtC(disable_notification) // C_NULL_CHAR 234 | end if 235 | if(present(reply_to_message_id)) then 236 | count = count + 1 237 | keys (count) = 'reply_to_message_id' // C_NULL_CHAR 238 | values(count) = ItC(reply_to_message_id) // C_NULL_CHAR 239 | end if 240 | if(present(reply_markup)) then 241 | count = count + 1 242 | keys (count) = 'reply_markup' // C_NULL_CHAR 243 | values(count) = reply_markup // C_NULL_CHAR 244 | end if 245 | !subroutine sendfile(subURL, keys, values, filetype, filepath, status) 246 | call sendfile('/sendDocument', keys, values, 'document', document, hidden) 247 | if(present(status)) status = hidden 248 | end subroutine 249 | 250 | subroutine answerInlineQuery(inline_query_id, results, cache_time, is_personal, next_offset, switch_pm_text, switch_pm_parameter, status) 251 | character(len=*), intent(in) :: inline_query_id, results 252 | integer(4), optional, intent(in) :: cache_time 253 | logical, optional, intent(in) :: is_personal 254 | character(len=*), optional, intent(in) :: next_offset, switch_pm_text, switch_pm_parameter 255 | integer(4), optional, intent(out) :: status 256 | character(len=:), allocatable :: message, result 257 | integer(4) :: hidden 258 | message = "inline_query_id=" // inline_query_id // "&results=" // results 259 | if(present(cache_time)) message = message // "&cache_time=" // ItC(cache_time) 260 | if(present(is_personal)) message = message // "&is_personal=" // LtC(is_personal) 261 | if(present(next_offset)) message = message // "&next_offset=" // next_offset 262 | if(present(switch_pm_text)) message = message // "&switch_pm_text=" // switch_pm_text 263 | if(present(switch_pm_parameter)) message = message // "&switch_pm_parameter=" // switch_pm_parameter 264 | call get("/answerInlineQuery", message, result, status) 265 | print *, result 266 | if(present(status)) status = hidden 267 | end subroutine 268 | 269 | subroutine CURL_ERR(status, text) 270 | integer(4), intent(in) :: status 271 | character(len=:), allocatable, intent(out) :: text 272 | text = '' 273 | select case (status) 274 | case (0) 275 | text = 'CURLE_OK' 276 | case (7) 277 | text = 'CURLE_COULDNT_CONNECT' 278 | case (23) 279 | text = 'CURLE_WRITE_ERROR' 280 | case (35) 281 | text = 'CURLE_SSL_CONNECT_ERROR' 282 | case (52) 283 | text = 'CURLE_GOT_NOTHING' 284 | case (60) 285 | text = 'CURLE_PEER_FAILED_VERIFICATION' 286 | case default 287 | text = 'UNSUPPORTED ERROR: ' // ItC(status) 288 | end select 289 | end subroutine 290 | end module -------------------------------------------------------------------------------- /src/wfile.f90: -------------------------------------------------------------------------------- 1 | module wfile 2 | implicit none 3 | integer(4) :: MAXLENGTH 4 | parameter (MAXLENGTH = 4096*12) 5 | contains 6 | subroutine getUserIDbyIP(IP, IPchars) 7 | integer(kind=2), dimension(4), intent(in) :: IP 8 | character(len=:), allocatable, intent(out) :: IPchars 9 | character(len=4) :: tmpchar 10 | integer(4) :: i 11 | IPchars = '' 12 | do i = 1, 4 13 | write(tmpchar, '(I4)') IP(i) 14 | IPchars = trim(IPchars) // '.' // adjustl(tmpchar) 15 | end do 16 | IPchars = IPchars(2:) 17 | end subroutine 18 | 19 | subroutine getUserData(ID, MESSID) 20 | implicit none 21 | character(len=*) :: ID, MESSID 22 | logical :: file_exist 23 | integer :: error, idmess 24 | character(len=:), allocatable :: sID 25 | read (MESSID, '(I10)') idmess 26 | sID = adjustl(trim(ID)) 27 | open(unit=idmess, file='./users/' // sID // '.history', action='WRITE', position='APPEND') 28 | write(idmess, '(a)') trim(MESSID) // ': ' // 'GET USER DATA' 29 | close(idmess) 30 | end subroutine 31 | 32 | subroutine checkFiles(ID, MESSID) 33 | character(len=*) :: ID, MESSID 34 | logical :: file_exist 35 | integer :: error, idmess 36 | character(len=:), allocatable :: sID 37 | read (MESSID, '(I10)') idmess 38 | sID = adjustl(trim(ID)) 39 | call execute_command_line('[[ ! -e users ]] && mkdir users', cmdstat=error) 40 | if(error .ne. 0) then 41 | print *, 'CANNOT CREATE USERS DIRECTORY' 42 | stop 43 | end if 44 | inquire(file='./users/' // sID // '.settings', exist=file_exist) 45 | if(file_exist .neqv. .true.) then 46 | open(unit=idmess, file='./users/' // sID // '.settings', action='WRITE') 47 | close(unit=idmess) 48 | end if 49 | inquire(file='./users/' // sID // '.packages', exist=file_exist) 50 | if(file_exist .neqv. .true.) then 51 | open(unit=idmess, file='./users/' // sID // '.packages', action='WRITE') 52 | close(unit=idmess) 53 | end if 54 | open(unit=idmess, file='./users/' // sID // '.history', action='WRITE', position='APPEND') 55 | close(idmess) 56 | end subroutine 57 | 58 | subroutine writeLog(ID, MESSID, MESS) 59 | implicit none 60 | character(len=*) :: ID, MESSID, MESS 61 | character(len=:), allocatable :: filenm, sID 62 | integer :: idmess 63 | read (MESSID, '(I10)') idmess 64 | sID = adjustl(trim(ID)) 65 | filenm = './users/' // sID // '.history' 66 | open(unit=idmess, file=filenm, position='append', action='write') 67 | write(idmess, '(A)') MESSID // ': ' // MESS 68 | close(idmess) 69 | end subroutine 70 | 71 | subroutine readfile(filename, result) 72 | USE, INTRINSIC :: ISO_FORTRAN_ENV, ONLY: IOSTAT_EOR 73 | implicit none 74 | character(len=*), intent(in) :: filename 75 | character(len=:), allocatable :: result 76 | character(len=256) :: buffer 77 | integer :: stat 78 | result = '' 79 | open(unit=7, file=trim(filename), action='READ') 80 | do 81 | read(7, '(a)', iostat=stat) buffer 82 | if(stat .eq. -1) then 83 | result = trim(result) 84 | close(unit=7) 85 | return 86 | end if 87 | result = result // trim(buffer) // NEW_LINE('') 88 | end do 89 | result = trim(result) 90 | close(unit=7) 91 | end subroutine 92 | 93 | subroutine LatexDefault(result) 94 | implicit none 95 | character(len=:), allocatable :: result 96 | call readfile('./default.tex', result) 97 | end subroutine 98 | 99 | subroutine getPackages(ID, result, isMessage) 100 | implicit none 101 | character(len=*), intent(in) :: ID 102 | character(len=:), allocatable :: result, filenm 103 | logical, optional :: isMessage 104 | filenm = './users/' // adjustl(trim(ID)) // '.packages' 105 | call readfile(filenm, result) 106 | if(present(isMessage).and.len(result).eq.0) then 107 | result = 'No usage packages' 108 | end if 109 | end subroutine 110 | 111 | subroutine reset(ID, MESSID) 112 | implicit none 113 | character(len=*), intent(in) :: ID, MESSID 114 | integer :: error, idmess 115 | character(len=:), allocatable :: sID 116 | read (MESSID, '(I10)') idmess 117 | sID = adjustl(trim(ID)) 118 | call writeLog(ID, MESSID, 'RESET') 119 | open(unit=idmess, file='./users/' // sID // '.settings', status='unknown', iostat=error) 120 | if(error .eq. 0) then 121 | close(unit=idmess, status='delete') 122 | end if 123 | open(unit=idmess, file='./users/' // sID // '.settings', status='new') 124 | close(unit=idmess) 125 | open(unit=idmess, file='./users/' // sID // '.packages', status='unknown', iostat=error) 126 | if(error .eq. 0) then 127 | close(unit=idmess, status='delete') 128 | end if 129 | open(unit=idmess, file='./users/' // sID // '.packages', status='new') 130 | close(unit=idmess) 131 | end subroutine 132 | 133 | subroutine appendHeadline(ID, MESSID, text, package) 134 | character(len=*), intent(in) :: ID, MESSID, package, text 135 | integer :: idmess 136 | call writeLog(ID, MESSID, 'APPEND HEADLINE: ' // text // package) 137 | read (MESSID, '(I10)') idmess 138 | open(unit=idmess, file='./users/' // adjustl(trim(ID)) // '.packages', status='old', position='append', action='write') 139 | write(idmess, '(A)') text // package 140 | close(idmess) 141 | end subroutine 142 | 143 | subroutine setHeadlines(ID, MESSID, text) 144 | character(len=*), intent(in) :: ID, MESSID, text 145 | integer :: idmess 146 | call writeLog(ID, MESSID, 'SET HEADLINE: ' // text) 147 | read (MESSID, '(I10)') idmess 148 | open(unit=idmess, file='./users/' // adjustl(trim(ID)) // '.packages', status='unknown', action='write') 149 | write(idmess, '(A)') text 150 | close(idmess) 151 | end subroutine 152 | 153 | subroutine saveLaTeX(fullfile, filenm) 154 | use hash 155 | use strings 156 | implicit none 157 | character(len=*), intent(in) :: fullfile 158 | character(len=:), allocatable, intent(out) :: filenm 159 | integer :: error 160 | call execute_command_line('[[ ! -e pics ]] && mkdir pics', cmdstat=error) 161 | if(error .ne. 0) then 162 | print *, 'CANNOT CREATE PICS DIRECTORY' 163 | stop 164 | end if 165 | filenm = './pics/' // sha256sum(fullfile) 166 | open(unit=9, file=filenm // '.tex', action='WRITE', encoding='utf-8') 167 | write(9, '(A)') ASCIItoUTF8(fullfile) 168 | close(9) 169 | end subroutine 170 | 171 | subroutine generateLaTeX(filenm, strerr) 172 | implicit none 173 | character(len=*), intent(in) :: filenm 174 | character(len=:), allocatable, intent(out) :: strerr 175 | integer :: error 176 | logical :: file_exist 177 | call execute_command_line('pdflatex -output-format=dvi -no-shell-escape -interaction=batchmode -output-directory pics ' // filenm // '.tex &>/dev/null', cmdstat=error) 178 | if(error .ne. 0) then 179 | strerr = 'CANNOT CREATE DVI' 180 | return 181 | end if 182 | inquire(file=filenm // '.dvi', exist=file_exist) 183 | if(file_exist .neqv. .true.) then 184 | strerr = 'ERROR IN LATEX' 185 | return 186 | end if 187 | call execute_command_line('dvipng -D 1200 ' // filenm // '.dvi -o ' // filenm // '.png &>/dev/null', cmdstat=error) 188 | if(error .ne. 0) then 189 | strerr = 'CANNOT CREATE PIC' 190 | return 191 | end if 192 | strerr = 'OK' 193 | end subroutine 194 | 195 | subroutine savePDF(link, save, strerr) 196 | implicit none 197 | character(len=*), intent(in) :: link, save 198 | character(len=:), allocatable, intent(out) :: strerr 199 | integer :: error 200 | call execute_command_line('[[ ! -e pdfs ]] && mkdir pdfs', cmdstat=error) 201 | if(error .ne. 0) then 202 | print *, 'CANNOT CREATE PDFS DIRECTORY' 203 | stop 204 | end if 205 | !call downloadFile(link, save, strerr) 206 | end subroutine 207 | 208 | subroutine generatePDF(filenm, strerr) 209 | implicit none 210 | character(len=*), intent(in) :: filenm 211 | character(len=:), allocatable, intent(out) :: strerr 212 | integer :: error 213 | logical :: file_exist 214 | call execute_command_line('pdflatex -interaction=batchmode -output-directory pdfs ' // filenm // '.tex &>/dev/null', cmdstat=error) 215 | if(error .ne. 0) then 216 | strerr = 'CANNOT CREATE PDF' 217 | return 218 | end if 219 | inquire(file=filenm // '.pdf', exist=file_exist) 220 | if(file_exist .neqv. .true.) then 221 | strerr = 'ERROR IN LATEX' 222 | return 223 | end if 224 | strerr = 'OK' 225 | end subroutine 226 | 227 | subroutine json_rank0(strinp, offset) 228 | use fson 229 | use fson_value_m, only: fson_value_count, fson_value_get 230 | character(len=*), intent(in) :: strinp 231 | integer(4), intent(out) :: offset 232 | integer(4), allocatable :: updateid(:) 233 | type(fson_value), pointer :: json, result, item 234 | integer(4) :: i, lenresult 235 | json => fson_parse(str=strinp) 236 | if(fson_check(json, 'result')) then 237 | call fson_get(json, 'result', result) 238 | lenresult = fson_value_count(result) 239 | if(allocated(updateid)) then 240 | deallocate(updateid) 241 | end if 242 | allocate(updateid(lenresult)) 243 | do i = 1, lenresult 244 | item => fson_value_get(result, i) 245 | call fson_get(item, 'update_id', updateid(i)) 246 | end do 247 | offset = maxval(updateid) 248 | else 249 | offset = 0 250 | end if 251 | call fson_destroy(json) 252 | end subroutine 253 | 254 | subroutine json_rank1(strinp, atext, userid, supdateid, mode, command) 255 | use fson 256 | use fson_value_m, only: fson_value_count, fson_value_get 257 | use define, only: workermode, inlinemode 258 | character(len=*), intent(in) :: strinp 259 | integer(4), allocatable, intent(out) :: userid(:), mode(:), command(:) 260 | character(len=40), allocatable, intent(out) :: supdateid(:) 261 | integer(4), allocatable :: updateid(:) 262 | type(fson_value), pointer :: json, result, message, from, item 263 | character(len=MAXLENGTH) :: text 264 | character(len=MAXLENGTH), allocatable :: atext(:) 265 | character(len=:), allocatable :: tmptext 266 | integer(4) :: lenresult, i, messtype 267 | messtype = -1 268 | json => fson_parse(str=strinp) 269 | if(fson_check(json, 'result')) then 270 | call fson_get(json, 'result', result) 271 | lenresult = fson_value_count(result) 272 | if(allocated(updateid)) deallocate(updateid) 273 | if(allocated(supdateid)) deallocate(supdateid) 274 | if(allocated(userid)) deallocate(userid) 275 | if(allocated(mode)) deallocate(mode) 276 | if(allocated(command)) deallocate(command) 277 | if(allocated(atext)) deallocate(atext) 278 | allocate(updateid(lenresult)) 279 | allocate(supdateid(lenresult)) 280 | allocate(userid(lenresult)) 281 | allocate(mode(lenresult)) 282 | allocate(command(lenresult)) 283 | allocate(atext(lenresult)) 284 | do i = 1, lenresult 285 | item => fson_value_get(result, i) 286 | call fson_get(item, 'update_id', updateid(i)) 287 | write(supdateid(i), "(I40)") updateid(i) 288 | if(fson_check(item, 'message')) then 289 | call fson_get(item, 'message', message) 290 | call fson_get(message, 'from', from) 291 | call fson_get(from, 'id', userid(i)) 292 | if(fson_check(message, 'text')) then 293 | call fson_get(message, 'text', text) 294 | messtype = 0 295 | else if(fson_check(message, 'document')) then 296 | !call fson_get(message, 'document', text) 297 | text = '' 298 | messtype = 1 299 | end if 300 | mode(i) = workermode 301 | else if(fson_check(item, 'inline_query')) then 302 | call fson_get(item, 'inline_query', message) 303 | call fson_get(message, 'id', supdateid(i)) 304 | call fson_get(message, 'from', from) 305 | call fson_get(from, 'id', userid(i)) 306 | call fson_get(message, 'query', text) 307 | messtype = 2 308 | mode(i) = inlinemode 309 | end if 310 | atext(i) = trim(text) 311 | tmptext = atext(i) 312 | call parsecommand(tmptext, messtype, command(i)) 313 | atext(i) = tmptext 314 | end do 315 | else 316 | lenresult = 0 317 | if(allocated(updateid)) deallocate(updateid) 318 | if(allocated(supdateid)) deallocate(supdateid) 319 | if(allocated(userid)) deallocate(userid) 320 | if(allocated(command)) deallocate(command) 321 | if(allocated(atext)) deallocate(atext) 322 | if(allocated(mode)) deallocate(mode) 323 | allocate(atext(lenresult)) 324 | allocate(updateid(lenresult)) 325 | allocate(command(lenresult)) 326 | allocate(userid(lenresult)) 327 | allocate(supdateid(lenresult)) 328 | end if 329 | call fson_destroy(json) 330 | end subroutine json_rank1 331 | 332 | subroutine send(userid, type, text, status) 333 | use tgAPI, only : sendmessage, sendphoto, senddocument 334 | integer(4) , intent(in) :: userid, type 335 | character(len=*), intent(in) :: text 336 | integer(4) , intent(out) :: status 337 | !tempopary 338 | character(len=12) :: convert 339 | character(len=:), allocatable :: suserid 340 | select case(type) 341 | case (0) 342 | write (convert, '(I12)') userid 343 | suserid = adjustl(trim(convert)) 344 | call sendmessage(suserid, text, status=status) 345 | case (1) 346 | !send photo 347 | write (convert, '(I12)') userid 348 | suserid = adjustl(trim(convert)) 349 | call sendphoto(suserid, text, status=status) 350 | case (2) 351 | !send document 352 | write (convert, '(I12)') userid 353 | suserid = adjustl(trim(convert)) 354 | call senddocument(suserid, text, status=status) 355 | case (3) 356 | write (convert, '(I12)') userid 357 | suserid = adjustl(trim(convert)) 358 | call sendmessage(suserid, text, parse_mode='Markdown', status=status) 359 | case default 360 | print *, 'UNSUPPORTED TYPE', type 361 | end select 362 | end subroutine 363 | 364 | subroutine parsecommand(message, messtype, command) 365 | implicit none 366 | character(len=:), allocatable, intent(inout) :: message 367 | integer(4), intent(in) :: messtype 368 | integer(4), intent(out) :: command 369 | character(len=:), allocatable :: strtmp 370 | message = message // ' ' 371 | select case(messtype) 372 | case (0) 373 | if(index(message, '/start ') .eq. 1) then 374 | command = 0 375 | message = '' 376 | else if(index(message, '/help ') .eq. 1) then 377 | command = 1 378 | message = '' 379 | else if(index(message, '/reset ') .eq. 1) then 380 | command = 2 381 | message = '' 382 | else if(index(message, '/getpackages ') .eq. 1) then 383 | command = 3 384 | message = '' 385 | else if(index(message, '/addpackage ') .eq. 1) then 386 | command = 4 387 | strtmp = message(13:) 388 | message = strtmp 389 | else if(index(message, '/rempackage ') .eq. 1) then 390 | command = 5 391 | strtmp = message(13:) 392 | message = strtmp 393 | else if(index(message, '/debug ') .eq. 1) then 394 | command = 6 395 | strtmp = message(8:) 396 | message = strtmp 397 | else if(index(message, '/fox ') .eq. 1) then 398 | command = 7 399 | message = '' 400 | else if(index(message, '/recipe ') .eq. 1) then 401 | command = 8 402 | strtmp = message(9:) 403 | message = strtmp 404 | else if(index(message, '/version ') .eq. 1) then 405 | command = 9 406 | message = '' 407 | else if(index(message, '/preambula ') .eq. 1) then 408 | command = 10 409 | strtmp = message(11:) 410 | message = strtmp 411 | else if(index(message, '/setpreambula ') .eq. 1) then 412 | command = 11 413 | strtmp = message(14:) 414 | message = strtmp 415 | else if(index(message, '/ip ') .eq. 1) then 416 | command = 12 417 | message = '' 418 | else 419 | command = -1 420 | end if 421 | case (1) 422 | command = -2 423 | case (2) 424 | if(index(message, '/fox ') .eq. 1) then 425 | command = 0 426 | message = '' 427 | else 428 | command = -1 429 | end if 430 | case default 431 | command = -200000 432 | message = 'ERROR IN PARSECOMMAND' 433 | end select 434 | end subroutine 435 | end module -------------------------------------------------------------------------------- /src/wrank.f90: -------------------------------------------------------------------------------- 1 | module wrank 2 | use MPI 3 | use wsleep 4 | implicit none 5 | 6 | integer(4) :: MPIBUFFERSIZE, CHARBUFFERSIZE, MAXLENGTH 7 | parameter (MPIBUFFERSIZE = 100000 * MPI_BSEND_OVERHEAD) 8 | parameter (CHARBUFFERSIZE = 1024) 9 | parameter (MAXLENGTH = 4096*12) 10 | 11 | contains 12 | subroutine rank0() 13 | use tgAPI 14 | use wfile, only : getoffset => json_rank0 15 | character(len=:), allocatable :: str, str1 16 | character(len=CHARBUFFERSIZE) :: charbuffer 17 | integer(4) :: ierr, res, offset 18 | integer(1) :: buffer(MPIBUFFERSIZE) 19 | call MPI_BUFFER_ATTACH(buffer, MPIBUFFERSIZE, ierr) 20 | offset = 0 21 | do 22 | if(offset.le.0) then 23 | call getUpdates(str, timeout=30, status=res) 24 | else 25 | call getUpdates(str, offset=offset, timeout=30, status=res) 26 | end if 27 | if(res.eq.0.and.len(trim(str)).ne.0) then 28 | str = adjustl(trim(str)) 29 | call getoffset(str, offset) 30 | offset = offset + 1 31 | call MPI_BSEND(1, 1, MPI_INTEGER, 1, 599, MPI_COMM_WORLD, ierr) 32 | do while (len(str) .ne. 0) 33 | charbuffer = str(1:MIN(CHARBUFFERSIZE, len(str))) 34 | str1 = str(CHARBUFFERSIZE+1:len(str)) 35 | str = str1 36 | call MPI_BSEND(len(charbuffer), 1, MPI_INTEGER, 1, 600, MPI_COMM_WORLD, ierr) 37 | call MPI_BSEND(charbuffer, len(charbuffer), MPI_CHARACTER, 1, 601, MPI_COMM_WORLD, ierr) 38 | end do 39 | call MPI_BSEND(0, 1, MPI_INTEGER, 1, 600, MPI_COMM_WORLD, ierr) 40 | else 41 | call curl_err(res, str) 42 | print *, "|", str, "|" 43 | end if 44 | end do 45 | end subroutine 46 | 47 | subroutine rank1(COMM_WORKERGROUP, COMM_INLINEGROUP) 48 | use wfile, only : parse => json_rank1 49 | use define, only : workermode, inlinemode 50 | integer, intent(in) :: COMM_WORKERGROUP, COMM_INLINEGROUP 51 | integer :: length 52 | integer :: status(MPI_STATUS_SIZE) 53 | character(len=:), allocatable :: strinp 54 | character(len=CHARBUFFERSIZE) :: charbuffer = REPEAT(" ", CHARBUFFERSIZE) 55 | integer(4), allocatable :: userid(:), mode(:), command(:) 56 | character(len=40), allocatable :: supdateid(:) 57 | integer(4) :: lenans 58 | character(len=MAXLENGTH) :: text 59 | character(len=MAXLENGTH), allocatable :: atext(:) 60 | !mpi_message 61 | character(len=MAXLENGTH+64) :: mpimess 62 | character(len=12) :: convert 63 | character(len=40) :: convert40 64 | integer(4) :: dest, commworkersize, comminlinesize, ierr, i 65 | integer(1) :: buffer(MPIBUFFERSIZE) 66 | real :: randreal 67 | logical :: canget 68 | call MPI_BUFFER_ATTACH(buffer, MPIBUFFERSIZE, ierr) 69 | call MPI_COMM_SIZE(COMM_WORKERGROUP, commworkersize, ierr) 70 | call MPI_COMM_SIZE(COMM_INLINEGROUP, comminlinesize, ierr) 71 | do 72 | length = 1 73 | strinp = "" 74 | text = REPEAT(" ", MAXLENGTH) 75 | canget = .FALSE. 76 | do while (canget.neqv..TRUE.) 77 | call MPI_IPROBE(0, 599, MPI_COMM_WORLD, canget, status, ierr) 78 | if (canget.eqv..FALSE.) then 79 | call msleep(10) 80 | end if 81 | end do 82 | call MPI_RECV(length, 1, MPI_INTEGER, 0, 599, MPI_COMM_WORLD, status, ierr) 83 | 84 | do while (length.ne.0) 85 | charbuffer = REPEAT(" ", CHARBUFFERSIZE) 86 | call MPI_RECV(length, 1, MPI_INTEGER, 0, 600, MPI_COMM_WORLD, status, ierr) 87 | if(length.ne.0) then 88 | call MPI_RECV(charbuffer, length, MPI_CHARACTER, 0, 601, MPI_COMM_WORLD, status, ierr) 89 | strinp = strinp // trim(charbuffer) 90 | end if 91 | end do 92 | call parse(strinp, atext, userid, supdateid, mode, command) 93 | lenans = size(userid) 94 | if(lenans.gt.0) print *, "rank1: ", strinp 95 | do i = 1, lenans 96 | print *, supdateid(i), userid(i), command(i), trim(atext(i)) 97 | text = REPEAT(" ", MAXLENGTH) 98 | text = atext(i) 99 | mpimess = REPEAT(" ", MAXLENGTH+36) 100 | mpimess( 1:40) = supdateid(i) 101 | write (convert, "(I12)") userid(i) 102 | mpimess(41:52) = convert 103 | write (convert, "(I12)") command(i) 104 | mpimess(53:64) = convert 105 | mpimess(65:MAXLENGTH+64) = text 106 | if(mode(i).eq.workermode) then 107 | call random_number(randreal) 108 | dest = 1 + floor(randreal*(commworkersize-1)) 109 | call MPI_BSEND(mpimess, MAXLENGTH+64, MPI_CHARACTER, dest, 700, COMM_WORKERGROUP, ierr) 110 | else if(mode(i).eq.inlinemode) then 111 | call random_number(randreal) 112 | dest = 1 + floor(randreal*(comminlinesize-1)) 113 | call MPI_BSEND(mpimess, MAXLENGTH+64, MPI_CHARACTER, dest, 720, COMM_INLINEGROUP, ierr) 114 | end if 115 | end do 116 | end do 117 | end subroutine 118 | 119 | subroutine rank2(COMM_SENDERGROUP) 120 | integer, intent(in) :: COMM_SENDERGROUP 121 | character(len=MAXLENGTH+64) :: mpimess 122 | integer(4) :: status(MPI_STATUS_SIZE), dest, commsendersize, ierr 123 | logical :: canget 124 | integer(1) :: buffer(MPIBUFFERSIZE) 125 | real :: randreal 126 | call MPI_BUFFER_ATTACH(buffer, MPIBUFFERSIZE, ierr) 127 | call MPI_COMM_SIZE(COMM_SENDERGROUP, commsendersize, ierr) 128 | do 129 | canget = .FALSE. 130 | do while (canget.neqv..TRUE.) 131 | call MPI_IPROBE(MPI_ANY_SOURCE, 800, MPI_COMM_WORLD, canget, status, ierr) 132 | if (canget.eqv..FALSE.) then 133 | call msleep(4) 134 | end if 135 | end do 136 | call MPI_RECV(mpimess, MAXLENGTH+64, MPI_CHAR, MPI_ANY_SOURCE, 800, MPI_COMM_WORLD, status, ierr) 137 | call random_number(randreal) 138 | dest = 1 + floor(randreal*(commsendersize-1)) 139 | call MPI_BSEND(mpimess, MAXLENGTH+64, MPI_CHARACTER, dest, 900, COMM_SENDERGROUP, ierr) 140 | end do 141 | end subroutine 142 | 143 | subroutine rank_senders(COMM_SENDERGROUP) 144 | use wfile, only : send 145 | integer(4), intent(in) :: COMM_SENDERGROUP 146 | integer(4) :: userid, resulttype, error, res 147 | character(len=:), allocatable :: text 148 | character(len=12) :: convert 149 | character(len=40) :: convert40 150 | character(len=MAXLENGTH) :: charbuffer 151 | !mpi 152 | character(len=MAXLENGTH+64) :: mpimess 153 | integer(4) :: status(MPI_STATUS_SIZE), ierr 154 | logical :: canget 155 | integer(1) :: buffer(MPIBUFFERSIZE) 156 | call MPI_BUFFER_ATTACH(buffer, MPIBUFFERSIZE, ierr) 157 | do 158 | canget = .FALSE. 159 | do while (canget.neqv..TRUE.) 160 | call MPI_IPROBE(0, 900, COMM_SENDERGROUP, canget, status, ierr) 161 | if (canget.eqv..FALSE.) then 162 | call msleep(50) 163 | end if 164 | end do 165 | call MPI_RECV(mpimess, MAXLENGTH+64, MPI_CHAR, 0, 900, COMM_SENDERGROUP, status, ierr) 166 | read(mpimess( 1:40), '(I40)') userid 167 | read(mpimess(41:52), '(I12)') resulttype 168 | read(mpimess(53:64), '(I12)') error 169 | read(mpimess(65: ), '(A)') charbuffer 170 | text = trim(charbuffer) 171 | call send(userid, resulttype, text, res) 172 | error = error + 1 173 | if(res.ne.0.and.error.le.10) then 174 | mpimess = REPEAT(' ', MAXLENGTH+64) 175 | write (convert40, '(I40)') userid 176 | mpimess(1:40) = convert40 177 | write (convert, '(I12)') resulttype 178 | mpimess(41:52) = convert 179 | write (convert, '(I12)') error 180 | mpimess(53:64) = convert 181 | mpimess(65:MAXLENGTH+64) = charbuffer 182 | call MPI_BSEND(mpimess, MAXLENGTH+64, MPI_CHARACTER, 2, 800, MPI_COMM_WORLD, ierr) 183 | end if 184 | end do 185 | end subroutine 186 | 187 | subroutine rank_workers(COMM_WORKERGROUP) 188 | use actions, only : generateresponse 189 | integer(4), intent(in) :: COMM_WORKERGROUP 190 | integer(4) :: ierr, status(MPI_STATUS_SIZE), request 191 | character(len=MAXLENGTH+64) :: mpimess 192 | character(len=MAXLENGTH) :: charbuffer 193 | character(len=:), allocatable :: text, key, error 194 | character(len=12) :: convert 195 | character(len=40) :: convert40 196 | integer(4) :: updateid, userid, command, resulttype 197 | logical :: canget 198 | integer(1) :: buffer(MPIBUFFERSIZE) 199 | call MPI_BUFFER_ATTACH(buffer, MPIBUFFERSIZE, ierr) 200 | do 201 | canget = .FALSE. 202 | do while (canget.neqv..TRUE.) 203 | call MPI_IPROBE(0, 700, COMM_WORKERGROUP, canget, status, ierr) 204 | if (canget.eqv..FALSE.) then 205 | call msleep(50) 206 | end if 207 | end do 208 | call MPI_RECV(mpimess, MAXLENGTH+64, MPI_CHAR, 0, 700, COMM_WORKERGROUP, status, ierr) 209 | read(mpimess( 1:40), '(I40)') updateid 210 | read(mpimess(41:52), '(I12)') userid 211 | read(mpimess(53:64), '(I12)') command 212 | read(mpimess(65: ), '(A)') charbuffer 213 | text = trim(charbuffer) 214 | call generateresponse(userid, updateid, command, text, resulttype, key, error) 215 | print *, resulttype, len(error), '"', key, ':', error, '"' 216 | mpimess = REPEAT(' ', MAXLENGTH+64) 217 | write (convert40, '(I40)') userid 218 | mpimess( 1:40) = convert40 219 | write (convert, '(I12)') resulttype 220 | mpimess(41:52) = convert 221 | write (convert, '(I12)') 0 222 | mpimess(53:64) = convert 223 | mpimess(65:MAXLENGTH+64) = key 224 | call MPI_BSEND(mpimess, MAXLENGTH+64, MPI_CHARACTER, 2, 800, MPI_COMM_WORLD, ierr) 225 | if(len(error).ne.0) then 226 | mpimess = REPEAT(' ', MAXLENGTH+64) 227 | write (convert40, '(I40)') userid 228 | mpimess( 1:40) = convert40 229 | write (convert, '(I12)') 0 230 | mpimess(41:52) = convert 231 | write (convert, '(I12)') 0 232 | mpimess(53:64) = convert 233 | mpimess(65:MAXLENGTH+64) = error 234 | call MPI_BSEND(mpimess, MAXLENGTH+64, MPI_CHARACTER, 2, 800, MPI_COMM_WORLD, ierr) 235 | end if 236 | end do 237 | end subroutine 238 | 239 | subroutine rank_inlines(COMM_INLINEGROUP) 240 | use actions, only : inlineresponse 241 | integer(4), intent(in) :: COMM_INLINEGROUP 242 | integer(4) :: ierr, status(MPI_STATUS_SIZE), request 243 | character(len=MAXLENGTH+64) :: mpimess 244 | character(len=MAXLENGTH) :: charbuffer 245 | character(len=:), allocatable :: text, key, error, supdateid 246 | integer(4) :: userid, command, resulttype 247 | logical :: canget 248 | integer(1) :: buffer(MPIBUFFERSIZE) 249 | call MPI_BUFFER_ATTACH(buffer, MPIBUFFERSIZE, ierr) 250 | do 251 | canget = .FALSE. 252 | do while (canget.neqv..TRUE.) 253 | call MPI_IPROBE(0, 720, COMM_INLINEGROUP, canget, status, ierr) 254 | if (canget.eqv..FALSE.) then 255 | call msleep(10) 256 | end if 257 | end do 258 | print *, "TEST" 259 | call MPI_RECV(mpimess, MAXLENGTH+64, MPI_CHAR, 0, 720, COMM_INLINEGROUP, status, ierr) 260 | supdateid = mpimess( 1:40) 261 | read(mpimess(41:52), '(I12)') userid 262 | read(mpimess(53:64), '(I12)') command 263 | read(mpimess(65: ), '(A)') charbuffer 264 | text = trim(charbuffer) 265 | call inlineresponse(userid, supdateid, command, text) 266 | end do 267 | end subroutine 268 | end module -------------------------------------------------------------------------------- /src/wsleep.f90: -------------------------------------------------------------------------------- 1 | module wsleep 2 | contains 3 | subroutine fsleep(secs) 4 | implicit none 5 | integer(4), intent(in) :: secs 6 | call sleep(secs) 7 | end subroutine 8 | 9 | subroutine msleep(millisecs) 10 | implicit none 11 | integer(4), intent(in) :: millisecs 12 | call Csleep(millisecs) 13 | end subroutine 14 | end module --------------------------------------------------------------------------------