|
12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882888388848885888688878888888988908891889288938894889588968897889888998900890189028903890489058906890789088909891089118912891389148915891689178918891989208921892289238924892589268927892889298930893189328933893489358936893789388939894089418942894389448945894689478948894989508951895289538954895589568957895889598960896189628963896489658966896789688969897089718972897389748975897689778978897989808981898289838984898589868987898889898990899189928993899489958996899789988999900090019002900390049005900690079008900990109011901290139014901590169017901890199020902190229023902490259026902790289029903090319032903390349035903690379038903990409041904290439044904590469047904890499050905190529053905490559056905790589059906090619062906390649065906690679068906990709071907290739074907590769077907890799080908190829083908490859086908790889089909090919092909390949095909690979098909991009101910291039104910591069107910891099110911191129113911491159116911791189119912091219122912391249125912691279128912991309131913291339134913591369137913891399140914191429143914491459146914791489149915091519152915391549155915691579158915991609161916291639164916591669167916891699170917191729173917491759176917791789179918091819182918391849185918691879188918991909191919291939194919591969197919891999200920192029203920492059206920792089209921092119212921392149215921692179218921992209221922292239224922592269227922892299230923192329233923492359236923792389239924092419242924392449245924692479248924992509251925292539254925592569257925892599260926192629263926492659266926792689269927092719272927392749275927692779278927992809281928292839284928592869287928892899290929192929293929492959296929792989299930093019302930393049305930693079308930993109311931293139314931593169317931893199320932193229323932493259326932793289329933093319332933393349335933693379338933993409341934293439344934593469347934893499350935193529353935493559356935793589359936093619362936393649365936693679368936993709371937293739374937593769377937893799380938193829383938493859386938793889389939093919392939393949395939693979398939994009401940294039404940594069407940894099410941194129413941494159416941794189419942094219422942394249425942694279428942994309431943294339434943594369437943894399440944194429443944494459446944794489449945094519452945394549455945694579458945994609461946294639464946594669467946894699470947194729473947494759476947794789479948094819482948394849485948694879488948994909491949294939494949594969497949894999500950195029503950495059506950795089509951095119512951395149515951695179518951995209521952295239524952595269527952895299530953195329533953495359536953795389539954095419542954395449545954695479548954995509551955295539554955595569557955895599560956195629563956495659566956795689569957095719572957395749575957695779578957995809581958295839584958595869587958895899590959195929593959495959596959795989599960096019602960396049605960696079608960996109611961296139614961596169617961896199620962196229623962496259626962796289629963096319632963396349635963696379638963996409641964296439644964596469647964896499650965196529653965496559656965796589659966096619662966396649665966696679668966996709671967296739674967596769677967896799680968196829683968496859686968796889689969096919692969396949695969696979698969997009701970297039704970597069707970897099710971197129713971497159716971797189719972097219722972397249725972697279728972997309731973297339734973597369737973897399740974197429743974497459746974797489749975097519752975397549755975697579758975997609761976297639764976597669767976897699770977197729773977497759776977797789779978097819782978397849785978697879788978997909791979297939794979597969797979897999800980198029803980498059806980798089809981098119812981398149815981698179818981998209821982298239824982598269827982898299830983198329833983498359836983798389839984098419842984398449845984698479848984998509851985298539854985598569857985898599860986198629863986498659866986798689869987098719872987398749875987698779878987998809881988298839884988598869887988898899890989198929893989498959896989798989899990099019902990399049905990699079908990999109911991299139914991599169917991899199920992199229923992499259926992799289929993099319932993399349935993699379938993999409941994299439944994599469947994899499950995199529953995499559956995799589959996099619962996399649965996699679968996999709971997299739974997599769977997899799980998199829983998499859986998799889989999099919992999399949995999699979998999910000100011000210003100041000510006100071000810009100101001110012100131001410015100161001710018100191002010021100221002310024100251002610027100281002910030100311003210033100341003510036100371003810039100401004110042100431004410045100461004710048100491005010051100521005310054100551005610057100581005910060100611006210063100641006510066100671006810069100701007110072100731007410075100761007710078100791008010081100821008310084100851008610087100881008910090100911009210093100941009510096100971009810099101001010110102101031010410105101061010710108101091011010111101121011310114101151011610117101181011910120101211012210123101241012510126101271012810129101301013110132101331013410135101361013710138101391014010141101421014310144101451014610147101481014910150101511015210153101541015510156101571015810159101601016110162101631016410165101661016710168101691017010171101721017310174101751017610177101781017910180101811018210183101841018510186101871018810189101901019110192101931019410195101961019710198101991020010201102021020310204102051020610207102081020910210102111021210213102141021510216102171021810219102201022110222102231022410225102261022710228102291023010231102321023310234102351023610237102381023910240102411024210243102441024510246102471024810249102501025110252102531025410255102561025710258102591026010261102621026310264102651026610267102681026910270102711027210273102741027510276102771027810279102801028110282102831028410285102861028710288102891029010291102921029310294102951029610297102981029910300103011030210303103041030510306103071030810309103101031110312103131031410315103161031710318103191032010321103221032310324103251032610327103281032910330103311033210333103341033510336103371033810339103401034110342103431034410345103461034710348103491035010351103521035310354103551035610357103581035910360103611036210363103641036510366103671036810369103701037110372103731037410375103761037710378103791038010381103821038310384103851038610387103881038910390103911039210393103941039510396103971039810399104001040110402104031040410405104061040710408104091041010411104121041310414104151041610417104181041910420104211042210423104241042510426104271042810429104301043110432104331043410435104361043710438104391044010441104421044310444104451044610447104481044910450104511045210453104541045510456104571045810459104601046110462104631046410465104661046710468104691047010471104721047310474104751047610477104781047910480104811048210483104841048510486104871048810489104901049110492104931049410495104961049710498104991050010501105021050310504105051050610507105081050910510105111051210513105141051510516105171051810519105201052110522105231052410525105261052710528105291053010531105321053310534105351053610537105381053910540105411054210543105441054510546105471054810549105501055110552105531055410555105561055710558105591056010561105621056310564105651056610567105681056910570105711057210573105741057510576105771057810579105801058110582105831058410585105861058710588105891059010591105921059310594105951059610597105981059910600106011060210603106041060510606106071060810609106101061110612106131061410615106161061710618106191062010621106221062310624106251062610627106281062910630106311063210633106341063510636106371063810639106401064110642106431064410645106461064710648106491065010651106521065310654106551065610657106581065910660106611066210663106641066510666106671066810669106701067110672106731067410675106761067710678106791068010681106821068310684106851068610687106881068910690106911069210693106941069510696106971069810699107001070110702107031070410705107061070710708107091071010711107121071310714107151071610717107181071910720107211072210723107241072510726107271072810729107301073110732107331073410735107361073710738107391074010741107421074310744107451074610747107481074910750107511075210753107541075510756107571075810759107601076110762107631076410765107661076710768107691077010771107721077310774107751077610777107781077910780107811078210783107841078510786107871078810789107901079110792107931079410795107961079710798107991080010801108021080310804108051080610807108081080910810108111081210813108141081510816108171081810819108201082110822108231082410825108261082710828108291083010831108321083310834108351083610837108381083910840108411084210843108441084510846108471084810849108501085110852108531085410855108561085710858108591086010861108621086310864108651086610867108681086910870108711087210873108741087510876108771087810879108801088110882108831088410885108861088710888108891089010891108921089310894108951089610897108981089910900109011090210903109041090510906109071090810909109101091110912109131091410915109161091710918109191092010921109221092310924109251092610927109281092910930109311093210933109341093510936109371093810939109401094110942109431094410945109461094710948109491095010951109521095310954109551095610957109581095910960109611096210963109641096510966109671096810969109701097110972109731097410975109761097710978109791098010981109821098310984109851098610987109881098910990109911099210993109941099510996109971099810999110001100111002110031100411005110061100711008110091101011011110121101311014110151101611017110181101911020110211102211023110241102511026110271102811029110301103111032110331103411035110361103711038110391104011041110421104311044110451104611047110481104911050110511105211053110541105511056110571105811059110601106111062110631106411065110661106711068110691107011071110721107311074110751107611077110781107911080110811108211083110841108511086110871108811089110901109111092110931109411095110961109711098110991110011101111021110311104111051110611107111081110911110111111111211113111141111511116111171111811119111201112111122111231112411125111261112711128111291113011131111321113311134111351113611137111381113911140111411114211143111441114511146111471114811149111501115111152111531115411155111561115711158111591116011161111621116311164111651116611167111681116911170111711117211173111741117511176111771117811179111801118111182111831118411185111861118711188111891119011191111921119311194111951119611197111981119911200112011120211203112041120511206112071120811209112101121111212112131121411215112161121711218112191122011221112221122311224112251122611227112281122911230112311123211233112341123511236112371123811239112401124111242112431124411245112461124711248112491125011251112521125311254112551125611257112581125911260112611126211263112641126511266112671126811269112701127111272112731127411275112761127711278112791128011281112821128311284112851128611287112881128911290112911129211293112941129511296112971129811299113001130111302113031130411305113061130711308113091131011311113121131311314113151131611317113181131911320113211132211323113241132511326113271132811329113301133111332113331133411335113361133711338113391134011341113421134311344113451134611347113481134911350113511135211353113541135511356113571135811359113601136111362113631136411365113661136711368113691137011371113721137311374113751137611377113781137911380113811138211383113841138511386113871138811389113901139111392113931139411395113961139711398113991140011401114021140311404114051140611407114081140911410114111141211413114141141511416114171141811419114201142111422114231142411425114261142711428114291143011431114321143311434114351143611437114381143911440114411144211443114441144511446114471144811449114501145111452114531145411455114561145711458114591146011461114621146311464114651146611467114681146911470114711147211473114741147511476114771147811479114801148111482114831148411485114861148711488114891149011491114921149311494114951149611497114981149911500115011150211503115041150511506115071150811509115101151111512115131151411515115161151711518115191152011521115221152311524115251152611527115281152911530115311153211533115341153511536115371153811539115401154111542115431154411545115461154711548115491155011551115521155311554115551155611557115581155911560115611156211563115641156511566115671156811569115701157111572115731157411575115761157711578115791158011581115821158311584115851158611587115881158911590115911159211593115941159511596115971159811599116001160111602116031160411605116061160711608116091161011611116121161311614116151161611617116181161911620116211162211623116241162511626116271162811629116301163111632116331163411635116361163711638116391164011641116421164311644116451164611647116481164911650116511165211653116541165511656116571165811659116601166111662116631166411665116661166711668116691167011671116721167311674116751167611677116781167911680116811168211683116841168511686116871168811689116901169111692116931169411695116961169711698116991170011701117021170311704117051170611707117081170911710117111171211713117141171511716117171171811719 |
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90"
- !*****************************************************************************************
- !> author: Jacob Williams
- ! license: BSD
- !
- ! This module provides a low-level interface for manipulation of JSON data.
- ! The two public entities are [[json_value]], and [[json_core(type)]].
- ! The [[json_file_module]] provides a higher-level interface to some
- ! of these routines.
- !
- !### License
- ! * JSON-Fortran is released under a BSD-style license.
- ! See the [LICENSE](https://github.com/jacobwilliams/json-fortran/blob/master/LICENSE)
- ! file for details.
-
- module json_value_module
-
- use,intrinsic :: iso_fortran_env, only: iostat_end,error_unit,output_unit
- use,intrinsic :: ieee_arithmetic
- use json_kinds
- use json_parameters
- use json_string_utilities
-
- implicit none
-
- private
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_macros.inc" 1
- ! JSON-Fortran preprocessor macros.
- !
- ! License
- ! JSON-Fortran is released under a BSD-style license.
- ! See the [LICENSE](https://github.com/jacobwilliams/json-fortran/blob/master/LICENSE)
- ! file for details.
-
- !*********************************************************
- ! File encoding preprocessor macro.
- !
- # 15
-
- ! don't ask for utf-8 file encoding unless using UCS4
- ! this may let us use unformatted stream io to read in files more quickly
- ! even with unicode support turned on `inquire( ... encoding=FL_ENCODING)`
- ! may be able to detect json files in which each character is exactly one
- ! byte
-
-
- !*********************************************************
-
- !*********************************************************
- ! This C preprocessor macro will take a procedure name as an
- ! input, and output either that same procedure name if the
- ! code is compiled without USE_UCS4 being defined or it will
- ! expand the procedure name to the original procedure name,
- ! followed by a comma and then the original procedure name
- ! with 'wrap_' prepended to it. This is suitable for creating
- ! overloaded interfaces that will accept UCS4 character actual
- ! arguments as well as DEFAULT/ASCII character arguments,
- ! based on whether or not ISO 10646 is supported and requested.
- !
- # 55
-
-
-
- !*********************************************************
- # 28 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- !*********************************************************
- !>
- ! If Unicode is not enabled, then
- ! JSON files are opened using access='STREAM' and
- ! form='UNFORMATTED'. This allows the file to
- ! be read faster.
- !
- # 38
-
- logical,parameter :: use_unformatted_stream = .true.
-
- !*********************************************************
-
- !*********************************************************
- !>
- ! If Unicode is not enabled, then
- ! JSON files are opened using access='STREAM' and
- ! form='UNFORMATTED'. This allows the file to
- ! be read faster.
- !
- # 52
-
- character(kind=CDK,len=*),parameter :: access_spec = 'STREAM'
-
- !*********************************************************
-
- !*********************************************************
- !>
- ! If Unicode is not enabled, then
- ! JSON files are opened using access='STREAM' and
- ! form='UNFORMATTED'. This allows the file to
- ! be read faster.
- !
- # 66
-
- character(kind=CDK,len=*),parameter :: form_spec = 'UNFORMATTED'
-
- !*********************************************************
-
- !*********************************************************
- !>
- ! Type used to construct the linked-list JSON structure.
- ! Normally, this should always be a pointer variable.
- ! This type should only be used by an instance of [[json_core(type)]].
- !
- !### Example
- !
- ! The following test program:
- !
- !````fortran
- ! program test
- ! use json_module
- ! implicit none
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_object(p,'') !create the root
- ! call json%add(p,'year',1805) !add some data
- ! call json%add(p,'value',1.0_RK) !add some data
- ! call json%print(p,'test.json') !write it to a file
- ! call json%destroy(p) !cleanup
- ! end program test
- !````
- !
- ! Produces the JSON file **test.json**:
- !
- !````json
- ! {
- ! "year": 1805,
- ! "value": 0.1E+1
- ! }
- !````
- !
- !@warning Pointers of this type should only be allocated
- ! using the methods from [[json_core(type)]].
-
- type,public :: json_value
-
- !force the constituents to be stored contiguously
- ![note: on Intel, the order of the variables below
- ! is significant to avoid the misaligned field warnings]
- sequence
-
- private
-
- !for the linked list:
- type(json_value),pointer :: previous => null() !! previous item in the list
- type(json_value),pointer :: next => null() !! next item in the list
- type(json_value),pointer :: parent => null() !! parent item of this
- type(json_value),pointer :: children => null() !! first child item of this
- type(json_value),pointer :: tail => null() !! last child item of this
-
- character(kind=CK,len=:),allocatable :: name !! variable name (unescaped)
-
- real(RK),allocatable :: dbl_value !! real data for this variable
- logical(LK),allocatable :: log_value !! logical data for this variable
- character(kind=CK,len=:),allocatable :: str_value !! string data for this variable
- !! (unescaped)
- integer(IK),allocatable :: int_value !! integer data for this variable
-
- integer(IK) :: var_type = json_unknown !! variable type
-
- integer(IK),private :: n_children = 0 !! number of children
-
- end type json_value
- !*********************************************************
-
- !*********************************************************
- !>
- ! To access the core routines for manipulation
- ! of [[json_value]] pointer variables. This class allows
- ! for thread safe use of the module.
- !
- !### Usage
- !````fortran
- ! program test
- ! use json_module, wp=>json_RK
- ! implicit none
- ! type(json_core) :: json !<--have to declare this
- ! type(json_value),pointer :: p
- ! call json%create_object(p,'') !create the root
- ! call json%add(p,'year',1805) !add some data
- ! call json%add(p,'value',1.0_wp) !add some data
- ! call json%print(p,'test.json') !write it to a file
- ! call json%destroy(p) !cleanup
- ! end program test
- !````
- type,public :: json_core
-
- private
-
- integer(IK) :: spaces_per_tab = 2 !! number of spaces for indenting
-
- logical(LK) :: compact_real = .true. !! to use the "compact" form of real
- !! numbers for output
- character(kind=CDK,len=:),allocatable :: real_fmt !! the format string to use
- !! for converting real numbers to strings.
- !! It can be set in [[json_initialize]],
- !! and used in [[json_value_print]]
- !! If not set, then `default_real_fmt`
- !! is used instead.
-
- logical(LK) :: is_verbose = .false. !! if true, all exceptions are
- !! immediately printed to console.
-
- logical(LK) :: stop_on_error = .false. !! if true, then the program is
- !! stopped immediately when an
- !! exception is raised.
-
- logical(LK) :: exception_thrown = .false. !! The error flag. Will be set to true
- !! when an error is thrown in the class.
- !! Many of the methods will check this
- !! and return immediately if it is true.
- character(kind=CK,len=:),allocatable :: err_message
- !! the error message.
- !! if `exception_thrown=False` then
- !! this variable is not allocated.
-
- integer(IK) :: char_count = 0 !! character position in the current line
- integer(IK) :: line_count = 1 !! lines read counter
- integer(IK) :: pushed_index = 0 !! used when parsing lines in file
- character(kind=CK,len=pushed_char_size) :: pushed_char = CK_'' !! used when parsing
- !! lines in file
-
- integer(IK) :: ipos = 1 !! for allocatable strings: next character to read
-
- logical(LK) :: strict_type_checking = .false. !! if true, then no type conversions are done
- !! in the `get` routines if the actual variable
- !! type is different from the return type (for
- !! example, integer to real).
-
- logical(LK) :: trailing_spaces_significant = .false. !! for name and path comparisons, if trailing
- !! space is to be considered significant.
-
- logical(LK) :: case_sensitive_keys = .true. !! if name and path comparisons
- !! are case sensitive.
-
- logical(LK) :: no_whitespace = .false. !! when printing a JSON string, don't include
- !! non-significant spaces or line breaks.
- !! If true, the entire structure will be
- !! printed on one line.
-
- logical(LK) :: unescaped_strings = .true. !! If false, then the escaped
- !! string is returned from [[json_get_string]]
- !! and similar routines. If true [default],
- !! then the string is returned unescaped.
-
- logical(LK) :: allow_comments = .true. !! if true, any comments will be ignored when
- !! parsing a file. The comment tokens are defined
- !! by the `comment_char` character variable.
- character(kind=CK,len=:),allocatable :: comment_char !! comment tokens when
- !! `allow_comments` is true.
- !! Examples: '`!`' or '`#`'.
- !! Default is `CK_'/!#'`.
-
- integer(IK) :: path_mode = 1_IK !! How the path strings are interpreted in the
- !! `get_by_path` routines:
- !!
- !! * 1 -- Default mode (see [[json_get_by_path_default]])
- !! * 2 -- as RFC 6901 "JSON Pointer" paths
- !! (see [[json_get_by_path_rfc6901]])
- !! * 3 -- JSONPath "bracket-notation"
- !! see [[json_get_by_path_jsonpath_bracket]])
-
- character(kind=CK,len=1) :: path_separator = dot !! The `path` separator to use
- !! in the "default" mode for
- !! the paths in the various
- !! `get_by_path` routines.
- !! Note: if `path_mode/=1`
- !! then this is ignored.
-
- logical(LK) :: compress_vectors = .false. !! If true, then arrays of integers,
- !! nulls, reals, & logicals are
- !! printed all on one line.
- !! [Note: `no_whitespace` will
- !! override this option if necessary]
-
- logical(LK) :: allow_duplicate_keys = .true. !! If False, then after parsing, if any
- !! duplicate keys are found, an error is
- !! thrown. A call to [[json_value_validate]]
- !! will also check for duplicates. If True
- !! [default] then no special checks are done
-
- logical(LK) :: escape_solidus = .false. !! If True then the solidus "`/`" is always escaped
- !! ("`\/`") when serializing JSON.
- !! If False [default], then it is not escaped.
- !! Note that this option does not affect parsing
- !! (both escaped and unescaped versions are still
- !! valid in all cases).
-
- integer(IK) :: null_to_real_mode = 2_IK !! if `strict_type_checking=false`:
- !!
- !! * 1 : an exception will be raised if
- !! try to retrieve a `null` as a real.
- !! * 2 : a `null` retrieved as a real
- !! will return NaN. [default]
- !! * 3 : a `null` retrieved as a real
- !! will return 0.0.
-
- logical(LK) :: non_normals_to_null = .false. !! How to serialize NaN, Infinity,
- !! and -Infinity real values:
- !!
- !! * If true : as JSON `null` values
- !! * If false : as strings (e.g., "NaN",
- !! "Infinity", "-Infinity") [default]
-
- logical(LK) :: use_quiet_nan = .true. !! if true [default], `null_to_real_mode=2`
- !! and [[string_to_real]] will use
- !! `ieee_quiet_nan` for NaN values. If false,
- !! `ieee_signaling_nan` will be used.
-
- logical(LK) :: strict_integer_type_checking = .true.
- !! * If false, when parsing JSON, if an integer numeric value
- !! cannot be converted to an integer (`integer(IK)`),
- !! then an attempt is then make to convert it
- !! to a real (`real(RK)`).
- !! * If true [default], an exception will be raised if an integer
- !! value cannot be read when parsing JSON.
-
- integer :: ichunk = 0 !! index in `chunk` for [[pop_char]]
- !! when `use_unformatted_stream=True`
- integer :: filesize = 0 !! the file size when when `use_unformatted_stream=True`
- character(kind=CK,len=:),allocatable :: chunk !! a chunk read from a stream file
- !! when `use_unformatted_stream=True`
-
- contains
-
- private
-
- !>
- ! Return a child of a [[json_value]] structure.
- generic,public :: get_child => json_value_get_child_by_index, &
- json_value_get_child,&
- json_value_get_child_by_name
- procedure,private :: json_value_get_child_by_index
- procedure,private :: json_value_get_child_by_name
- procedure,private :: json_value_get_child
-
- !>
- ! Add objects to a linked list of [[json_value]]s.
- !
- !@note It might make more sense to call this `add_child`.
- generic,public :: add => json_value_add_member, &
- json_value_add_null, &
- json_value_add_integer, &
- json_value_add_integer_vec, &
-
- json_value_add_real32, &
- json_value_add_real32_vec, &
-
- json_value_add_real, &
- json_value_add_real_vec, &
- # 326
-
- json_value_add_logical, &
- json_value_add_logical_vec, &
- json_value_add_string, &
- json_value_add_string_vec
- # 336
-
-
- procedure,private :: json_value_add_member
- procedure,private :: json_value_add_integer
- procedure,private :: json_value_add_null
- procedure,private :: json_value_add_integer_vec
-
- procedure,private :: json_value_add_real32
- procedure,private :: json_value_add_real32_vec
-
- procedure,private :: json_value_add_real
- procedure,private :: json_value_add_real_vec
- # 351
-
- procedure,private :: json_value_add_logical
- procedure,private :: json_value_add_logical_vec
- procedure,private :: json_value_add_string
- procedure,private :: json_value_add_string_vec
- # 361
-
-
- !>
- ! These are like the `add` methods, except if a variable with the
- ! same path is already present, then its value is simply updated.
- ! Note that currently, these only work for scalar variables.
- ! These routines can also change the variable's type (but an error will be
- ! thrown if the existing variable is not a scalar).
- !
- !### See also
- ! * [[json_core(type):add_by_path]] - this one can be used to change
- ! arrays and objects to scalars if so desired.
- !
- !@note Unlike some routines, the `found` output is not optional,
- ! so it doesn't present exceptions from being thrown.
- !
- !@note These have been mostly supplanted by the [[json_core(type):add_by_path]]
- ! methods, which do a similar thing (and can be used for
- ! scalars and vectors, etc.)
- generic,public :: update => json_update_logical,&
-
- json_update_real32,&
-
- json_update_real,&
- # 387
-
-
- json_update_integer,&
- json_update_string
- # 394
-
- procedure,private :: json_update_logical
-
- procedure,private :: json_update_real32
-
- procedure,private :: json_update_real
- # 402
-
- procedure,private :: json_update_integer
- procedure,private :: json_update_string
- # 408
-
-
- !>
- ! Add variables to a [[json_value]] linked list
- ! by specifying their paths.
- !
- !### Example
- !
- !````fortran
- ! use, intrinsic :: iso_fortran_env, only: output_unit
- ! use json_module, wp=>json_RK
- ! type(json_core) :: json
- ! type(json_value) :: p
- ! call json%create_object(p,'root') ! create the root
- ! ! now add some variables using the paths:
- ! call json%add_by_path(p,'inputs.t', 0.0_wp )
- ! call json%add_by_path(p,'inputs.x(1)', 100.0_wp)
- ! call json%add_by_path(p,'inputs.x(2)', 200.0_wp)
- ! call json%print(p) ! now print to console
- !````
- !
- !### Notes
- ! * This uses [[json_create_by_path]]
- !
- !### See also
- ! * The `json_core%update` methods.
- ! * [[json_create_by_path]]
-
- generic,public :: add_by_path => json_add_member_by_path,&
- json_add_integer_by_path,&
-
- json_add_real32_by_path,&
-
- json_add_real_by_path,&
- # 444
-
- json_add_logical_by_path,&
- json_add_string_by_path,&
- json_add_integer_vec_by_path,&
-
- json_add_real32_vec_by_path,&
-
- json_add_real_vec_by_path,&
- # 454
-
- json_add_logical_vec_by_path,&
- json_add_string_vec_by_path
- # 462
-
- procedure :: json_add_member_by_path
- procedure :: json_add_integer_by_path
-
- procedure :: json_add_real32_by_path
-
- procedure :: json_add_real_by_path
- # 471
-
- procedure :: json_add_logical_by_path
- procedure :: json_add_string_by_path
- procedure :: json_add_integer_vec_by_path
-
- procedure :: json_add_real32_vec_by_path
-
- procedure :: json_add_real_vec_by_path
- # 481
-
- procedure :: json_add_logical_vec_by_path
- procedure :: json_add_string_vec_by_path
- # 489
-
-
- !>
- ! Create a [[json_value]] linked list using the
- ! path to the variables. Optionally return a
- ! pointer to the variable.
- !
- ! (This will create a `null` variable)
- !
- !### See also
- ! * [[json_core(type):add_by_path]]
-
- generic,public :: create => json_create_by_path
- procedure :: json_create_by_path
-
- !>
- ! Get data from a [[json_value]] linked list.
- !
- !@note There are two versions (e.g. [[json_get_integer]] and [[json_get_integer_by_path]]).
- ! The first one gets the value from the [[json_value]] passed into the routine,
- ! while the second one gets the value from the [[json_value]] found by parsing the
- ! path. The path version is split up into unicode and non-unicode versions.
-
- generic,public :: get => &
- json_get_by_path, &
- json_get_integer, json_get_integer_by_path, &
- json_get_integer_vec, json_get_integer_vec_by_path, &
-
- json_get_real32, json_get_real32_by_path, &
- json_get_real32_vec, json_get_real32_vec_by_path, &
-
- json_get_real, json_get_real_by_path, &
- json_get_real_vec, json_get_real_vec_by_path, &
- # 525
-
- json_get_logical, json_get_logical_by_path, &
- json_get_logical_vec, json_get_logical_vec_by_path, &
- json_get_string, json_get_string_by_path, &
- json_get_string_vec, json_get_string_vec_by_path, &
- json_get_alloc_string_vec, json_get_alloc_string_vec_by_path,&
- json_get_array, json_get_array_by_path
-
- procedure,private :: json_get_integer
- procedure,private :: json_get_integer_vec
-
- procedure,private :: json_get_real32
- procedure,private :: json_get_real32_vec
-
- procedure,private :: json_get_real
- procedure,private :: json_get_real_vec
- # 544
-
- procedure,private :: json_get_logical
- procedure,private :: json_get_logical_vec
- procedure,private :: json_get_string
- procedure,private :: json_get_string_vec
- procedure,private :: json_get_alloc_string_vec
- procedure,private :: json_get_array
- procedure,private :: json_get_by_path
- procedure,private :: json_get_integer_by_path
- procedure,private :: json_get_integer_vec_by_path
-
- procedure,private :: json_get_real32_by_path
- procedure,private :: json_get_real32_vec_by_path
-
- procedure,private :: json_get_real_by_path
- procedure,private :: json_get_real_vec_by_path
- # 563
-
- procedure,private :: json_get_logical_by_path
- procedure,private :: json_get_logical_vec_by_path
- procedure,private :: json_get_string_by_path
- procedure,private :: json_get_string_vec_by_path
- procedure,private :: json_get_array_by_path
- procedure,private :: json_get_alloc_string_vec_by_path
- procedure,private :: json_get_by_path_default
- procedure,private :: json_get_by_path_rfc6901
- procedure,private :: json_get_by_path_jsonpath_bracket
-
- !>
- ! Print the [[json_value]] to an output unit or file.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value) :: p
- ! !...
- ! call json%print(p,'test.json') !this is [[json_print_to_filename]]
- !````
- generic,public :: print => json_print_to_console,&
- json_print_to_unit,&
- json_print_to_filename
- procedure :: json_print_to_console
- procedure :: json_print_to_unit
- procedure :: json_print_to_filename
-
- !>
- ! Destructor routine for a [[json_value]] pointer.
- ! This must be called explicitly if it is no longer needed,
- ! before it goes out of scope. Otherwise, a memory leak will result.
- !
- !### Example
- !
- ! Destroy the [[json_value]] pointer before the variable goes out of scope:
- !````fortran
- ! subroutine example1()
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_object(p,'')
- ! call json%add(p,'year',2015)
- ! call json%print(p)
- ! call json%destroy(p)
- ! end subroutine example1
- !````
- !
- ! Note: it should NOT be called for a [[json_value]] pointer than has already been
- ! added to another [[json_value]] structure, since doing so may render the
- ! other structure invalid. Consider the following example:
- !````fortran
- ! subroutine example2(p)
- ! type(json_core) :: json
- ! type(json_value),pointer,intent(out) :: p
- ! type(json_value),pointer :: q
- ! call json%create_object(p,'')
- ! call json%add(p,'year',2015)
- ! call json%create_object(q,'q')
- ! call json%add(q,'val',1)
- ! call json%add(p, q) !add q to p structure
- ! ! do NOT call json%destroy(q) here, because q is
- ! ! now part of the output structure p. p should be destroyed
- ! ! somewhere upstream by the caller of this routine.
- ! nullify(q) !OK, but not strictly necessary
- ! end subroutine example2
- !````
- generic,public :: destroy => json_value_destroy,destroy_json_core
- procedure :: json_value_destroy
- procedure :: destroy_json_core
-
- !>
- ! If the child variable is present, then remove it.
- generic,public :: remove_if_present => json_value_remove_if_present
- procedure :: json_value_remove_if_present
-
- !>
- ! Allocate a [[json_value]] pointer and make it a real variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_real(p,'value',1.0_RK)
- !````
- !
- !### Note
- ! * [[json_core(type):create_real]] is just an alias
- ! to this one for backward compatibility.
- generic,public :: create_real => json_value_create_real
- procedure :: json_value_create_real
-
- generic,public :: create_real => json_value_create_real32
- procedure :: json_value_create_real32
-
- # 663
-
-
- !>
- ! This is equivalent to [[json_core(type):create_real]],
- ! and is here only for backward compatibility.
- generic,public :: create_double => json_value_create_real
-
- generic,public :: create_double => json_value_create_real32
-
- # 674
-
-
- !>
- ! Allocate a [[json_value]] pointer and make it an array variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_array(p,'arrayname')
- !````
- generic,public :: create_array => json_value_create_array
- procedure :: json_value_create_array
-
- !>
- ! Allocate a [[json_value]] pointer and make it an object variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_object(p,'objectname')
- !````
- !
- !@note The name is not significant for the root structure or an array element.
- ! In those cases, an empty string can be used.
- generic,public :: create_object => json_value_create_object
- procedure :: json_value_create_object
-
- !>
- ! Allocate a json_value pointer and make it a null variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_null(p,'value')
- !````
- generic,public :: create_null => json_value_create_null
- procedure :: json_value_create_null
-
- !>
- ! Allocate a json_value pointer and make it a string variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_string(p,'value','foobar')
- !````
- generic,public :: create_string => json_value_create_string
- procedure :: json_value_create_string
-
- !>
- ! Allocate a json_value pointer and make it an integer variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_integer(p,42,'value')
- !````
- generic,public :: create_integer => json_value_create_integer
- procedure :: json_value_create_integer
-
- !>
- ! Allocate a json_value pointer and make it a logical variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%create_logical(p,'value',.true.)
- !````
- generic,public :: create_logical => json_value_create_logical
- procedure :: json_value_create_logical
-
- !>
- ! Parse the JSON file and populate the [[json_value]] tree.
- generic,public :: load => json_parse_file
- procedure :: json_parse_file
-
- !>
- ! Print the [[json_value]] structure to an allocatable string
- procedure,public :: serialize => json_value_to_string
-
- !>
- ! The same as `serialize`, but only here for backward compatibility
- procedure,public :: print_to_string => json_value_to_string
-
- !>
- ! Parse the JSON string and populate the [[json_value]] tree.
- generic,public :: deserialize => json_parse_string
- procedure :: json_parse_string
-
- !>
- ! Same as `load` and `deserialize` but only here for backward compatibility.
- generic,public :: parse => json_parse_file, &
- json_parse_string
-
- !>
- ! Throw an exception.
- generic,public :: throw_exception => json_throw_exception
- procedure :: json_throw_exception
-
- !>
- ! Rename a [[json_value]] variable.
- generic,public :: rename => json_value_rename,&
- json_rename_by_path
- procedure :: json_value_rename
- procedure :: json_rename_by_path
- # 802
-
-
- !>
- ! get info about a [[json_value]]
- generic,public :: info => json_info, json_info_by_path
- procedure :: json_info
- procedure :: json_info_by_path
-
- !>
- ! get string info about a [[json_value]]
- generic,public :: string_info => json_string_info
- procedure :: json_string_info
-
- !>
- ! get matrix info about a [[json_value]]
- generic,public :: matrix_info => json_matrix_info, json_matrix_info_by_path
- procedure :: json_matrix_info
- procedure :: json_matrix_info_by_path
-
- !>
- ! insert a new element after an existing one,
- ! updating the JSON structure accordingly
- generic,public :: insert_after => json_value_insert_after, &
- json_value_insert_after_child_by_index
- procedure :: json_value_insert_after
- procedure :: json_value_insert_after_child_by_index
-
- !>
- ! get the path to a JSON variable in a structure:
- generic,public :: get_path => json_get_path
- procedure :: json_get_path
-
- !>
- ! verify if a path is valid
- ! (i.e., a variable with this path exists in the file).
- generic,public :: valid_path => json_valid_path
- procedure :: json_valid_path
-
- procedure,public :: remove => json_value_remove !! Remove a [[json_value]] from a
- !! linked-list structure.
- procedure,public :: replace => json_value_replace !! Replace a [[json_value]] in a
- !! linked-list structure.
- procedure,public :: reverse => json_value_reverse !! Reverse the order of the children
- !! of an array of object.
- procedure,public :: check_for_errors => json_check_for_errors !! check for error and get error message
- procedure,public :: clear_exceptions => json_clear_exceptions !! clear exceptions
- procedure,public :: count => json_count !! count the number of children
- procedure,public :: clone => json_clone !! clone a JSON structure (deep copy)
- procedure,public :: failed => json_failed !! check for error
- procedure,public :: get_parent => json_get_parent !! get pointer to json_value parent
- procedure,public :: get_next => json_get_next !! get pointer to json_value next
- procedure,public :: get_previous => json_get_previous !! get pointer to json_value previous
- procedure,public :: get_tail => json_get_tail !! get pointer to json_value tail
- procedure,public :: initialize => json_initialize !! to initialize some parsing parameters
- procedure,public :: traverse => json_traverse !! to traverse all elements of a JSON
- !! structure
- procedure,public :: print_error_message => json_print_error_message !! simply routine to print error
- !! messages
- procedure,public :: swap => json_value_swap !! Swap two [[json_value]] pointers
- !! in a structure (or two different
- !! structures).
- procedure,public :: is_child_of => json_value_is_child_of !! Check if a [[json_value]] is a
- !! descendant of another.
- procedure,public :: validate => json_value_validate !! Check that a [[json_value]] linked
- !! list is valid (i.e., is properly
- !! constructed). This may be useful
- !! if it has been constructed externally.
- procedure,public :: check_for_duplicate_keys &
- => json_check_all_for_duplicate_keys !! Check entire JSON structure
- !! for duplicate keys (recursively)
- procedure,public :: check_children_for_duplicate_keys &
- => json_check_children_for_duplicate_keys !! Check a `json_value` object's
- !! children for duplicate keys
-
- !other private routines:
- procedure :: name_equal
- procedure :: name_strings_equal
- procedure :: json_value_print
- procedure :: string_to_int
- procedure :: string_to_dble
- procedure :: prepare_parser => json_prepare_parser
- procedure :: parse_end => json_parse_end
- procedure :: parse_value
- procedure :: parse_number
- procedure :: parse_string
- procedure :: parse_for_chars
- procedure :: parse_object
- procedure :: parse_array
- procedure :: annotate_invalid_json
- procedure :: pop_char
- procedure :: push_char
- procedure :: get_current_line_from_file_stream
- procedure,nopass :: get_current_line_from_file_sequential
- procedure :: convert
- procedure :: to_string
- procedure :: to_logical
- procedure :: to_integer
- procedure :: to_real
- procedure :: to_null
- procedure :: to_object
- procedure :: to_array
- procedure,nopass :: json_value_clone_func
- procedure :: is_vector => json_is_vector
-
- end type json_core
- !*********************************************************
-
- !*********************************************************
- !>
- ! Structure constructor to initialize a
- ! [[json_core(type)]] object
- !
- !### Example
- !
- !```fortran
- ! type(json_file) :: json_core
- ! json_core = json_core()
- !```
- interface json_core
- module procedure initialize_json_core
- end interface
- !*********************************************************
-
- !*************************************************************************************
- abstract interface
-
- subroutine json_array_callback_func(json, element, i, count)
- !! Array element callback function. Used by [[json_get_array]]
- import :: json_value,json_core,IK
- implicit none
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: element
- integer(IK),intent(in) :: i !! index
- integer(IK),intent(in) :: count !! size of array
- end subroutine json_array_callback_func
-
- subroutine json_traverse_callback_func(json,p,finished)
- !! Callback function used by [[json_traverse]]
- import :: json_value,json_core,LK
- implicit none
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- logical(LK),intent(out) :: finished !! set true to stop traversing
- end subroutine json_traverse_callback_func
-
- end interface
- public :: json_array_callback_func
- public :: json_traverse_callback_func
- !*************************************************************************************
-
- contains
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/17/2016
- !
- ! Destructor for the [[json_core(type)]] type.
-
- subroutine destroy_json_core(me)
-
- implicit none
-
- class(json_core),intent(out) :: me
-
- end subroutine destroy_json_core
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/26/2016
- !
- ! Function constructor for a [[json_core(type)]].
- ! This is just a wrapper for [[json_initialize]].
- !
- !@note [[initialize_json_core]], [[json_initialize]],
- ! [[initialize_json_core_in_file]], and [[initialize_json_file]]
- ! all have a similar interface.
-
- function initialize_json_core(&
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_initialize_dummy_arguments.inc" 1
- ! The dummy argument list for the various `initialize` subroutines.
- !
- ! See also: json_initialize_argument.inc
-
- verbose,&
- compact_reals,&
- print_signs,&
- real_format,&
- spaces_per_tab,&
- strict_type_checking,&
- trailing_spaces_significant,&
- case_sensitive_keys,&
- no_whitespace,&
- unescape_strings,&
- comment_char,&
- path_mode,&
- path_separator,&
- compress_vectors,&
- allow_duplicate_keys,&
- escape_solidus,&
- stop_on_error,&
- null_to_real_mode,&
- non_normal_mode,&
- use_quiet_nan, &
- strict_integer_type_checking &
- # 983 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
- ) result(json_core_object)
-
- implicit none
-
- type(json_core) :: json_core_object
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_initialize_arguments.inc" 1
- ! The argument list for the various `initialize` subroutines.
- !
- ! See also: json_initialize_dummy_arguments.inc
-
- logical(LK),intent(in),optional :: verbose
- !! mainly useful for debugging (default is false)
- logical(LK),intent(in),optional :: compact_reals
- !! to compact the real number strings for output (default is true)
- logical(LK),intent(in),optional :: print_signs
- !! always print numeric sign (default is false)
- character(kind=CDK,len=*),intent(in),optional :: real_format
- !! Real number format: 'E' [default], '*', 'G', 'EN', or 'ES'
- integer(IK),intent(in),optional :: spaces_per_tab
- !! number of spaces per tab for indenting (default is 2)
- logical(LK),intent(in),optional :: strict_type_checking
- !! if true, no integer, double, or logical type
- !! conversions are done for the `get` routines
- !! (default is false).
- logical(LK),intent(in),optional :: trailing_spaces_significant
- !! for name and path comparisons, is trailing
- !! space to be considered significant.
- !! (default is false)
- logical(LK),intent(in),optional :: case_sensitive_keys
- !! for name and path comparisons, are they
- !! case sensitive. (default is true)
- logical(LK),intent(in),optional :: no_whitespace
- !! if true, printing the JSON structure is
- !! done without adding any non-significant
- !! spaces or linebreaks (default is false)
- logical(LK),intent(in),optional :: unescape_strings
- !! If false, then the raw escaped
- !! string is returned from [[json_get_string]]
- !! and similar routines. If true [default],
- !! then the string is returned unescaped.
- character(kind=CK,len=*),intent(in),optional :: comment_char
- !! If present, these characters are used
- !! to denote comments in the JSON file,
- !! which will be ignored if present.
- !! Example: `!`, `#`, or `/!#`. Setting this
- !! to a blank string disables the
- !! ignoring of comments. (Default is `/!#`).
- integer(IK),intent(in),optional :: path_mode
- !! How the path strings are interpreted in the
- !! `get_by_path` routines:
- !!
- !! * 1 : Default mode (see [[json_get_by_path_default]])
- !! * 2 : as RFC 6901 "JSON Pointer" paths
- !! (see [[json_get_by_path_rfc6901]])
- !! * 3 : JSONPath "bracket-notation"
- !! see [[json_get_by_path_jsonpath_bracket]])
- character(kind=CK,len=1),intent(in),optional :: path_separator
- !! The `path` separator to use
- !! in the "default" mode for
- !! the paths in the various
- !! `get_by_path` routines.
- !! Example: `.` [default] or `%`.
- !! Note: if `path_mode/=1`
- !! then this is ignored.
- logical(LK),intent(in),optional :: compress_vectors
- !! If true, then arrays of integers,
- !! nulls, doubles, and logicals are
- !! printed all on one line.
- !! [Note: `no_whitespace` will
- !! override this option if necessary].
- !! (Default is False).
- logical(LK),intent(in),optional :: allow_duplicate_keys
- !! * If True [default] then no special checks
- !! are done to check for duplicate keys.
- !! * If False, then after parsing, if any duplicate
- !! keys are found, an error is thrown. A call to
- !! [[json_value_validate]] will also check for
- !! duplicates.
- logical(LK),intent(in),optional :: escape_solidus
- !! * If True then the solidus "`/`" is always escaped
- !! "`\/`" when serializing JSON
- !! * If False [default], then it is not escaped.
- !!
- !! Note that this option does not affect parsing
- !! (both escaped and unescaped are still valid in
- !! all cases).
- logical(LK),intent(in),optional :: stop_on_error
- !! If an exception is raised, then immediately quit.
- !! (Default is False).
- integer(IK),intent(in),optional :: null_to_real_mode
- !! if `strict_type_checking=false`:
- !!
- !! * 1 : an exception will be raised if
- !! try to retrieve a `null` as a real.
- !! * 2 : a `null` retrieved as a real
- !! will return a NaN. [default]
- !! * 3 : a `null` retrieved as a real
- !! will return 0.0.
- integer(IK),intent(in),optional :: non_normal_mode
- !! How to serialize NaN, Infinity, and
- !! -Infinity real values:
- !!
- !! * 1 : as strings (e.g., "NaN",
- !! "Infinity", "-Infinity") [default]
- !! * 2 : as JSON `null` values
- logical(LK),intent(in),optional :: use_quiet_nan
- !! * If true [default], `null_to_real_mode=2`
- !! and [[string_to_real]] will use
- !! `ieee_quiet_nan` for NaN values.
- !! * If false,
- !! `ieee_signaling_nan` will be used.
- logical(LK),intent(in),optional :: strict_integer_type_checking
- !! * If false, when parsing JSON, if an integer numeric value
- !! cannot be converted to an integer (`integer(IK)`),
- !! then an attempt is then make to convert it
- !! to a real (`real(RK)`).
- !! * If true, an exception will be raised if the integer
- !! value cannot be read.
- !!
- !! (default is true)
- # 989 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- call json_core_object%initialize(&
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_initialize_dummy_arguments.inc" 1
- ! The dummy argument list for the various `initialize` subroutines.
- !
- ! See also: json_initialize_argument.inc
-
- verbose,&
- compact_reals,&
- print_signs,&
- real_format,&
- spaces_per_tab,&
- strict_type_checking,&
- trailing_spaces_significant,&
- case_sensitive_keys,&
- no_whitespace,&
- unescape_strings,&
- comment_char,&
- path_mode,&
- path_separator,&
- compress_vectors,&
- allow_duplicate_keys,&
- escape_solidus,&
- stop_on_error,&
- null_to_real_mode,&
- non_normal_mode,&
- use_quiet_nan, &
- strict_integer_type_checking &
- # 992 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
- )
-
- end function initialize_json_core
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/4/2013
- !
- ! Initialize the [[json_core(type)]] instance.
- !
- ! The routine may be called before any of the [[json_core(type)]] methods are used in
- ! order to specify certain parameters. If it is not called, then the defaults
- ! are used. This routine is also called internally by various routines.
- ! It can also be called to clear exceptions, or to reset some
- ! of the variables (note that only the arguments present are changed).
- !
- !### Modified
- ! * Izaak Beekman : 02/24/2015
- !
- !@note [[initialize_json_core]], [[json_initialize]],
- ! [[initialize_json_core_in_file]], and [[initialize_json_file]]
- ! all have a similar interface.
-
- subroutine json_initialize(me,&
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_initialize_dummy_arguments.inc" 1
- ! The dummy argument list for the various `initialize` subroutines.
- !
- ! See also: json_initialize_argument.inc
-
- verbose,&
- compact_reals,&
- print_signs,&
- real_format,&
- spaces_per_tab,&
- strict_type_checking,&
- trailing_spaces_significant,&
- case_sensitive_keys,&
- no_whitespace,&
- unescape_strings,&
- comment_char,&
- path_mode,&
- path_separator,&
- compress_vectors,&
- allow_duplicate_keys,&
- escape_solidus,&
- stop_on_error,&
- null_to_real_mode,&
- non_normal_mode,&
- use_quiet_nan, &
- strict_integer_type_checking &
- # 1018 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
- )
-
- implicit none
-
- class(json_core),intent(inout) :: me
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_initialize_arguments.inc" 1
- ! The argument list for the various `initialize` subroutines.
- !
- ! See also: json_initialize_dummy_arguments.inc
-
- logical(LK),intent(in),optional :: verbose
- !! mainly useful for debugging (default is false)
- logical(LK),intent(in),optional :: compact_reals
- !! to compact the real number strings for output (default is true)
- logical(LK),intent(in),optional :: print_signs
- !! always print numeric sign (default is false)
- character(kind=CDK,len=*),intent(in),optional :: real_format
- !! Real number format: 'E' [default], '*', 'G', 'EN', or 'ES'
- integer(IK),intent(in),optional :: spaces_per_tab
- !! number of spaces per tab for indenting (default is 2)
- logical(LK),intent(in),optional :: strict_type_checking
- !! if true, no integer, double, or logical type
- !! conversions are done for the `get` routines
- !! (default is false).
- logical(LK),intent(in),optional :: trailing_spaces_significant
- !! for name and path comparisons, is trailing
- !! space to be considered significant.
- !! (default is false)
- logical(LK),intent(in),optional :: case_sensitive_keys
- !! for name and path comparisons, are they
- !! case sensitive. (default is true)
- logical(LK),intent(in),optional :: no_whitespace
- !! if true, printing the JSON structure is
- !! done without adding any non-significant
- !! spaces or linebreaks (default is false)
- logical(LK),intent(in),optional :: unescape_strings
- !! If false, then the raw escaped
- !! string is returned from [[json_get_string]]
- !! and similar routines. If true [default],
- !! then the string is returned unescaped.
- character(kind=CK,len=*),intent(in),optional :: comment_char
- !! If present, these characters are used
- !! to denote comments in the JSON file,
- !! which will be ignored if present.
- !! Example: `!`, `#`, or `/!#`. Setting this
- !! to a blank string disables the
- !! ignoring of comments. (Default is `/!#`).
- integer(IK),intent(in),optional :: path_mode
- !! How the path strings are interpreted in the
- !! `get_by_path` routines:
- !!
- !! * 1 : Default mode (see [[json_get_by_path_default]])
- !! * 2 : as RFC 6901 "JSON Pointer" paths
- !! (see [[json_get_by_path_rfc6901]])
- !! * 3 : JSONPath "bracket-notation"
- !! see [[json_get_by_path_jsonpath_bracket]])
- character(kind=CK,len=1),intent(in),optional :: path_separator
- !! The `path` separator to use
- !! in the "default" mode for
- !! the paths in the various
- !! `get_by_path` routines.
- !! Example: `.` [default] or `%`.
- !! Note: if `path_mode/=1`
- !! then this is ignored.
- logical(LK),intent(in),optional :: compress_vectors
- !! If true, then arrays of integers,
- !! nulls, doubles, and logicals are
- !! printed all on one line.
- !! [Note: `no_whitespace` will
- !! override this option if necessary].
- !! (Default is False).
- logical(LK),intent(in),optional :: allow_duplicate_keys
- !! * If True [default] then no special checks
- !! are done to check for duplicate keys.
- !! * If False, then after parsing, if any duplicate
- !! keys are found, an error is thrown. A call to
- !! [[json_value_validate]] will also check for
- !! duplicates.
- logical(LK),intent(in),optional :: escape_solidus
- !! * If True then the solidus "`/`" is always escaped
- !! "`\/`" when serializing JSON
- !! * If False [default], then it is not escaped.
- !!
- !! Note that this option does not affect parsing
- !! (both escaped and unescaped are still valid in
- !! all cases).
- logical(LK),intent(in),optional :: stop_on_error
- !! If an exception is raised, then immediately quit.
- !! (Default is False).
- integer(IK),intent(in),optional :: null_to_real_mode
- !! if `strict_type_checking=false`:
- !!
- !! * 1 : an exception will be raised if
- !! try to retrieve a `null` as a real.
- !! * 2 : a `null` retrieved as a real
- !! will return a NaN. [default]
- !! * 3 : a `null` retrieved as a real
- !! will return 0.0.
- integer(IK),intent(in),optional :: non_normal_mode
- !! How to serialize NaN, Infinity, and
- !! -Infinity real values:
- !!
- !! * 1 : as strings (e.g., "NaN",
- !! "Infinity", "-Infinity") [default]
- !! * 2 : as JSON `null` values
- logical(LK),intent(in),optional :: use_quiet_nan
- !! * If true [default], `null_to_real_mode=2`
- !! and [[string_to_real]] will use
- !! `ieee_quiet_nan` for NaN values.
- !! * If false,
- !! `ieee_signaling_nan` will be used.
- logical(LK),intent(in),optional :: strict_integer_type_checking
- !! * If false, when parsing JSON, if an integer numeric value
- !! cannot be converted to an integer (`integer(IK)`),
- !! then an attempt is then make to convert it
- !! to a real (`real(RK)`).
- !! * If true, an exception will be raised if the integer
- !! value cannot be read.
- !!
- !! (default is true)
- # 1024 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- character(kind=CDK,len=10) :: w !! max string length
- character(kind=CDK,len=10) :: d !! real precision digits
- character(kind=CDK,len=10) :: e !! real exponent digits
- character(kind=CDK,len=2) :: sgn !! sign flag: `ss` or `sp`
- character(kind=CDK,len=2) :: rl_edit_desc !! `G`, `E`, `EN`, or `ES`
- integer(IK) :: istat !! `iostat` flag for
- !! write statements
- logical(LK) :: sgn_prnt !! print sign flag
- character(kind=CK,len=max_integer_str_len) :: istr !! for integer to
- !! string conversion
-
- !reset exception to false:
- call me%clear_exceptions()
-
- !Just in case, clear these global variables also:
- me%pushed_index = 0
- me%pushed_char = CK_''
- me%char_count = 0
- me%line_count = 1
- me%ipos = 1
- if (use_unformatted_stream) then
- me%filesize = 0
- me%ichunk = 0
- me%chunk = repeat(space, stream_chunk_size) ! default chunk size
- end if
-
- # 1055
-
-
- !various optional inputs:
- if (present(spaces_per_tab)) &
- me%spaces_per_tab = spaces_per_tab
- if (present(stop_on_error)) &
- me%stop_on_error = stop_on_error
- if (present(verbose)) &
- me%is_verbose = verbose
- if (present(strict_type_checking)) &
- me%strict_type_checking = strict_type_checking
- if (present(trailing_spaces_significant)) &
- me%trailing_spaces_significant = trailing_spaces_significant
- if (present(case_sensitive_keys)) &
- me%case_sensitive_keys = case_sensitive_keys
- if (present(no_whitespace)) &
- me%no_whitespace = no_whitespace
- if (present(unescape_strings)) &
- me%unescaped_strings = unescape_strings
- if (present(path_mode)) then
- if (path_mode==1_IK .or. path_mode==2_IK .or. path_mode==3_IK) then
- me%path_mode = path_mode
- else
- me%path_mode = 1_IK ! just to have a valid value
- call me%throw_exception('Invalid path_mode.')
- end if
- end if
-
- ! if we are allowing comments in the file:
- ! [an empty string disables comments]
- if (present(comment_char)) then
- me%allow_comments = comment_char/=CK_''
- me%comment_char = trim(adjustl(comment_char))
- end if
-
- ! path separator:
- if (present(path_separator)) then
- me%path_separator = path_separator
- end if
-
- ! printing vectors in compressed form:
- if (present(compress_vectors)) then
- me%compress_vectors = compress_vectors
- end if
-
- ! checking for duplicate keys:
- if (present(allow_duplicate_keys)) then
- me%allow_duplicate_keys = allow_duplicate_keys
- end if
-
- ! if escaping the forward slash:
- if (present(escape_solidus)) then
- me%escape_solidus = escape_solidus
- end if
-
- ! how to handle null to read conversions:
- if (present(null_to_real_mode)) then
- select case (null_to_real_mode)
- case(1_IK:3_IK)
- me%null_to_real_mode = null_to_real_mode
- case default
- me%null_to_real_mode = 2_IK ! just to have a valid value
- call integer_to_string(null_to_real_mode,int_fmt,istr)
- call me%throw_exception('Invalid null_to_real_mode: '//istr)
- end select
- end if
-
- ! how to handle NaN and Infinities:
- if (present(non_normal_mode)) then
- select case (non_normal_mode)
- case(1_IK) ! use strings
- me%non_normals_to_null = .false.
- case(2_IK) ! use null
- me%non_normals_to_null = .true.
- case default
- call integer_to_string(non_normal_mode,int_fmt,istr)
- call me%throw_exception('Invalid non_normal_mode: '//istr)
- end select
- end if
-
- if (present(use_quiet_nan)) then
- me%use_quiet_nan = use_quiet_nan
- end if
-
- if (present(strict_integer_type_checking)) then
- me%strict_integer_type_checking = strict_integer_type_checking
- end if
-
- !Set the format for real numbers:
- ! [if not changing it, then it remains the same]
-
- if ( (.not. allocated(me%real_fmt)) .or. & ! if this hasn't been done yet
- present(compact_reals) .or. &
- present(print_signs) .or. &
- present(real_format) ) then
-
- !allow the special case where real format is '*':
- ! [this overrides the other options]
- if (present(real_format)) then
- if (real_format==star) then
- if (present(compact_reals)) then
- ! we will also allow for compact reals with
- ! '*' format, if both arguments are present.
- me%compact_real = compact_reals
- else
- me%compact_real = .false.
- end if
- me%real_fmt = star
- return
- end if
- end if
-
- if (present(compact_reals)) me%compact_real = compact_reals
-
- !set defaults
- sgn_prnt = .false.
- if ( present( print_signs) ) sgn_prnt = print_signs
- if ( sgn_prnt ) then
- sgn = 'sp'
- else
- sgn = 'ss'
- end if
-
- rl_edit_desc = 'E'
- if ( present( real_format ) ) then
- select case ( real_format )
- case ('g','G','e','E','en','EN','es','ES')
- rl_edit_desc = real_format
- case default
- call me%throw_exception('Invalid real format, "' // &
- trim(real_format) // '", passed to json_initialize.'// &
- new_line('a') // 'Acceptable formats are: "G", "E", "EN", and "ES".' )
- end select
- end if
-
- ! set the default output/input format for reals:
- write(w,'(ss,I0)',iostat=istat) max_numeric_str_len
- if (istat==0) write(d,'(ss,I0)',iostat=istat) real_precision
- if (istat==0) write(e,'(ss,I0)',iostat=istat) real_exponent_digits
- if (istat==0) then
- me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) //&
- trim(w) // '.' // trim(d) // 'E' // trim(e) // ')'
- else
- me%real_fmt = '(' // sgn // ',' // trim(rl_edit_desc) // &
- '27.17E4)' !just use this one (should never happen)
- end if
-
- end if
-
- end subroutine json_initialize
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Returns true if `name` is equal to `p%name`, using the specified
- ! settings for case sensitivity and trailing whitespace.
- !
- !### History
- ! * 4/30/2016 : original version
- ! * 8/25/2017 : now just a wrapper for [[name_strings_equal]]
-
- function name_equal(json,p,name) result(is_equal)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),intent(in) :: p !! the json object
- character(kind=CK,len=*),intent(in) :: name !! the name to check for
- logical(LK) :: is_equal !! true if the string are
- !! lexically equal
-
- if (allocated(p%name)) then
- ! call the low-level routines for the name strings:
- is_equal = json%name_strings_equal(p%name,name)
- else
- is_equal = name == CK_'' ! check a blank name
- end if
-
- end function name_equal
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 8/25/2017
- !
- ! Returns true if the name strings `name1` is equal to `name2`, using
- ! the specified settings for case sensitivity and trailing whitespace.
-
- function name_strings_equal(json,name1,name2) result(is_equal)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- character(kind=CK,len=*),intent(in) :: name1 !! the name to check
- character(kind=CK,len=*),intent(in) :: name2 !! the name to check
- logical(LK) :: is_equal !! true if the string are
- !! lexically equal
-
- !must be the same length if we are treating
- !trailing spaces as significant, so do a
- !quick test of this first:
- if (json%trailing_spaces_significant) then
- is_equal = len(name1) == len(name2)
- if (.not. is_equal) return
- end if
-
- if (json%case_sensitive_keys) then
- is_equal = name1 == name2
- else
- is_equal = lowercase_string(name1) == lowercase_string(name2)
- end if
-
- end function name_strings_equal
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 10/31/2015
- !
- ! Create a deep copy of a [[json_value]] linked-list structure.
- !
- !### Notes
- !
- ! * If `from` has children, then they are also cloned.
- ! * The parent of `from` is not linked to `to`.
- ! * If `from` is an element of an array, then the previous and
- ! next entries are not cloned (only that element and it's children, if any).
- !
- !### Example
- !
- !````fortran
- ! program test
- ! use json_module
- ! implicit none
- ! type(json_core) :: json
- ! type(json_value),pointer :: j1, j2
- ! call json%load('../files/inputs/test1.json',j1)
- ! call json%clone(j1,j2) !now have two independent copies
- ! call json%destroy(j1) !destroys j1, but j2 remains
- ! call json%print(j2,'j2.json')
- ! call json%destroy(j2)
- ! end program test
- !````
-
- subroutine json_clone(json,from,to)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: from !! this is the structure to clone
- type(json_value),pointer :: to !! the clone is put here
- !! (it must not already be associated)
-
- !call the main function:
- call json%json_value_clone_func(from,to)
-
- end subroutine json_clone
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 10/31/2015
- !
- ! Recursive deep copy function called by [[json_clone]].
- !
- !@note If new data is added to the [[json_value]] type,
- ! then this would need to be updated.
-
- recursive subroutine json_value_clone_func(from,to,parent,previous,tail)
-
- implicit none
-
- type(json_value),pointer :: from !! this is the structure to clone
- type(json_value),pointer :: to !! the clone is put here (it
- !! must not already be associated)
- type(json_value),pointer,optional :: parent !! to%parent
- type(json_value),pointer,optional :: previous !! to%previous
- logical,optional :: tail !! if "to" is the tail of
- !! its parent's children
-
- nullify(to)
-
- if (associated(from)) then
-
- allocate(to)
-
- !copy over the data variables:
- ! [note: the allocate() statements don't work here for the
- ! deferred-length characters in gfortran-4.9]
- if (allocated(from%name)) to%name = from%name
- if (allocated(from%dbl_value)) allocate(to%dbl_value,source=from%dbl_value)
- if (allocated(from%log_value)) allocate(to%log_value,source=from%log_value)
- if (allocated(from%str_value)) to%str_value = from%str_value
- if (allocated(from%int_value)) allocate(to%int_value,source=from%int_value)
- to%var_type = from%var_type
- to%n_children = from%n_children
-
- ! allocate and associate the pointers as necessary:
- if (present(parent)) to%parent => parent
- if (present(previous)) to%previous => previous
- if (present(tail)) then
- if (tail .and. associated(to%parent)) to%parent%tail => to
- end if
-
- if (associated(from%next) .and. associated(to%parent)) then
- ! we only clone the next entry in an array
- ! if the parent has also been cloned
- call json_value_clone_func(from = from%next,&
- to = to%next,&
- previous = to,&
- parent = to%parent,&
- tail = (.not. associated(from%next%next)))
- end if
-
- if (associated(from%children)) then
- call json_value_clone_func(from = from%children,&
- to = to%children,&
- parent = to,&
- tail = (.not. associated(from%children%next)))
- end if
-
- end if
-
- end subroutine json_value_clone_func
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Destroy the data within a [[json_value]], and reset type to `json_unknown`.
-
- pure subroutine destroy_json_data(d)
-
- implicit none
-
- type(json_value),intent(inout) :: d
-
- d%var_type = json_unknown
-
- if (allocated(d%log_value)) deallocate(d%log_value)
- if (allocated(d%int_value)) deallocate(d%int_value)
- if (allocated(d%dbl_value)) deallocate(d%dbl_value)
- if (allocated(d%str_value)) deallocate(d%str_value)
-
- end subroutine destroy_json_data
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 2/13/2014
- !
- ! Returns information about a [[json_value]].
-
- subroutine json_info(json,p,var_type,n_children,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- integer(IK),intent(out),optional :: var_type !! variable type
- integer(IK),intent(out),optional :: n_children !! number of children
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
-
- if (.not. json%exception_thrown .and. associated(p)) then
-
- if (present(var_type)) var_type = p%var_type
- if (present(n_children)) n_children = json%count(p)
- if (present(name)) then
- if (allocated(p%name)) then
- name = p%name
- else
- name = CK_''
- end if
- end if
-
- else ! error
-
- if (.not. json%exception_thrown) then
- call json%throw_exception('Error in json_info: '//&
- 'pointer is not associated.' )
- end if
- if (present(var_type)) var_type = json_unknown
- if (present(n_children)) n_children = 0
- if (present(name)) name = CK_''
-
- end if
-
- end subroutine json_info
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/18/2016
- !
- ! Returns information about character strings returned from a [[json_value]].
-
- subroutine json_string_info(json,p,ilen,max_str_len,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- integer(IK),dimension(:),allocatable,intent(out),optional :: ilen !! if `p` is an array, this
- !! is the actual length
- !! of each character
- !! string in the array.
- !! if not an array, this
- !! is returned unallocated.
- integer(IK),intent(out),optional :: max_str_len !! The maximum length required to
- !! hold the string representation returned
- !! by a call to a `get` routine. If a scalar,
- !! this is just the length of the scalar. If
- !! a vector, this is the maximum length of
- !! any element.
- logical(LK),intent(out),optional :: found !! true if there were no errors.
- !! if not present, an error will
- !! throw an exception
-
- character(kind=CK,len=:),allocatable :: cval !! for getting values as strings.
- logical(LK) :: initialized !! if the output array has been sized
- logical(LK) :: get_max_len !! if we are returning the `max_str_len`
- logical(LK) :: get_ilen !! if we are returning the `ilen` array
- integer(IK) :: var_type !! variable type
-
- get_max_len = present(max_str_len)
- get_ilen = present(ilen)
-
- if (.not. json%exception_thrown) then
-
- if (present(found)) found = .true.
- initialized = .false.
-
- if (get_max_len) max_str_len = 0
-
- select case (p%var_type)
-
- case (json_array) ! it's an array
-
- ! call routine for each element
- call json%get(p, array_callback=get_string_lengths)
-
- case default ! not an array
-
- if (json%strict_type_checking) then
- ! only allowing strings to be returned
- ! as strings, so we can check size directly
- call json%info(p,var_type=var_type)
- if (var_type==json_string) then
- if (allocated(p%str_value) .and. get_max_len) &
- max_str_len = len(p%str_value)
- else
- ! it isn't a string, so there is no length
- call json%throw_exception('Error in json_string_info: '//&
- 'When strict_type_checking is true '//&
- 'the variable must be a character string.',&
- found)
- end if
- else
- ! in this case, we have to get the value
- ! as a string to know what size it is.
- call json%get(p, value=cval)
- if (.not. json%exception_thrown) then
- if (allocated(cval) .and. get_max_len) &
- max_str_len = len(cval)
- end if
- end if
-
- end select
-
- end if
-
- if (json%exception_thrown) then
- if (present(found)) then
- call json%clear_exceptions()
- found = .false.
- end if
- if (get_max_len) max_str_len = 0
- if (get_ilen) then
- if (allocated(ilen)) deallocate(ilen)
- end if
- end if
-
- contains
-
- subroutine get_string_lengths(json, element, i, count)
-
- !! callback function to call for each element in the array.
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: element
- integer(IK),intent(in) :: i !! index
- integer(IK),intent(in) :: count !! size of array
-
- character(kind=CK,len=:),allocatable :: cval
- integer(IK) :: var_type
-
- if (json%exception_thrown) return
-
- if (.not. initialized) then
- if (get_ilen) allocate(ilen(count))
- initialized = .true.
- end if
-
- if (json%strict_type_checking) then
- ! only allowing strings to be returned
- ! as strings, so we can check size directly
- call json%info(element,var_type=var_type)
- if (var_type==json_string) then
- if (allocated(element%str_value)) then
- if (get_max_len) then
- if (len(element%str_value)>max_str_len) &
- max_str_len = len(element%str_value)
- end if
- if (get_ilen) ilen(i) = len(element%str_value)
- else
- if (get_ilen) ilen(i) = 0
- end if
- else
- ! it isn't a string, so there is no length
- call json%throw_exception('Error in json_string_info: '//&
- 'When strict_type_checking is true '//&
- 'the array must contain only '//&
- 'character strings.',found)
- end if
- else
- ! in this case, we have to get the value
- ! as a string to know what size it is.
- call json%get(element, value=cval)
- if (json%exception_thrown) return
- if (allocated(cval)) then
- if (get_max_len) then
- if (len(cval)>max_str_len) max_str_len = len(cval)
- end if
- if (get_ilen) ilen(i) = len(cval)
- else
- if (get_ilen) ilen(i) = 0
- end if
- end if
-
- end subroutine get_string_lengths
-
- end subroutine json_string_info
- !*****************************************************************************************
-
- !*****************************************************************************************
- !
- ! Returns information about a [[json_value]], given the path.
- !
- !### See also
- ! * [[json_info]]
- !
- !@note If `found` is present, no exceptions will be thrown if an
- ! error occurs. Otherwise, an exception will be thrown if the
- ! variable is not found.
-
- subroutine json_info_by_path(json,p,path,found,var_type,n_children,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- logical(LK),intent(out),optional :: found !! true if it was found
- integer(IK),intent(out),optional :: var_type !! variable type
- integer(IK),intent(out),optional :: n_children !! number of children
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
-
- type(json_value),pointer :: p_var !! temporary pointer
- logical(LK) :: ok !! if the variable was found
- # 1629
-
-
- call json%get(p,path,p_var,found)
-
- !check if it was found:
- if (present(found)) then
- ok = found
- else
- ok = .not. json%exception_thrown
- end if
-
- if (.not. ok) then
- if (present(var_type)) var_type = json_unknown
- if (present(n_children)) n_children = 0
- if (present(name)) name = CK_''
- else
- !get info:
-
- # 1657
-
- call json%info(p_var,var_type,n_children,name)
-
-
- end if
-
- end subroutine json_info_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_info_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_info_by_path(json,p,path,found,var_type,n_children,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! a JSON linked list
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable
- logical(LK),intent(out),optional :: found !! true if it was found
- integer(IK),intent(out),optional :: var_type !! variable type
- integer(IK),intent(out),optional :: n_children !! number of children
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
-
- call json%info(p,to_unicode(path),found,var_type,n_children,name)
-
- end subroutine wrap_json_info_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 10/16/2015
- !
- ! Alternate version of [[json_info]] that returns matrix
- ! information about a [[json_value]].
- !
- ! A [[json_value]] is a valid rank 2 matrix if all of the following are true:
- !
- ! * The var_type is *json_array*
- ! * Each child is also a *json_array*, each of which has the same number of elements
- ! * Each individual element has the same variable type (integer, logical, etc.)
- !
- ! The idea here is that if it is a valid matrix, it can be interoperable with
- ! a Fortran rank 2 array of the same type.
- !
- !### Example
- !
- ! The following example is an array with `var_type=json_integer`,
- ! `n_sets=3`, and `set_size=4`
- !
- !```json
- ! {
- ! "matrix": [
- ! [1,2,3,4],
- ! [5,6,7,8],
- ! [9,10,11,12]
- ! ]
- ! }
- !```
-
- subroutine json_matrix_info(json,p,is_matrix,var_type,n_sets,set_size,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! a JSON linked list
- logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
- integer(IK),intent(out),optional :: var_type !! variable type of data in the matrix
- !! (if all elements have the same type)
- integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
- !! rows if using row-major order)
- integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
- !! cols if using row-major order)
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
-
- type(json_value),pointer :: p_row !! for getting a set
- type(json_value),pointer :: p_element !! for getting an element in a set
- integer(IK) :: vartype !! json variable type of `p`
- integer(IK) :: row_vartype !! json variable type of a row
- integer(IK) :: element_vartype !! json variable type of an element in a row
- integer(IK) :: nr !! number of children of `p`
- integer(IK) :: nc !! number of elements in first child of `p`
- integer(IK) :: icount !! number of elements in a set
- integer(IK) :: i !! counter
- integer(IK) :: j !! counter
- # 1745
-
-
- !get info about the variable:
- # 1758
-
- call json%info(p,vartype,nr,name)
-
-
- is_matrix = (vartype==json_array)
-
- if (is_matrix) then
-
- main : do i=1,nr
-
- nullify(p_row)
- call json%get_child(p,i,p_row)
- if (.not. associated(p_row)) then
- is_matrix = .false.
- call json%throw_exception('Error in json_matrix_info: '//&
- 'Malformed JSON linked list')
- exit main
- end if
- call json%info(p_row,var_type=row_vartype,n_children=icount)
-
- if (row_vartype==json_array) then
- if (i==1) nc = icount !number of columns in first row
- if (icount==nc) then !make sure each row has the same number of columns
- !see if all the variables in this row are the same type:
- do j=1,icount
- nullify(p_element)
- call json%get_child(p_row,j,p_element)
- if (.not. associated(p_element)) then
- is_matrix = .false.
- call json%throw_exception('Error in json_matrix_info: '//&
- 'Malformed JSON linked list')
- exit main
- end if
- call json%info(p_element,var_type=element_vartype)
- if (i==1 .and. j==1) vartype = element_vartype !type of first element
- !in the row
- if (vartype/=element_vartype) then
- !not all variables are the same time
- is_matrix = .false.
- exit main
- end if
- end do
- else
- is_matrix = .false.
- exit main
- end if
- else
- is_matrix = .false.
- exit main
- end if
-
- end do main
-
- end if
-
- if (is_matrix) then
- if (present(var_type)) var_type = vartype
- if (present(n_sets)) n_sets = nr
- if (present(set_size)) set_size = nc
- else
- if (present(var_type)) var_type = json_unknown
- if (present(n_sets)) n_sets = 0
- if (present(set_size)) set_size = 0
- end if
-
- end subroutine json_matrix_info
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns matrix information about a [[json_value]], given the path.
- !
- !### See also
- ! * [[json_matrix_info]]
- !
- !@note If `found` is present, no exceptions will be thrown if an
- ! error occurs. Otherwise, an exception will be thrown if the
- ! variable is not found.
-
- subroutine json_matrix_info_by_path(json,p,path,is_matrix,found,&
- var_type,n_sets,set_size,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
- logical(LK),intent(out),optional :: found !! true if it was found
- integer(IK),intent(out),optional :: var_type !! variable type of data in
- !! the matrix (if all elements have
- !! the same type)
- integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
- !! rows if using row-major order)
- integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
- !! cols if using row-major order)
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
-
- type(json_value),pointer :: p_var
- logical(LK) :: ok
- # 1860
-
-
- call json%get(p,path,p_var,found)
-
- !check if it was found:
- if (present(found)) then
- ok = found
- else
- ok = .not. json%exception_thrown
- end if
-
- if (.not. ok) then
- if (present(var_type)) var_type = json_unknown
- if (present(n_sets)) n_sets = 0
- if (present(set_size)) set_size = 0
- if (present(name)) name = CK_''
- else
-
- !get info about the variable:
- # 1889
-
- call json%matrix_info(p_var,is_matrix,var_type,n_sets,set_size,name)
-
- if (json%exception_thrown .and. present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- end if
-
- end subroutine json_matrix_info_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_matrix_info_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_matrix_info_by_path(json,p,path,is_matrix,found,&
- var_type,n_sets,set_size,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! a JSON linked list
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable
- logical(LK),intent(out) :: is_matrix !! true if it is a valid matrix
- logical(LK),intent(out),optional :: found !! true if it was found
- integer(IK),intent(out),optional :: var_type !! variable type of data in
- !! the matrix (if all elements have
- !! the same type)
- integer(IK),intent(out),optional :: n_sets !! number of data sets (i.e., matrix
- !! rows if using row-major order)
- integer(IK),intent(out),optional :: set_size !! size of each data set (i.e., matrix
- !! cols if using row-major order)
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! variable name
-
- call json%matrix_info(p,to_unicode(path),is_matrix,found,var_type,n_sets,set_size,name)
-
- end subroutine wrap_json_matrix_info_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/29/2016
- !
- ! Rename a [[json_value]].
-
- subroutine json_value_rename(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- character(kind=CK,len=*),intent(in) :: name !! new variable name
-
- if (json%trailing_spaces_significant) then
- p%name = name
- else
- p%name = trim(name)
- end if
-
- end subroutine json_value_rename
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/29/2016
- !
- ! Alternate version of [[json_value_rename]], where `name` is kind=CDK.
-
- subroutine wrap_json_value_rename(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- character(kind=CDK,len=*),intent(in) :: name !! new variable name
-
- call json%rename(p,to_unicode(name))
-
- end subroutine wrap_json_value_rename
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/4/2013
- !
- ! Clear exceptions in the [[json_core(type)]].
-
- pure subroutine json_clear_exceptions(json)
-
- implicit none
-
- class(json_core),intent(inout) :: json
-
- !clear the flag and message:
- json%exception_thrown = .false.
- if (allocated(json%err_message)) deallocate(json%err_message)
-
- end subroutine json_clear_exceptions
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/4/2013
- !
- ! Throw an exception in the [[json_core(type)]].
- ! This routine sets the error flag, and prevents any subsequent routine
- ! from doing anything, until [[json_clear_exceptions]] is called.
- !
- !@note If `is_verbose` is true, this will also print a
- ! traceback if the Intel compiler is used.
- !
- !@note If `stop_on_error` is true, then the program is stopped.
-
- subroutine json_throw_exception(json,msg,found)
-
-
- use ifcore, only: tracebackqq
-
-
- implicit none
-
- class(json_core),intent(inout) :: json
- character(kind=CK,len=*),intent(in) :: msg !! the error message
- logical(LK),intent(inout),optional :: found !! if the caller is handling the
- !! exception with an optimal return
- !! argument. If so, `json%stop_on_error`
- !! is ignored.
-
- logical(LK) :: stop_on_error
-
- json%exception_thrown = .true.
- json%err_message = trim(msg)
- stop_on_error = json%stop_on_error .and. .not. present(found)
-
- if (stop_on_error) then
-
-
- ! for Intel, we raise a traceback and quit
- call tracebackqq(string=trim(msg), user_exit_code=0)
- # 2032
-
-
- elseif (json%is_verbose) then
-
- write(output_unit,'(A)') '***********************'
- write(output_unit,'(A)') 'JSON-Fortran Exception: '//trim(msg)
-
- !#if defined __GFORTRAN__
- ! call backtrace() ! (have to compile with -fbacktrace -fall-intrinsics flags)
- !#endif
-
-
- call tracebackqq(user_exit_code=-1) ! print a traceback and return
-
-
- write(output_unit,'(A)') '***********************'
-
- end if
-
- end subroutine json_throw_exception
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_throw_exception]], where `msg` is kind=CDK.
-
- subroutine wrap_json_throw_exception(json,msg,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- character(kind=CDK,len=*),intent(in) :: msg !! the error message
- logical(LK),intent(inout),optional :: found !! if the caller is handling the
- !! exception with an optimal return
- !! argument. If so, `json%stop_on_error`
- !! is ignored.
-
- call json%throw_exception(to_unicode(msg),found)
-
- end subroutine wrap_json_throw_exception
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/4/2013
- !
- ! Retrieve error code from the [[json_core(type)]].
- ! This should be called after `parse` to check for errors.
- ! If an error is thrown, before using the class again, [[json_initialize]]
- ! should be called to clean up before it is used again.
- !
- !### Example
- !
- !````fortran
- ! type(json_file) :: json
- ! logical :: status_ok
- ! character(kind=CK,len=:),allocatable :: error_msg
- ! call json%load(filename='myfile.json')
- ! call json%check_for_errors(status_ok, error_msg)
- ! if (.not. status_ok) then
- ! write(*,*) 'Error: '//error_msg
- ! call json%clear_exceptions()
- ! call json%destroy()
- ! end if
- !````
- !
- !### See also
- ! * [[json_failed]]
- ! * [[json_throw_exception]]
-
- subroutine json_check_for_errors(json,status_ok,error_msg)
-
- implicit none
-
- class(json_core),intent(in) :: json
- logical(LK),intent(out),optional :: status_ok !! true if there were no errors
- character(kind=CK,len=:),allocatable,intent(out),optional :: error_msg !! the error message.
- !! (not allocated if
- !! there were no errors)
-
- # 2114
-
-
- if (present(status_ok)) status_ok = .not. json%exception_thrown
-
- if (present(error_msg)) then
- if (json%exception_thrown) then
- ! if an exception has been thrown,
- ! then this will always be allocated
- ! [see json_throw_exception]
- # 2126
-
- error_msg = json%err_message
-
- end if
- end if
-
- end subroutine json_check_for_errors
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/5/2013
- !
- ! Logical function to indicate if an exception has been thrown in a [[json_core(type)]].
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! logical :: status_ok
- ! character(len=:),allocatable :: error_msg
- ! call json%load(filename='myfile.json',p)
- ! if (json%failed()) then
- ! call json%check_for_errors(status_ok, error_msg)
- ! write(*,*) 'Error: '//error_msg
- ! call json%clear_exceptions()
- ! call json%destroy(p)
- ! end if
- !````
- !
- ! Note that [[json_file]] contains a wrapper for this routine, which is used like:
- !````fortran
- ! type(json_file) :: f
- ! logical :: status_ok
- ! character(len=:),allocatable :: error_msg
- ! call f%load(filename='myfile.json')
- ! if (f%failed()) then
- ! call f%check_for_errors(status_ok, error_msg)
- ! write(*,*) 'Error: '//error_msg
- ! call f%clear_exceptions()
- ! call f%destroy()
- ! end if
- !````
- !
- !### See also
- ! * [[json_check_for_errors]]
-
- pure function json_failed(json) result(failed)
-
- implicit none
-
- class(json_core),intent(in) :: json
- logical(LK) :: failed !! will be true if an exception
- !! has been thrown.
-
- failed = json%exception_thrown
-
- end function json_failed
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Allocate a [[json_value]] pointer variable.
- ! This should be called before adding data to it.
- !
- !### Example
- !
- !````fortran
- ! type(json_value),pointer :: var
- ! call json_value_create(var)
- ! call json%to_real(var,1.0_RK)
- !````
- !
- !### Notes
- ! 1. This routine does not check for exceptions.
- ! 2. The pointer should not already be allocated, or a memory leak will occur.
-
- subroutine json_value_create(p)
-
- implicit none
-
- type(json_value),pointer :: p
-
- nullify(p)
- allocate(p)
-
- end subroutine json_value_create
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/22/2014
- !
- ! Destroy a [[json_value]] linked-list structure.
- !
- !@note The original FSON version of this
- ! routine was not properly freeing the memory.
- ! It was rewritten.
- !
- !@note This routine destroys this variable, it's children, and
- ! (if `destroy_next` is true) the subsequent elements in
- ! an object or array. It does not destroy the parent or
- ! previous elements.
- !
- !@Note There is some protection here to enable destruction of
- ! improperly-created linked lists. However, likely there
- ! are cases not handled. Use the [[json_value_validate]]
- ! method to validate a JSON structure that was manually
- ! created using [[json_value]] pointers.
-
- pure recursive subroutine json_value_destroy(json,p,destroy_next)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! variable to destroy
- logical(LK),intent(in),optional :: destroy_next !! if true, then `p%next`
- !! is also destroyed (default is true)
-
- logical(LK) :: des_next !! local copy of `destroy_next`
- !! optional argument
- type(json_value),pointer :: child !! for getting child elements
- logical :: circular !! to check to malformed linked lists
-
- if (associated(p)) then
-
- if (present(destroy_next)) then
- des_next = destroy_next
- else
- des_next = .true.
- end if
-
- if (allocated(p%name)) deallocate(p%name)
-
- call destroy_json_data(p)
-
- if (associated(p%next)) then
- ! check for circular references:
- if (associated(p, p%next)) nullify(p%next)
- end if
-
- if (associated(p%children)) then
- do while (p%n_children > 0)
- child => p%children
- if (associated(child)) then
- p%children => p%children%next
- p%n_children = p%n_children - 1
- ! check children for circular references:
- circular = (associated(p%children) .and. &
- associated(p%children,child))
- call json%destroy(child,destroy_next=.false.)
- if (circular) exit
- else
- ! it is a malformed JSON object. But, we will
- ! press ahead with the destroy process, since
- ! otherwise, there would be no way to destroy it.
- exit
- end if
- end do
- nullify(p%children)
- nullify(child)
- end if
-
- if (associated(p%next) .and. des_next) call json%destroy(p%next)
-
- nullify(p%previous)
- nullify(p%parent)
- nullify(p%tail)
-
- if (associated(p)) deallocate(p)
- nullify(p)
-
- end if
-
- end subroutine json_value_destroy
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 9/9/2014
- !
- ! Remove a [[json_value]] (and all its children)
- ! from a linked-list structure, preserving the rest of the structure.
- !
- !### Examples
- !
- ! To extract an object from one JSON structure, and add it to another:
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: json1,json2,p
- ! logical :: found
- ! !create and populate json1 and json2
- ! call json%get(json1,'name',p,found) ! get pointer to name element of json1
- ! call json%remove(p,destroy=.false.) ! remove it from json1 (don't destroy)
- ! call json%add(json2,p) ! add it to json2
- !````
- !
- ! To remove an object from a JSON structure (and destroy it):
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: json1,p
- ! logical :: found
- ! !create and populate json1
- ! call json%get(json1,'name',p,found) ! get pointer to name element of json1
- ! call json%remove(p) ! remove and destroy it
- !````
- !
- !### History
- ! * Jacob Williams : 12/28/2014 : added destroy optional argument.
- ! * Jacob Williams : 12/04/2020 : bug fix.
-
- subroutine json_value_remove(json,p,destroy)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- logical(LK),intent(in),optional :: destroy !! Option to destroy `p` after it is removed:
- !!
- !! * If `destroy` is not present, it is also destroyed.
- !! * If `destroy` is present and true, it is destroyed.
- !! * If `destroy` is present and false, it is not destroyed.
-
- type(json_value),pointer :: parent !! pointer to parent
- type(json_value),pointer :: previous !! pointer to previous
- type(json_value),pointer :: next !! pointer to next
- logical(LK) :: destroy_it !! if `p` should be destroyed
-
- if (associated(p)) then
-
- !optional input argument:
- if (present(destroy)) then
- destroy_it = destroy
- else
- destroy_it = .true.
- end if
-
- if (associated(p%parent)) then
-
- parent => p%parent
-
- if (associated(p%next)) then
-
- !there are later items in the list:
- next => p%next
-
- if (associated(p%previous)) then
- !there are earlier items in the list
- previous => p%previous
- previous%next => next
- next%previous => previous
- else
- !this is the first item in the list
- parent%children => next
- nullify(next%previous)
- end if
-
- else
-
- if (associated(p%previous)) then
- !there are earlier items in the list:
- previous => p%previous
- nullify(previous%next)
- parent%tail => previous
- else
- !this is the only item in the list:
- nullify(parent%children)
- nullify(parent%tail)
- end if
-
- end if
-
- ! nullify all pointers to original structure:
- nullify(p%next)
- nullify(p%previous)
- nullify(p%parent)
-
- parent%n_children = parent%n_children - 1
-
- end if
-
- if (destroy_it) call json%destroy(p)
-
- end if
-
- end subroutine json_value_remove
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Replace `p1` with `p2` in a JSON structure.
- !
- !@note The replacement is done using an insert and remove
- ! See [[json_value_insert_after]] and [[json_value_remove]]
- ! for details.
-
- subroutine json_value_replace(json,p1,p2,destroy)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p1 !! the item to replace
- type(json_value),pointer :: p2 !! item to take the place of `p1`
- logical(LK),intent(in),optional :: destroy !! Should `p1` also be destroyed
- !! (default is True). Normally,
- !! this should be true to avoid
- !! a memory leak.
-
- logical(LK) :: destroy_p1 !! if `p1` is to be destroyed
-
- if (present(destroy)) then
- destroy_p1 = destroy
- else
- destroy_p1 = .true. ! default
- end if
-
- call json%insert_after(p1,p2)
- call json%remove(p1,destroy_p1)
-
- end subroutine json_value_replace
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/11/2017
- !
- ! Reverse the order of the children of an array or object.
-
- subroutine json_value_reverse(json,p)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
-
- type(json_value),pointer :: tmp !! temp variable for traversing the list
- type(json_value),pointer :: current !! temp variable for traversing the list
- integer(IK) :: var_type !! for getting the variable type
-
- if (associated(p)) then
-
- call json%info(p,var_type=var_type)
-
- ! can only reverse objects or arrays
- if (var_type==json_object .or. var_type==json_array) then
-
- nullify(tmp)
- current => p%children
- p%tail => current
-
- ! Swap next and previous for all nodes:
- do
- if (.not. associated(current)) exit
- tmp => current%previous
- current%previous => current%next
- current%next => tmp
- current => current%previous
- end do
-
- if (associated(tmp)) then
- p%children => tmp%previous
- end if
-
- end if
-
- end if
-
- end subroutine json_value_reverse
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/26/2016
- !
- ! Swap two elements in a JSON structure.
- ! All of the children are carried along as well.
- !
- !@note If both are not associated, then an error is thrown.
- !
- !@note The assumption here is that both variables are part of a valid
- ! [[json_value]] linked list (so the normal `parent`, `previous`,
- ! `next`, etc. pointers are properly associated if necessary).
- !
- !@warning This cannot be used to swap a parent/child pair, since that
- ! could lead to a circular linkage. An exception is thrown if
- ! this is tried.
- !
- !@warning There are also other situations where using this routine may
- ! produce a malformed JSON structure, such as moving an array
- ! element outside of an array. This is not checked for.
- !
- !@note If `p1` and `p2` have a common parent, it is always safe to swap them.
-
- subroutine json_value_swap(json,p1,p2)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p1 !! swap with `p2`
- type(json_value),pointer :: p2 !! swap with `p1`
-
- logical :: same_parent !! if `p1` and `p2` have the same parent
- logical :: first_last !! if `p1` and `p2` are the first,last or
- !! last,first children of a common parent
- logical :: adjacent !! if `p1` and `p2` are adjacent
- !! elements in an array
- type(json_value),pointer :: a !! temporary variable
- type(json_value),pointer :: b !! temporary variable
-
- if (json%exception_thrown) return
-
- !both have to be associated:
- if (associated(p1) .and. associated(p2)) then
-
- !simple check to make sure that they both
- !aren't pointing to the same thing:
- if (.not. associated(p1,p2)) then
-
- !we will not allow swapping an item with one of its descendants:
- if (json%is_child_of(p1,p2) .or. json%is_child_of(p2,p1)) then
- call json%throw_exception('Error in json_value_swap: '//&
- 'cannot swap an item with one of its descendants')
- else
-
- same_parent = ( associated(p1%parent) .and. &
- associated(p2%parent) .and. &
- associated(p1%parent,p2%parent) )
- if (same_parent) then
- first_last = (associated(p1%parent%children,p1) .and. &
- associated(p2%parent%tail,p2)) .or. &
- (associated(p1%parent%tail,p1) .and. &
- associated(p2%parent%children,p2))
- else
- first_last = .false.
- end if
-
- !first, we fix children,tail pointers:
-
- if (same_parent .and. first_last) then
-
- !this is all we have to do for the parent in this case:
- call swap_pointers(p1%parent%children,p2%parent%tail)
-
- else if (same_parent .and. .not. first_last) then
-
- if (associated(p1%parent%children,p1)) then
- p1%parent%children => p2 ! p1 is the first child of the parent
- else if (associated(p1%parent%children,p2)) then
- p1%parent%children => p1 ! p2 is the first child of the parent
- end if
- if (associated(p1%parent%tail,p1)) then
- p1%parent%tail => p2 ! p1 is the last child of the parent
- else if (associated(p1%parent%tail,p2)) then
- p1%parent%tail => p1 ! p2 is the last child of the parent
- end if
-
- else ! general case: different parents
-
- if (associated(p1%parent)) then
- if (associated(p1%parent%children,p1)) p1%parent%children => p2
- if (associated(p1%parent%tail,p1)) p1%parent%tail => p2
- end if
- if (associated(p2%parent)) then
- if (associated(p2%parent%children,p2)) p2%parent%children => p1
- if (associated(p2%parent%tail,p2)) p2%parent%tail => p1
- end if
- call swap_pointers(p1%parent, p2%parent)
-
- end if
-
- !now, have to fix previous,next pointers:
-
- !first, see if they are adjacent:
- adjacent = associated(p1%next,p2) .or. &
- associated(p2%next,p1)
- if (associated(p2%next,p1)) then !p2,p1
- a => p2
- b => p1
- else !p1,p2 (or not adjacent)
- a => p1
- b => p2
- end if
- if (associated(a%previous)) a%previous%next => b
- if (associated(b%next)) b%next%previous => a
-
- if (adjacent) then
- !a comes before b in the original list
- b%previous => a%previous
- a%next => b%next
- a%previous => b
- b%next => a
- else
- if (associated(a%next)) a%next%previous => b
- if (associated(b%previous)) b%previous%next => a
- call swap_pointers(a%previous,b%previous)
- call swap_pointers(a%next, b%next)
- end if
-
- end if
-
- else
- call json%throw_exception('Error in json_value_swap: '//&
- 'both pointers must be associated')
- end if
-
- end if
-
- contains
-
- pure subroutine swap_pointers(s1,s2)
-
- implicit none
-
- type(json_value),pointer,intent(inout) :: s1
- type(json_value),pointer,intent(inout) :: s2
-
- type(json_value),pointer :: tmp !! temporary pointer
-
- if (.not. associated(s1,s2)) then
- tmp => s1
- s1 => s2
- s2 => tmp
- end if
-
- end subroutine swap_pointers
-
- end subroutine json_value_swap
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/28/2016
- !
- ! Returns True if `p2` is a descendant of `p1`
- ! (i.e, a child, or a child of child, etc.)
-
- function json_value_is_child_of(json,p1,p2) result(is_child_of)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p1
- type(json_value),pointer :: p2
- logical(LK) :: is_child_of
-
- is_child_of = .false.
-
- if (json%exception_thrown) return
-
- if (associated(p1) .and. associated(p2)) then
- if (associated(p1%children)) then
- call json%traverse(p1%children,is_child_of_callback)
- end if
- end if
-
- contains
-
- subroutine is_child_of_callback(json,p,finished)
- !! Traverse until `p` is `p2`.
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- logical(LK),intent(out) :: finished
-
- is_child_of = associated(p,p2)
- finished = is_child_of ! stop searching if found
-
- end subroutine is_child_of_callback
-
- end function json_value_is_child_of
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 5/2/2016
- !
- ! Validate a [[json_value]] linked list by checking to make sure
- ! all the pointers are properly associated, arrays and objects
- ! have the correct number of children, and the correct data is
- ! allocated for the variable types.
- !
- ! It recursively traverses the entire structure and checks every element.
- !
- !### History
- ! * Jacob Williams, 8/26/2017 : added duplicate key check.
- !
- !@note It will return on the first error it encounters.
- !
- !@note This routine does not check or throw any exceptions.
- ! If `json` is currently in a state of exception, it will
- ! remain so after calling this routine.
-
- subroutine json_value_validate(json,p,is_valid,error_msg)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- logical(LK),intent(out) :: is_valid !! True if the structure is valid.
- character(kind=CK,len=:),allocatable,intent(out) :: error_msg !! if not valid, this will contain
- !! a description of the problem
-
- logical(LK) :: has_duplicate !! to check for duplicate keys
- character(kind=CK,len=:),allocatable :: path !! path to duplicate key
- logical(LK) :: status_ok !! to check for existing exception
- character(kind=CK,len=:),allocatable :: exception_msg !! error message for an existing exception
- character(kind=CK,len=:),allocatable :: exception_msg2 !! error message for a new exception
-
- if (associated(p)) then
-
- is_valid = .true.
- call check_if_valid(p,require_parent=associated(p%parent))
-
- if (is_valid .and. .not. json%allow_duplicate_keys) then
- ! if no errors so far, also check the
- ! entire structure for duplicate keys:
-
- ! note: check_for_duplicate_keys does call routines
- ! that check and throw exceptions, so let's clear any
- ! first. (save message for later)
- call json%check_for_errors(status_ok, exception_msg)
- call json%clear_exceptions()
-
- call json%check_for_duplicate_keys(p,has_duplicate,path=path)
- if (json%failed()) then
- ! if an exception was thrown during this call,
- ! then clear it but make that the error message
- ! returned by this routine. Normally this should
- ! never actually occur since we have already
- ! validated the structure.
- call json%check_for_errors(is_valid, exception_msg2)
- error_msg = exception_msg2
- call json%clear_exceptions()
- is_valid = .false.
- else
- if (has_duplicate) then
- error_msg = 'duplicate key found: '//path
- is_valid = .false.
- end if
- end if
-
- if (.not. status_ok) then
- ! restore any existing exception if necessary
- call json%throw_exception(exception_msg)
- end if
-
- ! cleanup:
- if (allocated(path)) deallocate(path)
- if (allocated(exception_msg)) deallocate(exception_msg)
- if (allocated(exception_msg2)) deallocate(exception_msg2)
-
- end if
-
- else
- error_msg = 'The pointer is not associated'
- is_valid = .false.
- end if
-
- contains
-
- recursive subroutine check_if_valid(p,require_parent)
-
- implicit none
-
- type(json_value),pointer,intent(in) :: p
- logical,intent(in) :: require_parent !! the first one may be a root (so no parent),
- !! but all descendants must have a parent.
-
- integer(IK) :: i !! counter
- type(json_value),pointer :: element
- type(json_value),pointer :: previous
-
- if (is_valid .and. associated(p)) then
-
- ! data type:
- select case (p%var_type)
- case(json_null,json_object,json_array)
- if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
- allocated(p%dbl_value) .or. allocated(p%str_value)) then
- error_msg = 'incorrect data allocated for '//&
- 'json_null, json_object, or json_array variable type'
- is_valid = .false.
- return
- end if
- case(json_logical)
- if (.not. allocated(p%log_value)) then
- error_msg = 'log_value should be allocated for json_logical variable type'
- is_valid = .false.
- return
- else if (allocated(p%int_value) .or. &
- allocated(p%dbl_value) .or. allocated(p%str_value)) then
- error_msg = 'incorrect data allocated for json_logical variable type'
- is_valid = .false.
- return
- end if
- case(json_integer)
- if (.not. allocated(p%int_value)) then
- error_msg = 'int_value should be allocated for json_integer variable type'
- is_valid = .false.
- return
- else if (allocated(p%log_value) .or. &
- allocated(p%dbl_value) .or. allocated(p%str_value)) then
- error_msg = 'incorrect data allocated for json_integer variable type'
- is_valid = .false.
- return
- end if
- case(json_real)
- if (.not. allocated(p%dbl_value)) then
- error_msg = 'dbl_value should be allocated for json_real variable type'
- is_valid = .false.
- return
- else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
- allocated(p%str_value)) then
- error_msg = 'incorrect data allocated for json_real variable type'
- is_valid = .false.
- return
- end if
- case(json_string)
- if (.not. allocated(p%str_value)) then
- error_msg = 'str_value should be allocated for json_string variable type'
- is_valid = .false.
- return
- else if (allocated(p%log_value) .or. allocated(p%int_value) .or. &
- allocated(p%dbl_value)) then
- error_msg = 'incorrect data allocated for json_string variable type'
- is_valid = .false.
- return
- end if
- case default
- error_msg = 'invalid JSON variable type'
- is_valid = .false.
- return
- end select
-
- if (require_parent .and. .not. associated(p%parent)) then
- error_msg = 'parent pointer is not associated'
- is_valid = .false.
- return
- end if
-
- if (.not. allocated(p%name)) then
- if (associated(p%parent)) then
- if (p%parent%var_type/=json_array) then
- error_msg = 'JSON variable must have a name if not an '//&
- 'array element or the root'
- is_valid = .false.
- return
- end if
- end if
- end if
-
- if (associated(p%children) .neqv. associated(p%tail)) then
- error_msg = 'both children and tail pointers must be associated'
- is_valid = .false.
- return
- end if
-
- ! now, check next one:
- if (associated(p%next)) then
- if (associated(p,p%next)) then
- error_msg = 'circular linked list'
- is_valid = .false.
- return
- else
- ! if it's an element in an
- ! array, then require a parent:
- call check_if_valid(p%next,require_parent=.true.)
- end if
- end if
-
- if (associated(p%children)) then
-
- if (p%var_type/=json_array .and. p%var_type/=json_object) then
- error_msg = 'only arrays and objects can have children'
- is_valid = .false.
- return
- end if
-
- ! first validate children pointers:
-
- previous => null()
- element => p%children
- do i = 1_IK, p%n_children
- if (.not. associated(element%parent,p)) then
- error_msg = 'child''s parent pointer not properly associated'
- is_valid = .false.
- return
- end if
- if (i==1 .and. associated(element%previous)) then
- error_msg = 'first child shouldn''t have a previous'
- is_valid = .false.
- return
- end if
- if (i<p%n_children .and. .not. associated(element%next)) then
- error_msg = 'not enough children'
- is_valid = .false.
- return
- end if
- if (i==p%n_children .and. associated(element%next)) then
- error_msg = 'too many children'
- is_valid = .false.
- return
- end if
- if (i>1) then
- if (.not. associated(previous,element%previous)) then
- error_msg = 'previous pointer not properly associated'
- is_valid = .false.
- return
- end if
- end if
- if (i==p%n_children .and. &
- .not. associated(element%parent%tail,element)) then
- error_msg = 'parent''s tail pointer not properly associated'
- is_valid = .false.
- return
- end if
- if (i<p%n_children) then
- !setup next case:
- previous => element
- element => element%next
- end if
- end do
-
- !now check all the children:
- call check_if_valid(p%children,require_parent=.true.)
-
- end if
-
- end if
-
- end subroutine check_if_valid
-
- end subroutine json_value_validate
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/6/2014
- !
- ! Given the path string, remove the variable
- ! from [[json_value]], if it exists.
-
- subroutine json_value_remove_if_present(json,p,path)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable to remove
-
- type(json_value),pointer :: p_var
- logical(LK) :: found
-
- call json%get(p,path,p_var,found)
- if (found) call json%remove(p_var)
-
- end subroutine json_value_remove_if_present
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_remove_if_present]], where `path` is kind=CDK.
-
- subroutine wrap_json_value_remove_if_present(json,p,path)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: path
-
- call json%remove_if_present(p,to_unicode(path))
-
- end subroutine wrap_json_value_remove_if_present
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/6/2014
- !
- ! Given the path string, if the variable is present,
- ! and is a scalar, then update its value.
- ! If it is not present, then create it and set its value.
- !
- !@note If the variable is not a scalar, an exception will be thrown.
-
- subroutine json_update_logical(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
- logical(LK),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- type(json_value),pointer :: p_var
- integer(IK) :: var_type
-
- call json%get(p,path,p_var,found)
- if (found) then
-
- call json%info(p_var,var_type)
- select case (var_type)
- case (json_null,json_logical,json_integer,json_real,json_string)
- call json%to_logical(p_var,val) !update the value
- case default
- found = .false.
- call json%throw_exception('Error in json_update_logical: '//&
- 'the variable is not a scalar value',found)
- end select
-
- else
- call json%add_by_path(p,path,val) !add the new element
- end if
-
- end subroutine json_update_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_logical]], where `path` is kind=CDK.
-
- subroutine wrap_json_update_logical(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
- logical(LK),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- call json%update(p,to_unicode(path),val,found)
-
- end subroutine wrap_json_update_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/6/2014
- !
- ! Given the path string, if the variable is present,
- ! and is a scalar, then update its value.
- ! If it is not present, then create it and set its value.
- !
- !@note If the variable is not a scalar, an exception will be thrown.
-
- subroutine json_update_real(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
- real(RK),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- type(json_value),pointer :: p_var
- integer(IK) :: var_type
-
- call json%get(p,path,p_var,found)
- if (found) then
-
- call json%info(p_var,var_type)
- select case (var_type)
- case (json_null,json_logical,json_integer,json_real,json_string)
- call json%to_real(p_var,val) !update the value
- case default
- found = .false.
- call json%throw_exception('Error in json_update_real: '//&
- 'the variable is not a scalar value',found)
- end select
-
- else
- call json%add_by_path(p,path,val) !add the new element
- end if
-
- end subroutine json_update_real
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_real]], where `path` is kind=CDK.
-
- subroutine wrap_json_update_real(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
- real(RK),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- call json%update(p,to_unicode(path),val,found)
-
- end subroutine wrap_json_update_real
- !*****************************************************************************************
-
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_real]], where `val` is `real32`.
-
- subroutine json_update_real32(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
- real(real32),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- call json%update(p,path,real(val,RK),found)
-
- end subroutine json_update_real32
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_real32]], where `path` is kind=CDK.
-
- subroutine wrap_json_update_real32(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
- real(real32),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- call json%update(p,to_unicode(path),real(val,RK),found)
-
- end subroutine wrap_json_update_real32
- !*****************************************************************************************
-
-
- # 3206
-
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/6/2014
- !
- ! Given the path string, if the variable is present,
- ! and is a scalar, then update its value.
- ! If it is not present, then create it and set its value.
- !
- !@note If the variable is not a scalar, an exception will be thrown.
-
- subroutine json_update_integer(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
- integer(IK),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- type(json_value),pointer :: p_var
- integer(IK) :: var_type
-
- call json%get(p,path,p_var,found)
- if (found) then
-
- call json%info(p_var,var_type)
- select case (var_type)
- case (json_null,json_logical,json_integer,json_real,json_string)
- call json%to_integer(p_var,val) !update the value
- case default
- found = .false.
- call json%throw_exception('Error in json_update_integer: '//&
- 'the variable is not a scalar value',found)
- end select
-
- else
- call json%add_by_path(p,path,val) !add the new element
- end if
-
- end subroutine json_update_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_integer]], where `path` is kind=CDK.
-
- subroutine wrap_json_update_integer(json,p,path,val,found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
- integer(IK),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
-
- call json%update(p,to_unicode(path),val,found)
-
- end subroutine wrap_json_update_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/6/2014
- !
- ! Given the path string, if the variable is present,
- ! and is a scalar, then update its value.
- ! If it is not present, then create it and set its value.
- !
- !@note If the variable is not a scalar, an exception will be thrown.
-
- subroutine json_update_string(json,p,path,val,found,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: path !! path to the variable in the structure
- character(kind=CK,len=*),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- !! (only used if `val` is present)
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
- !! (only used if `val` is present)
- !! (note that ADJUSTL is done before TRIM)
-
- type(json_value),pointer :: p_var
- integer(IK) :: var_type
-
- call json%get(p,path,p_var,found)
- if (found) then
-
- call json%info(p_var,var_type)
- select case (var_type)
- case (json_null,json_logical,json_integer,json_real,json_string)
- call json%to_string(p_var,val,trim_str=trim_str,adjustl_str=adjustl_str) ! update the value
- case default
- found = .false.
- call json%throw_exception('Error in json_update_string: '//&
- 'the variable is not a scalar value',found)
- end select
-
- else
- call json%add_by_path(p,path,val) !add the new element
- end if
-
- end subroutine json_update_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_string]], where `path` and `value` are kind=CDK.
-
- subroutine wrap_json_update_string(json,p,path,val,found,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
- character(kind=CDK,len=*),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- !! (only used if `val` is present)
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
- !! (only used if `val` is present)
- !! (note that ADJUSTL is done before TRIM)
-
- call json%update(p,to_unicode(path),to_unicode(val),found,trim_str,adjustl_str)
-
- end subroutine wrap_json_update_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_string]], where `path` is kind=CDK.
-
- subroutine json_update_string_name_ascii(json,p,path,val,found,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable in the structure
- character(kind=CK, len=*),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- !! (only used if `val` is present)
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
- !! (only used if `val` is present)
- !! (note that ADJUSTL is done before TRIM)
-
- call json%update(p,to_unicode(path),val,found,trim_str,adjustl_str)
-
- end subroutine json_update_string_name_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_update_string]], where `val` is kind=CDK.
-
- subroutine json_update_string_val_ascii(json,p,path,val,found,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK, len=*),intent(in) :: path !! path to the variable in the structure
- character(kind=CDK,len=*),intent(in) :: val !! the new value
- logical(LK),intent(out) :: found !! if the variable was found and was a scalar.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- !! (only used if `val` is present)
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
- !! (only used if `val` is present)
- !! (note that ADJUSTL is done before TRIM)
-
- call json%update(p,path,to_unicode(val),found,trim_str,adjustl_str)
-
- end subroutine json_update_string_val_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Adds `member` as a child of `p`.
-
- subroutine json_value_add_member(json,p,member)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! `p` must be a `json_object`
- !! or a `json_array`
- type(json_value),pointer :: member !! the child member
- !! to add to `p`
-
- integer(IK) :: var_type !! variable type of `p`
-
- if (.not. json%exception_thrown) then
-
- if (associated(p)) then
-
- call json%info(p,var_type=var_type)
-
- select case (var_type)
- case(json_object, json_array)
-
- ! associate the parent
- member%parent => p
-
- ! add to linked list
- if (associated(p%children)) then
- p%tail%next => member
- member%previous => p%tail
- else
- p%children => member
- member%previous => null() !first in the list
- end if
-
- ! new member is now the last one in the list
- p%tail => member
- p%n_children = p%n_children + 1
-
- case default
- call json%throw_exception('Error in json_value_add_member: '//&
- 'can only add child to object or array')
- end select
-
- else
- call json%throw_exception('Error in json_value_add_member: '//&
- 'the pointer is not associated')
- end if
-
- end if
-
- end subroutine json_value_add_member
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Inserts `element` after `p`, and updates the JSON structure accordingly.
- !
- !### Example
- !
- !````fortran
- ! program test
- ! use json_module
- ! implicit none
- ! logical(json_LK) :: found
- ! type(json_core) :: json
- ! type(json_value),pointer :: p,new,element
- ! call json%load(file='myfile.json', p=p)
- ! call json%get(p,'x(3)',element,found) ! get pointer to an array element in the file
- ! call json%create_integer(new,1,'') ! create a new element
- ! call json%insert_after(element,new) ! insert new element after x(3)
- ! call json%print(p,'myfile2.json') ! write it to a file
- ! call json%destroy(p) ! cleanup
- ! end program test
- !````
- !
- !### Details
- !
- ! * This routine can be used to insert a new element (or set of elements)
- ! into an array or object at a specific index.
- ! See [[json_value_insert_after_child_by_index]]
- ! * Children and subsequent elements of `element` are carried along.
- ! * If the inserted elements are part of an existing list, then
- ! they are removed from that list.
- !
- !````
- ! p
- ! [1] - [2] - [3] - [4]
- ! |
- ! [5] - [6] - [7] n=3 elements inserted
- ! element last
- !
- ! Result is:
- !
- ! [1] - [2] - [5] - [6] - [7] - [3] - [4]
- !
- !````
-
- subroutine json_value_insert_after(json,p,element)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! a value from a JSON structure
- !! (presumably, this is a child of
- !! an object or array).
- type(json_value),pointer :: element !! the element to insert after `p`
-
- type(json_value),pointer :: parent !! the parent of `p`
- type(json_value),pointer :: next !! temp pointer for traversing structure
- type(json_value),pointer :: last !! the last of the items being inserted
- integer :: n !! number of items being inserted
-
- if (.not. json%exception_thrown) then
-
- parent => p%parent
-
- ! set first parent of inserted list:
- element%parent => parent
-
- ! Count the number of inserted elements.
- ! and set their parents.
- n = 1 ! initialize counter
- next => element%next
- last => element
- do
- if (.not. associated(next)) exit
- n = n + 1
- next%parent => parent
- last => next
- next => next%next
- end do
-
- if (associated(parent)) then
- ! update parent's child counter:
- parent%n_children = parent%n_children + n
- ! if p is last of parents children then
- ! also have to update parent tail pointer:
- if (associated(parent%tail,p)) then
- parent%tail => last
- end if
- end if
-
- if (associated(element%previous)) then
- ! element is apparently part of an existing list,
- ! so have to update that as well.
- if (associated(element%previous%parent)) then
- element%previous%parent%n_children = &
- element%previous%parent%n_children - n
- element%previous%parent%tail => &
- element%previous ! now the last one in the list
- else
- ! this would be a memory leak if the previous entries
- ! are not otherwise being pointed too
- ! [throw an error in this case???]
- end if
- !remove element from the other list:
- element%previous%next => null()
- end if
- element%previous => p
-
- if (associated(p%next)) then
- ! if there are any in the list after p:
- last%next => p%next
- last%next%previous => element
- else
- last%next => null()
- end if
- p%next => element
-
- end if
-
- end subroutine json_value_insert_after
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Inserts `element` after the `idx`-th child of `p`,
- ! and updates the JSON structure accordingly. This is just
- ! a wrapper for [[json_value_insert_after]].
-
- subroutine json_value_insert_after_child_by_index(json,p,idx,element)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! a JSON object or array.
- integer(IK),intent(in) :: idx !! the index of the child of `p` to
- !! insert the new element after
- !! (this is a 1-based Fortran
- !! style array index)
- type(json_value),pointer :: element !! the element to insert
-
- type(json_value),pointer :: tmp !! for getting the `idx`-th child of `p`
-
- if (.not. json%exception_thrown) then
-
- ! get the idx-th child of p:
- call json%get_child(p,idx,tmp)
-
- ! call json_value_insert_after:
- if (.not. json%exception_thrown) call json%insert_after(tmp,element)
-
- end if
-
- end subroutine json_value_insert_after_child_by_index
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Add a new member (`json_value` pointer) to a JSON structure, given the path.
- !
- !@warning If the path points to an existing variable in the structure,
- ! then this routine will destroy it and replace it with the
- ! new value.
-
- subroutine json_add_member_by_path(json,me,path,p,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- type(json_value),pointer,intent(in) :: p !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- type(json_value),pointer :: tmp
- character(kind=CK,len=:),allocatable :: name !! name of the variable
-
- if ( .not. json%exception_thrown ) then
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in json_add_member_by_path:'//&
- ' Input pointer p is not associated.',found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- if ( present(was_created) ) was_created = .false.
- else
-
- ! return a pointer to the path (possibly creating it)
- call json%create(me,path,tmp,found,was_created)
-
- if (.not. associated(tmp)) then
-
- call json%throw_exception('Error in json_add_member_by_path:'//&
- ' Unable to resolve path: '//trim(path),found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
-
- else
-
- call json%info(tmp,name=name)
-
- ! replace it with the new one:
- call json%replace(tmp,p,destroy=.true.)
- call json%rename(p,name)
-
- end if
-
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_member_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_member_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_add_member_by_path(json,me,path,p,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- type(json_value),pointer,intent(in) :: p !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%json_add_member_by_path(me,to_unicode(path),p,found,was_created)
-
- end subroutine wrap_json_add_member_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Add an integer value to a [[json_value]], given the path.
- !
- !@warning If the path points to an existing variable in the structure,
- ! then this routine will destroy it and replace it with the
- ! new value.
-
- subroutine json_add_integer_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- integer(IK),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- type(json_value),pointer :: p
- type(json_value),pointer :: tmp
- character(kind=CK,len=:),allocatable :: name !! variable name
-
- if ( .not. json%exception_thrown ) then
-
- nullify(p)
-
- ! return a pointer to the path (possibly creating it)
- ! If the variable had to be created, then
- ! it will be a json_null variable.
- call json%create(me,path,p,found,was_created)
-
- if (.not. associated(p)) then
-
- call json%throw_exception('Error in json_add_integer_by_path:'//&
- ' Unable to resolve path: '//trim(path),found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
-
- else
-
- !NOTE: a new object is created, and the old one
- ! is replaced and destroyed. This is to
- ! prevent memory leaks if the type is
- ! being changed (for example, if an array
- ! is being replaced with a scalar).
-
- if (p%var_type==json_integer) then
- p%int_value = value
- else
- call json%info(p,name=name)
- call json%create_integer(tmp,value,name)
- call json%replace(p,tmp,destroy=.true.)
- end if
-
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_integer_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_integer_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_add_integer_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- integer(IK),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%json_add_integer_by_path(me,to_unicode(path),value,found,was_created)
-
- end subroutine wrap_json_add_integer_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Add an real value to a [[json_value]], given the path.
- !
- !@warning If the path points to an existing variable in the structure,
- ! then this routine will destroy it and replace it with the
- ! new value.
-
- subroutine json_add_real_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- real(RK),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- type(json_value),pointer :: p
- type(json_value),pointer :: tmp
- character(kind=CK,len=:),allocatable :: name !! variable name
-
- if ( .not. json%exception_thrown ) then
-
- nullify(p)
-
- ! return a pointer to the path (possibly creating it)
- ! If the variable had to be created, then
- ! it will be a json_null variable.
- call json%create(me,path,p,found,was_created)
-
- if (.not. associated(p)) then
-
- call json%throw_exception('Error in json_add_real_by_path:'//&
- ' Unable to resolve path: '//trim(path),found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
-
- else
-
- !NOTE: a new object is created, and the old one
- ! is replaced and destroyed. This is to
- ! prevent memory leaks if the type is
- ! being changed (for example, if an array
- ! is being replaced with a scalar).
-
- if (p%var_type==json_real) then
- p%dbl_value = value
- else
- call json%info(p,name=name)
- call json%create_real(tmp,value,name)
- call json%replace(p,tmp,destroy=.true.)
- end if
-
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_real_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_real_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_add_real_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- real(RK),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%json_add_real_by_path(me,to_unicode(path),value,found,was_created)
-
- end subroutine wrap_json_add_real_by_path
- !*****************************************************************************************
-
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_add_real_by_path]] where value=real32.
-
- subroutine json_add_real32_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- real(real32),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%add_by_path(me,path,real(value,RK),found,was_created)
-
- end subroutine json_add_real32_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_real32_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_add_real32_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- real(real32),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
-
- end subroutine wrap_json_add_real32_by_path
- !*****************************************************************************************
-
-
- # 3942
-
-
- !*****************************************************************************************
- !>
- ! Add a logical value to a [[json_value]], given the path.
- !
- !@warning If the path points to an existing variable in the structure,
- ! then this routine will destroy it and replace it with the
- ! new value.
-
- subroutine json_add_logical_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- logical(LK),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- type(json_value),pointer :: p
- type(json_value),pointer :: tmp
- character(kind=CK,len=:),allocatable :: name !! variable name
-
- if ( .not. json%exception_thrown ) then
-
- nullify(p)
-
- ! return a pointer to the path (possibly creating it)
- ! If the variable had to be created, then
- ! it will be a json_null variable.
- call json%create(me,path,p,found,was_created)
-
- if (.not. associated(p)) then
-
- call json%throw_exception('Error in json_add_logical_by_path:'//&
- ' Unable to resolve path: '//trim(path),found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
-
- else
-
- !NOTE: a new object is created, and the old one
- ! is replaced and destroyed. This is to
- ! prevent memory leaks if the type is
- ! being changed (for example, if an array
- ! is being replaced with a scalar).
-
- if (p%var_type==json_logical) then
- p%log_value = value
- else
- call json%info(p,name=name)
- call json%create_logical(tmp,value,name)
- call json%replace(p,tmp,destroy=.true.)
- end if
-
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_logical_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_logical_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_add_logical_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- logical(LK),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%json_add_logical_by_path(me,to_unicode(path),value,found,was_created)
-
- end subroutine wrap_json_add_logical_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Add a string value to a [[json_value]], given the path.
- !
- !@warning If the path points to an existing variable in the structure,
- ! then this routine will destroy it and replace it with the
- ! new value.
-
- subroutine json_add_string_by_path(json,me,path,value,found,&
- was_created,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CK,len=*),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- type(json_value),pointer :: p
- type(json_value),pointer :: tmp
- character(kind=CK,len=:),allocatable :: name !! variable name
-
- if ( .not. json%exception_thrown ) then
-
- nullify(p)
-
- ! return a pointer to the path (possibly creating it)
- ! If the variable had to be created, then
- ! it will be a json_null variable.
- call json%create(me,path,p,found,was_created)
-
- if (.not. associated(p)) then
-
- call json%throw_exception('Error in json_add_string_by_path:'//&
- ' Unable to resolve path: '//trim(path),found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
-
- else
-
- !NOTE: a new object is created, and the old one
- ! is replaced and destroyed. This is to
- ! prevent memory leaks if the type is
- ! being changed (for example, if an array
- ! is being replaced with a scalar).
-
- if (p%var_type==json_string) then
- p%str_value = value
- else
- call json%info(p,name=name)
- call json%create_string(tmp,value,name,trim_str,adjustl_str)
- call json%replace(p,tmp,destroy=.true.)
- end if
-
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_string_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_string_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_add_string_by_path(json,me,path,value,found,&
- was_created,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CDK,len=*),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- call json%json_add_string_by_path(me,to_unicode(path),to_unicode(value),&
- found,was_created,trim_str,adjustl_str)
-
- end subroutine wrap_json_add_string_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_string_by_path]] where "path" is kind=CDK.
-
- subroutine json_add_string_by_path_path_ascii(json,me,path,value,found,&
- was_created,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CK,len=*),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- call json%json_add_string_by_path(me,to_unicode(path),value,found,was_created,trim_str,adjustl_str)
-
- end subroutine json_add_string_by_path_path_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_string_by_path]] where "value" is kind=CDK.
-
- subroutine json_add_string_by_path_value_ascii(json,me,path,value,found,&
- was_created,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CDK,len=*),intent(in) :: value !! the value to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- call json%json_add_string_by_path(me,path,to_unicode(value),found,was_created,trim_str,adjustl_str)
-
- end subroutine json_add_string_by_path_value_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_integer_by_path]] for adding an integer vector by path.
-
- subroutine json_add_integer_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- integer(IK),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- type(json_value),pointer :: p !! pointer to path (which may exist)
- type(json_value),pointer :: var !! new variable that is created
- integer(IK) :: i !! counter
- character(kind=CK,len=:),allocatable :: name !! the variable name
- logical(LK) :: p_found !! if the path was successfully found (or created)
-
- if ( .not. json%exception_thrown ) then
-
- !get a pointer to the variable
- !(creating it if necessary)
- call json%create(me,path,p,found=p_found)
- if (p_found) then
- call json%info(p,name=name) ! want to keep the existing name
- call json%create_array(var,name) ! create a new array variable
- call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
- !populate each element of the array:
- do i=1,size(value)
- call json%add(var, CK_'', value(i))
- end do
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_integer_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_integer_vec_by_path]] where "path" is kind=CDK).
-
- subroutine wrap_json_add_integer_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- integer(IK),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%json_add_integer_vec_by_path(me,to_unicode(path),value,found,was_created)
-
- end subroutine wrap_json_add_integer_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_logical_by_path]] for adding a logical vector by path.
-
- subroutine json_add_logical_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- logical(LK),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- type(json_value),pointer :: p !! pointer to path (which may exist)
- type(json_value),pointer :: var !! new variable that is created
- integer(IK) :: i !! counter
- character(kind=CK,len=:),allocatable :: name !! the variable name
- logical(LK) :: p_found !! if the path was successfully found (or created)
-
- if ( .not. json%exception_thrown ) then
-
- !get a pointer to the variable
- !(creating it if necessary)
- call json%create(me,path,p,found=p_found)
- if (p_found) then
- call json%info(p,name=name) ! want to keep the existing name
- call json%create_array(var,name) ! create a new array variable
- call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
- !populate each element of the array:
- do i=1,size(value)
- call json%add(var, CK_'', value(i))
- end do
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_logical_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_logical_vec_by_path]] where "path" is kind=CDK).
-
- subroutine wrap_json_add_logical_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- logical(LK),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%json_add_logical_vec_by_path(me,to_unicode(path),value,found,was_created)
-
- end subroutine wrap_json_add_logical_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path.
-
- subroutine json_add_real_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- real(RK),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- type(json_value),pointer :: p !! pointer to path (which may exist)
- type(json_value),pointer :: var !! new variable that is created
- integer(IK) :: i !! counter
- character(kind=CK,len=:),allocatable :: name !! the variable name
- logical(LK) :: p_found !! if the path was successfully found (or created)
-
- if ( .not. json%exception_thrown ) then
-
- !get a pointer to the variable
- !(creating it if necessary)
- call json%create(me,path,p,found=p_found)
- if (p_found) then
- call json%info(p,name=name) ! want to keep the existing name
- call json%create_array(var,name) ! create a new array variable
- call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
- !populate each element of the array:
- do i=1,size(value)
- call json%add(var, CK_'', value(i))
- end do
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_real_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_real_vec_by_path]] where "path" is kind=CDK).
-
- subroutine wrap_json_add_real_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- real(RK),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%json_add_real_vec_by_path(me,to_unicode(path),value,found,was_created)
-
- end subroutine wrap_json_add_real_vec_by_path
- !*****************************************************************************************
-
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_real_by_path]] for adding a real vector by path.
-
- subroutine json_add_real32_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- real(real32),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%add_by_path(me,path,real(value,RK),found,was_created)
-
- end subroutine json_add_real32_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_real32_vec_by_path]] where "path" is kind=CDK).
-
- subroutine wrap_json_add_real32_vec_by_path(json,me,path,value,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- real(real32),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
-
- call json%add_by_path(me,to_unicode(path),real(value,RK),found,was_created)
-
- end subroutine wrap_json_add_real32_vec_by_path
- !*****************************************************************************************
-
-
- # 4445
-
-
- !*****************************************************************************************
- !>
- ! Wrapper to [[json_add_string_by_path]] for adding a string vector by path.
- !
- !@note The `ilen` input can be used to specify the actual lengths of the
- ! the strings in the array. They must all be `<= len(value)`.
-
- subroutine json_add_string_vec_by_path(json,me,path,value,found,was_created,ilen,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
- !! element in `value`. If not present,
- !! the full `len(value)` string is added
- !! for each element.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- type(json_value),pointer :: p !! pointer to path (which may exist)
- type(json_value),pointer :: var !! new variable that is created
- integer(IK) :: i !! counter
- character(kind=CK,len=:),allocatable :: name !! the variable name
- logical(LK) :: p_found !! if the path was successfully found (or created)
-
- if ( .not. json%exception_thrown ) then
-
- ! validate ilen array if present:
- if (present(ilen)) then
- if (size(ilen)/=size(value)) then
- call json%throw_exception('Error in json_add_string_vec_by_path: '//&
- 'Invalid size of ilen input vector.',found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- if (present(was_created)) was_created = .false.
- return
- else
- ! also have to validate the specified lengths.
- ! (must not be greater than input string length)
- do i = 1, size(value)
- if (ilen(i)>len(value)) then
- call json%throw_exception('Error in json_add_string_vec_by_path: '//&
- 'Invalid ilen element.',found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- if (present(was_created)) was_created = .false.
- return
- end if
- end do
- end if
- end if
-
- !get a pointer to the variable
- !(creating it if necessary)
- call json%create(me,path,p,found=p_found)
- if (p_found) then
- call json%info(p,name=name) ! want to keep the existing name
- call json%create_array(var,name) ! create a new array variable
- call json%replace(p,var,destroy=.true.) ! replace p with this array (destroy p)
- !populate each element of the array:
- do i=1,size(value)
- if (present(ilen)) then
- call json%add(var, CK_'', value(i)(1:ilen(i)), &
- trim_str=trim_str, adjustl_str=adjustl_str)
- else
- call json%add(var, CK_'', value(i), &
- trim_str=trim_str, adjustl_str=adjustl_str)
- end if
- end do
- end if
-
- else
- if ( present(found) ) found = .false.
- if ( present(was_created) ) was_created = .false.
- end if
-
- end subroutine json_add_string_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_string_vec_by_path]] where "path" and "value" are kind=CDK).
-
- subroutine wrap_json_add_string_vec_by_path(json,me,path,value,&
- found,was_created,ilen,&
- trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
- !! element in `value`. If not present,
- !! the full `len(value)` string is added
- !! for each element.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- call json%json_add_string_vec_by_path(me,to_unicode(path),to_unicode(value),&
- found,was_created,ilen,trim_str,adjustl_str)
-
- end subroutine wrap_json_add_string_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_string_vec_by_path]] where "value" is kind=CDK).
-
- subroutine json_add_string_vec_by_path_value_ascii(json,me,path,value,&
- found,was_created,ilen,&
- trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CDK,len=*),dimension(:),intent(in):: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
- !! element in `value`. If not present,
- !! the full `len(value)` string is added
- !! for each element.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- call json%json_add_string_vec_by_path(me,path,to_unicode(value),&
- found,was_created,ilen,trim_str,adjustl_str)
-
- end subroutine json_add_string_vec_by_path_value_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_add_string_vec_by_path]] where "path" is kind=CDK).
-
- subroutine json_add_string_vec_by_path_path_ascii(json,me,path,value,&
- found,was_created,ilen,&
- trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me !! the JSON structure
- character(kind=CDK,len=*),intent(in) :: path !! the path to the variable
- character(kind=CK,len=*),dimension(:),intent(in) :: value !! the vector to add
- logical(LK),intent(out),optional :: found !! if the variable was found
- logical(LK),intent(out),optional :: was_created !! if the variable had to be created
- integer(IK),dimension(:),intent(in),optional :: ilen !! the string lengths of each
- !! element in `value`. If not present,
- !! the full `len(value)` string is added
- !! for each element.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- call json%json_add_string_vec_by_path(me,to_unicode(path),value,&
- found,was_created,ilen,trim_str,adjustl_str)
-
- end subroutine json_add_string_vec_by_path_path_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/19/2014
- !
- ! Add a real value child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_real(json,p,name,val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name !! variable name
- real(RK),intent(in) :: val !! real value
-
- type(json_value),pointer :: var
-
- !create the variable:
- call json%create_real(var,val,name)
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_real
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_real]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_real(json,p,name,val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! variable name
- real(RK),intent(in) :: val !! real value
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_real
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/20/2014
- !
- ! Add a real vector child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_real_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name
- real(RK),dimension(:),intent(in) :: val
-
- type(json_value),pointer :: var
- integer(IK) :: i !! counter
-
- !create the variable as an array:
- call json%create_array(var,name)
-
- !populate the array:
- do i=1,size(val)
- call json%add(var, CK_'', val(i))
- end do
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_real_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_real_vec]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_real_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name
- real(RK),dimension(:),intent(in) :: val
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_real_vec
- !*****************************************************************************************
-
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_real]] where `val` is `real32`.
-
- subroutine json_value_add_real32(json,p,name,val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name !! variable name
- real(real32),intent(in) :: val !! real value
-
- call json%add(p,name,real(val,RK))
-
- end subroutine json_value_add_real32
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_real32]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_real32(json,p,name,val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! variable name
- real(real32),intent(in) :: val !! real value
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_real32
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_real_vec]] where `val` is `real32`.
-
- subroutine json_value_add_real32_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name
- real(real32),dimension(:),intent(in) :: val
-
- call json%add(p,name,real(val,RK))
-
- end subroutine json_value_add_real32_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_real32_vec]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_real32_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name
- real(real32),dimension(:),intent(in) :: val
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_real32_vec
- !*****************************************************************************************
-
-
- # 4868
-
-
- !*****************************************************************************************
- !>
- ! Add a NULL value child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_null(json, p, name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name
-
- type(json_value),pointer :: var
-
- !create the variable:
- call json%create_null(var,name)
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_null
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_null]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_null(json, p, name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! name of the variable
-
- call json%add(p, to_unicode(name))
-
- end subroutine wrap_json_value_add_null
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/20/2014
- !
- ! Add an integer value child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_integer(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name
- integer(IK),intent(in) :: val
-
- type(json_value),pointer :: var
-
- !create the variable:
- call json%create_integer(var,val,name)
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_integer]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_integer(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! name of the variable
- integer(IK),intent(in) :: val !! value
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/20/2014
- !
- ! Add a integer vector child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_integer_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name !! name of the variable
- integer(IK),dimension(:),intent(in) :: val !! value
-
- type(json_value),pointer :: var
- integer(IK) :: i !! counter
-
- !create a variable as an array:
- call json%create_array(var,name)
-
- !populate the array:
- do i=1,size(val)
- call json%add(var, CK_'', val(i))
- end do
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_integer_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_integer_vec]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_integer_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! name of the variable
- integer(IK),dimension(:),intent(in) :: val !! value
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_integer_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/20/2014
- !
- ! Add a logical value child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_logical(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name !! name of the variable
- logical(LK),intent(in) :: val !! value
-
- type(json_value),pointer :: var
-
- !create the variable:
- call json%create_logical(var,val,name)
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_logical]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_logical(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! name of the variable
- logical(LK),intent(in) :: val !! value
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/20/2014
- !
- ! Add a logical vector child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_logical_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name !! name of the vector
- logical(LK),dimension(:),intent(in) :: val !! value
-
- type(json_value),pointer :: var
- integer(IK) :: i !! counter
-
- !create the variable as an array:
- call json%create_array(var,name)
-
- !populate the array:
- do i=1,size(val)
- call json%add(var, CK_'', val(i))
- end do
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_logical_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_logical_vec]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_add_logical_vec(json, p, name, val)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! name of the variable
- logical(LK),dimension(:),intent(in) :: val !! value
-
- call json%add(p, to_unicode(name), val)
-
- end subroutine wrap_json_value_add_logical_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/19/2014
- !
- ! Add a character string child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_string(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name !! name of the variable
- character(kind=CK,len=*),intent(in) :: val !! value
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
-
- type(json_value),pointer :: var
-
- !create the variable:
- call json%create_string(var,val,name,trim_str,adjustl_str)
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_string]] where `name` and `val` are kind=CDK.
-
- subroutine wrap_json_value_add_string(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! name of the variable
- character(kind=CDK,len=*),intent(in) :: val !! value
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
-
- call json%add(p, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
-
- end subroutine wrap_json_value_add_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_string]] where `name` is kind=CDK.
-
- subroutine json_value_add_string_name_ascii(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name !! name of the variable
- character(kind=CK, len=*),intent(in) :: val !! value
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
-
- call json%add(p, to_unicode(name), val, trim_str, adjustl_str)
-
- end subroutine json_value_add_string_name_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_string]] where `val` is kind=CDK.
-
- subroutine json_value_add_string_val_ascii(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK, len=*),intent(in) :: name !! name of the variable
- character(kind=CDK,len=*),intent(in) :: val !! value
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
-
- call json%add(p, name, to_unicode(val), trim_str, adjustl_str)
-
- end subroutine json_value_add_string_val_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/19/2014
- !
- ! Add a character string vector child to the [[json_value]] variable.
- !
- !@note This routine is part of the public API that can be
- ! used to build a JSON structure using [[json_value]] pointers.
-
- subroutine json_value_add_string_vec(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name !! variable name
- character(kind=CK,len=*),dimension(:),intent(in) :: val !! array of strings
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for each element
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for each element
-
- type(json_value),pointer :: var
- integer(IK) :: i !! counter
-
- !create the variable as an array:
- call json%create_array(var,name)
-
- !populate the array:
- do i=1,size(val)
- call json%add(var, CK_'', val(i), trim_str, adjustl_str)
- end do
-
- !add it:
- call json%add(p, var)
-
- end subroutine json_value_add_string_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_string_vec]] where `name` and `val` are kind=CDK.
-
- subroutine wrap_json_value_add_string_vec(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name
- character(kind=CDK,len=*),dimension(:),intent(in) :: val
- logical(LK),intent(in),optional :: trim_str
- logical(LK),intent(in),optional :: adjustl_str
-
- call json%add(p, to_unicode(name), to_unicode(val), trim_str, adjustl_str)
-
- end subroutine wrap_json_value_add_string_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_string_vec]] where `name` is kind=CDK.
-
- subroutine json_value_add_string_vec_name_ascii(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name
- character(kind=CK, len=*),dimension(:),intent(in) :: val
- logical(LK),intent(in),optional :: trim_str
- logical(LK),intent(in),optional :: adjustl_str
-
- call json%add(p, to_unicode(name), val, trim_str, adjustl_str)
-
- end subroutine json_value_add_string_vec_name_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_add_string_vec]] where `val` is kind=CDK.
-
- subroutine json_value_add_string_vec_val_ascii(json, p, name, val, trim_str, adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK, len=*),intent(in) :: name
- character(kind=CDK,len=*),dimension(:),intent(in) :: val
- logical(LK),intent(in),optional :: trim_str
- logical(LK),intent(in),optional :: adjustl_str
-
- call json%add(p, name, to_unicode(val), trim_str, adjustl_str)
-
- end subroutine json_value_add_string_vec_val_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Count the number of children in the object or array.
- !
- !### History
- ! * JW : 1/4/2014 : Original routine removed.
- ! Now using `n_children` variable.
- ! Renamed from `json_value_count`.
-
- function json_count(json,p) result(count)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! this should normally be a `json_object`
- !! or a `json_array`. For any other
- !! variable type this will return 0.
- integer(IK) :: count !! number of children in `p`.
-
- if (associated(p)) then
- count = p%n_children
- else
- call json%throw_exception('Error in json_count: '//&
- 'pointer is not associated.')
- end if
-
- end function json_count
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 10/16/2015
- !
- ! Returns a pointer to the parent of a [[json_value]].
- ! If there is no parent, then a `null()` pointer is returned.
-
- subroutine json_get_parent(json,p,parent)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! JSON object
- type(json_value),pointer,intent(out) :: parent !! pointer to `parent`
-
- if (associated(p)) then
- parent => p%parent
- else
- nullify(parent)
- call json%throw_exception('Error in json_get_parent: '//&
- 'pointer is not associated.')
- end if
-
- end subroutine json_get_parent
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 10/31/2015
- !
- ! Returns a pointer to the next of a [[json_value]].
- ! If there is no next, then a `null()` pointer is returned.
-
- subroutine json_get_next(json,p,next)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! JSON object
- type(json_value),pointer,intent(out) :: next !! pointer to `next`
-
- if (associated(p)) then
- next => p%next
- else
- nullify(next)
- call json%throw_exception('Error in json_get_next: '//&
- 'pointer is not associated.')
- end if
-
- end subroutine json_get_next
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 10/31/2015
- !
- ! Returns a pointer to the previous of a [[json_value]].
- ! If there is no previous, then a `null()` pointer is returned.
-
- subroutine json_get_previous(json,p,previous)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! JSON object
- type(json_value),pointer,intent(out) :: previous !! pointer to `previous`
-
- if (associated(p)) then
- previous => p%previous
- else
- nullify(previous)
- call json%throw_exception('Error in json_get_previous: '//&
- 'pointer is not associated.')
- end if
-
- end subroutine json_get_previous
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 10/31/2015
- !
- ! Returns a pointer to the tail of a [[json_value]]
- ! (the last child of an array of object).
- ! If there is no tail, then a `null()` pointer is returned.
-
- subroutine json_get_tail(json,p,tail)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! JSON object
- type(json_value),pointer,intent(out) :: tail !! pointer to `tail`
-
- if (associated(p)) then
- tail => p%tail
- else
- nullify(tail)
- call json%throw_exception('Error in json_get_tail: '//&
- 'pointer is not associated.')
- end if
-
- end subroutine json_get_tail
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns a child in the object or array given the index.
-
- subroutine json_value_get_child_by_index(json, p, idx, child, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! object or array JSON data
- integer(IK),intent(in) :: idx !! index of the child
- !! (this is a 1-based Fortran
- !! style array index).
- type(json_value),pointer :: child !! pointer to the child
- logical(LK),intent(out),optional :: found !! true if the value was found
- !! (if not present, an exception
- !! will be thrown if it was not
- !! found. If present and not
- !! found, no exception will be
- !! thrown).
-
- integer(IK) :: i !! counter
-
- nullify(child)
-
- if (.not. json%exception_thrown) then
-
- if (associated(p%children)) then
-
- ! If getting first or last child, we can do this quickly.
- ! Otherwise, traverse the list.
- if (idx==1) then
-
- child => p%children ! first one
-
- elseif (idx==p%n_children) then
-
- if (associated(p%tail)) then
- child => p%tail ! last one
- else
- call json%throw_exception('Error in json_value_get_child_by_index:'//&
- ' child%tail is not associated.',found)
- end if
-
- elseif (idx<1 .or. idx>p%n_children) then
-
- call json%throw_exception('Error in json_value_get_child_by_index:'//&
- ' idx is out of range.',found)
-
- else
-
- ! if idx is closer to the end, we traverse the list backward from tail,
- ! otherwise we traverse it forward from children:
-
- if (p%n_children-idx < idx) then ! traverse backward
-
- child => p%tail
-
- do i = 1, p%n_children - idx
-
- if (associated(child%previous)) then
- child => child%previous
- else
- call json%throw_exception('Error in json_value_get_child_by_index:'//&
- ' child%previous is not associated.',found)
- nullify(child)
- exit
- end if
-
- end do
-
- else ! traverse forward
-
- child => p%children
-
- do i = 1, idx - 1
-
- if (associated(child%next)) then
- child => child%next
- else
- call json%throw_exception('Error in json_value_get_child_by_index:'//&
- ' child%next is not associated.',found)
- nullify(child)
- exit
- end if
-
- end do
-
- end if
-
- end if
-
- else
-
- call json%throw_exception('Error in json_value_get_child_by_index:'//&
- ' p%children is not associated.',found)
-
- end if
-
- ! found output:
- if (json%exception_thrown) then
- if (present(found)) then
- call json%clear_exceptions()
- found = .false.
- end if
- else
- if (present(found)) found = .true.
- end if
-
- else
- if (present(found)) found = .false.
- end if
-
- end subroutine json_value_get_child_by_index
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns pointer to the first child of the object
- ! (or `null()` if it is not associated).
-
- subroutine json_value_get_child(json, p, child)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! object or array JSON data
- type(json_value),pointer :: child !! pointer to the child
-
- if (associated(p)) then
- child => p%children
- else
- nullify(child)
- call json%throw_exception('Error in json_value_get_child: '//&
- 'pointer is not associated.')
- end if
-
- end subroutine json_value_get_child
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns a child in the object or array given the name string.
- !
- ! The name search can be case-sensitive or not, and can have significant trailing
- ! whitespace or not, depending on the settings in the [[json_core(type)]] class.
- !
- !@note The `name` input is not a path, and is not parsed like it is in [[json_get_by_path]].
-
- subroutine json_value_get_child_by_name(json, p, name, child, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- character(kind=CK,len=*),intent(in) :: name !! the name of a child of `p`
- type(json_value),pointer :: child !! pointer to the child
- logical(LK),intent(out),optional :: found !! true if the value was found
- !! (if not present, an exception
- !! will be thrown if it was not
- !! found. If present and not
- !! found, no exception will be
- !! thrown).
-
- integer(IK) :: i,n_children
- logical :: error
-
- nullify(child)
-
- if (.not. json%exception_thrown) then
-
- if (associated(p)) then
-
- error = .true. ! will be false if it is found
- if (p%var_type==json_object) then
- n_children = json%count(p)
- child => p%children !start with first one
- do i=1, n_children
- if (.not. associated(child)) then
- call json%throw_exception(&
- 'Error in json_value_get_child_by_name: '//&
- 'Malformed JSON linked list',found)
- exit
- end if
- if (allocated(child%name)) then
- !name string matching routine:
- if (json%name_equal(child,name)) then
- error = .false.
- exit
- end if
- end if
- child => child%next
- end do
- end if
-
- if (error) then
- !did not find anything:
- call json%throw_exception(&
- 'Error in json_value_get_child_by_name: '//&
- 'child variable '//trim(name)//' was not found.',found)
- nullify(child)
- end if
-
- else
- call json%throw_exception(&
- 'Error in json_value_get_child_by_name: '//&
- 'pointer is not associated.',found)
- end if
-
- ! found output:
- if (json%exception_thrown) then
- if (present(found)) then
- call json%clear_exceptions()
- found = .false.
- end if
- else
- if (present(found)) found = .true.
- end if
-
- else
- if (present(found)) found = .false.
- end if
-
- end subroutine json_value_get_child_by_name
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 8/25/2017
- !
- ! Checks a JSON object for duplicate child names.
- !
- ! It uses the specified settings for name matching (see [[name_strings_equal]]).
- !
- !@note This will only check for one duplicate,
- ! it will return the first one that it finds.
-
- subroutine json_check_children_for_duplicate_keys(json,p,has_duplicate,name,path)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
- !! not a `json_object`, then `has_duplicate`
- !! will be false.
- logical(LK),intent(out) :: has_duplicate !! true if there is at least
- !! two children have duplicate
- !! `name` values.
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
- !! (unallocated if no
- !! duplicate was found)
- character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
- !! duplicate name
- !! (unallocated if no
- !! duplicate was found)
-
- integer(IK) :: i !! counter
- integer(IK) :: j !! counter
- type(json_value),pointer :: child !! pointer to a child of `p`
- integer(IK) :: n_children !! number of children of `p`
- logical(LK) :: found !! flag for `get_child`
-
- type :: alloc_str
- !! so we can have an array of allocatable strings
- character(kind=CK,len=:),allocatable :: str !! name string
- end type alloc_str
- type(alloc_str),dimension(:),allocatable :: names !! array of all the
- !! child name strings
-
- ! initialize:
- has_duplicate =.false.
-
- if (.not. json%exception_thrown) then
-
- if (associated(p)) then
-
- if (p%var_type==json_object) then
-
- ! number of items to check:
- n_children = json%count(p)
- allocate(names(n_children))
-
- ! first get a list of all the name keys:
- do i=1, n_children
- call json%get_child(p,i,child,found) ! get by index
- if (.not. found) then
- call json%throw_exception(&
- 'Error in json_check_children_for_duplicate_keys: '//&
- 'Malformed JSON linked list')
- exit
- end if
- if (allocated(child%name)) then
- names(i)%str = child%name
- else
- call json%throw_exception(&
- 'Error in json_check_children_for_duplicate_keys: '//&
- 'Object child name is not allocated')
- exit
- end if
- end do
-
- if (.not. json%exception_thrown) then
- ! now check the list for duplicates:
- main: do i=1,n_children
- do j=1,i-1
- if (json%name_strings_equal(names(i)%str,names(j)%str)) then
- has_duplicate = .true.
- if (present(name)) then
- name = names(i)%str
- end if
- if (present(path)) then
- call json%get_child(p,names(i)%str,child,found) ! get by name
- if (found) then
- call json%get_path(child,path,found)
- if (.not. found) then
- ! should never happen since we know it is there
- call json%throw_exception(&
- 'Error in json_check_children_for_duplicate_keys: '//&
- 'Could not get path')
- end if
- else
- ! should never happen since we know it is there
- call json%throw_exception(&
- 'Error in json_check_children_for_duplicate_keys: '//&
- 'Could not get child: '//trim(names(i)%str))
- end if
- end if
- exit main
- end if
- end do
- end do main
- end if
-
- ! cleanup
- do i=1,n_children
- if (allocated(names(i)%str)) deallocate(names(i)%str)
- end do
- if (allocated(names)) deallocate(names)
-
- end if
-
- end if
-
- end if
-
- end subroutine json_check_children_for_duplicate_keys
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 8/25/2017
- !
- ! Checks a JSON structure for duplicate child names.
- ! This one recursively traverses the entire structure
- ! (calling [[json_check_children_for_duplicate_keys]]
- ! recursively for each element).
- !
- !@note This will only check for one duplicate,
- ! it will return the first one that it finds.
-
- subroutine json_check_all_for_duplicate_keys(json,p,has_duplicate,name,path)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! the object to search. If `p` is
- !! not a `json_object`, then `has_duplicate`
- !! will be false.
- logical(LK),intent(out) :: has_duplicate !! true if there is at least
- !! one duplicate `name` key anywhere
- !! in the structure.
- character(kind=CK,len=:),allocatable,intent(out),optional :: name !! the duplicate name
- !! (unallocated if no
- !! duplicates were found)
- character(kind=CK,len=:),allocatable,intent(out),optional :: path !! the full path to the
- !! duplicate name
- !! (unallocated if no
- !! duplicate was found)
-
- has_duplicate = .false.
- if (.not. json%exception_thrown) then
- call json%traverse(p,duplicate_key_func)
- end if
-
- contains
-
- subroutine duplicate_key_func(json,p,finished)
-
- !! Callback function to check each element
- !! for duplicate child names.
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- logical(LK),intent(out) :: finished
-
- # 5854
-
- call json%check_children_for_duplicate_keys(p,has_duplicate,name,path)
-
-
- finished = has_duplicate .or. json%exception_thrown
-
- end subroutine duplicate_key_func
-
- end subroutine json_check_all_for_duplicate_keys
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_get_child_by_name]] where `name` is kind=CDK.
-
- subroutine wrap_json_value_get_child_by_name(json, p, name, child, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- character(kind=CDK,len=*),intent(in) :: name
- type(json_value),pointer :: child
- logical(LK),intent(out),optional :: found
-
- call json%get(p,to_unicode(name),child,found)
-
- end subroutine wrap_json_value_get_child_by_name
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 2/12/2014
- !
- ! Print the [[json_value]] structure to an allocatable string.
-
- subroutine json_value_to_string(json,p,str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- character(kind=CK,len=:),intent(out),allocatable :: str !! prints structure to this string
-
- integer(IK) :: iloc !! used to keep track of size of str
- !! since it is being allocated in chunks.
-
- str = repeat(space, print_str_chunk_size)
- iloc = 0_IK
- call json%json_value_print(p, iunit=unit2str, str=str, iloc=iloc, indent=1_IK, colon=.true.)
-
- ! trim the string if necessary:
- if (len(str)>iloc) str = str(1:iloc)
-
- end subroutine json_value_to_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Print the [[json_value]] structure to the console (`output_unit`).
- !
- !### Note
- ! * Just a wrapper for [[json_print_to_unit]].
-
- subroutine json_print_to_console(json,p)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
-
- call json%print(p,int(output_unit,IK))
-
- end subroutine json_print_to_console
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 6/20/2014
- !
- ! Print the [[json_value]] structure to a file.
-
- subroutine json_print_to_unit(json,p,iunit)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- integer(IK),intent(in) :: iunit !! the file unit (the file must
- !! already have been opened, can't be -1).
-
- character(kind=CK,len=:),allocatable :: dummy !! dummy for `str` argument
- !! to [[json_value_print]]
- integer(IK) :: idummy !! dummy for `iloc` argument
- !! to [[json_value_print]]
-
- if (iunit/=unit2str) then
- idummy = 0_IK
- call json%json_value_print(p,iunit,str=dummy,iloc=idummy,indent=1_IK,colon=.true.)
- else
- call json%throw_exception('Error in json_print_to_unit: iunit must not be -1.')
- end if
-
- end subroutine json_print_to_unit
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/23/2014
- !
- ! Print the [[json_value]] structure to a file.
-
- subroutine json_print_to_filename(json,p,filename)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- character(kind=CDK,len=*),intent(in) :: filename !! the filename to print to
- !! (should not already be open)
-
- integer(IK) :: iunit !! file unit for `open` statement
- integer(IK) :: istat !! `iostat` code for `open` statement
-
- open(newunit=iunit,file=filename,status='REPLACE',iostat=istat )
- if (istat==0) then
- call json%print(p,iunit)
- close(iunit,iostat=istat)
- else
- call json%throw_exception('Error in json_print_to_filename: could not open file: '//&
- trim(filename))
- end if
-
- end subroutine json_print_to_filename
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Print the JSON structure to a string or a file.
- !
- !### Notes
- ! * This is an internal routine called by the various wrapper routines.
- ! * The reason the `str` argument is non-optional is because of a
- ! bug in v4.9 of the gfortran compiler.
-
- recursive subroutine json_value_print(json,p,iunit,str,indent,&
- need_comma,colon,is_array_element,&
- is_compressed_vector,iloc)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- integer(IK),intent(in) :: iunit !! file unit to write to (the
- !! file is assumed to be open)
- integer(IK),intent(in),optional :: indent !! indention level
- logical(LK),intent(in),optional :: is_array_element !! if this is an array element
- logical(LK),intent(in),optional :: need_comma !! if it needs a comma after it
- logical(LK),intent(in),optional :: colon !! if the colon was just written
- character(kind=CK,len=:),intent(inout),allocatable :: str
- !! if `iunit==unit2str` (-1) then
- !! the structure is printed to this
- !! string rather than a file. This mode
- !! is used by [[json_value_to_string]].
- integer(IK),intent(inout) :: iloc !! current index in `str`. should be set to 0 initially.
- !! [only used when `str` is used.]
- logical(LK),intent(in),optional :: is_compressed_vector !! if True, this is an element
- !! from an array being printed
- !! on one line [default is False]
-
- character(kind=CK,len=max_numeric_str_len) :: tmp !! for value to string conversions
- character(kind=CK,len=:),allocatable :: s_indent !! the string of spaces for
- !! indenting (see `tab` and `spaces`)
- character(kind=CK,len=:),allocatable :: s !! the string appended to `str`
- type(json_value),pointer :: element !! for getting children
- integer(IK) :: tab !! number of `tabs` for indenting
- integer(IK) :: spaces !! number of spaces for indenting
- integer(IK) :: i !! counter
- integer(IK) :: count !! number of children
- logical(LK) :: print_comma !! if the comma will be printed after the value
- logical(LK) :: write_file !! if we are writing to a file
- logical(LK) :: write_string !! if we are writing to a string
- logical(LK) :: is_array !! if this is an element in an array
- logical(LK) :: is_vector !! if all elements of a vector
- !! are scalars of the same type
- character(kind=CK,len=:),allocatable :: str_escaped !! escaped version of
- !! `name` or `str_value`
-
- if (.not. json%exception_thrown) then
-
- if (.not. associated(p)) then
- ! note: a null() pointer will trigger this error.
- ! However, if the pointer is undefined, then this will
- ! crash (if this wasn't here it would crash below when
- ! we try to access the contents)
- call json%throw_exception('Error in json_value_print: '//&
- 'the pointer is not associated')
- return
- end if
-
- if (present(is_compressed_vector)) then
- is_vector = is_compressed_vector
- else
- is_vector = .false.
- end if
-
- !whether to write a string or a file (one or the other):
- write_string = (iunit==unit2str)
- write_file = .not. write_string
-
- !if the comma will be printed after the value
- ! [comma not printed for the last elements]
- if (present(need_comma)) then
- print_comma = need_comma
- else
- print_comma = .false.
- end if
-
- !number of "tabs" to indent:
- if (present(indent) .and. .not. json%no_whitespace) then
- tab = indent
- else
- tab = 0
- end if
- !convert to number of spaces:
- spaces = tab*json%spaces_per_tab
-
- !if this is an element in an array:
- if (present(is_array_element)) then
- is_array = is_array_element
- else
- is_array = .false.
- end if
-
- !if the colon was the last thing written
- if (present(colon)) then
- s_indent = CK_''
- else
- s_indent = repeat(space, spaces)
- end if
-
- select case (p%var_type)
-
- case (json_object)
-
- count = json%count(p)
-
- if (count==0) then !special case for empty object
-
- s = s_indent//start_object//end_object
- call write_it( comma=print_comma )
-
- else
-
- s = s_indent//start_object
- call write_it()
-
- !if an object is in an array, there is an extra tab:
- if (is_array) then
- if ( .not. json%no_whitespace) tab = tab+1
- spaces = tab*json%spaces_per_tab
- end if
-
- nullify(element)
- element => p%children
- do i = 1, count
-
- if (.not. associated(element)) then
- call json%throw_exception('Error in json_value_print: '//&
- 'Malformed JSON linked list')
- return
- end if
-
- ! print the name
- if (allocated(element%name)) then
- call escape_string(element%name,str_escaped,json%escape_solidus)
- if (json%no_whitespace) then
- !compact printing - no extra space
- s = repeat(space, spaces)//quotation_mark//&
- str_escaped//quotation_mark//colon_char
- call write_it(advance=.false.)
- else
- s = repeat(space, spaces)//quotation_mark//&
- str_escaped//quotation_mark//colon_char//space
- call write_it(advance=.false.)
- end if
- else
- call json%throw_exception('Error in json_value_print:'//&
- ' element%name not allocated')
- nullify(element)
- return
- end if
-
- ! recursive print of the element
- call json%json_value_print(element, iunit=iunit, indent=tab + 1_IK, &
- need_comma=i<count, colon=.true., str=str, iloc=iloc)
- if (json%exception_thrown) return
-
- ! get the next child the list:
- element => element%next
-
- end do
-
- ! [one fewer tab if it isn't an array element]
- if (.not. is_array) then
- s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_object
- else
- s = s_indent//end_object
- end if
- call write_it( comma=print_comma )
- nullify(element)
-
- end if
-
- case (json_array)
-
- count = json%count(p)
-
- if (count==0) then ! special case for empty array
-
- s = s_indent//start_array//end_array
- call write_it( comma=print_comma )
-
- else
-
- ! if every child is the same type & a scalar:
- is_vector = json%is_vector(p)
- if (json%failed()) return
-
- s = s_indent//start_array
- call write_it( advance=(.not. is_vector) )
-
- !if an array is in an array, there is an extra tab:
- if (is_array) then
- if ( .not. json%no_whitespace) tab = tab+1
- spaces = tab*json%spaces_per_tab
- end if
-
- nullify(element)
- element => p%children
- do i = 1, count
-
- if (.not. associated(element)) then
- call json%throw_exception('Error in json_value_print: '//&
- 'Malformed JSON linked list')
- return
- end if
-
- ! recursive print of the element
- if (is_vector) then
- call json%json_value_print(element, iunit=iunit, indent=0_IK,&
- need_comma=i<count, is_array_element=.false., &
- str=str, iloc=iloc,&
- is_compressed_vector = .true.)
- else
- call json%json_value_print(element, iunit=iunit, indent=tab,&
- need_comma=i<count, is_array_element=.true., &
- str=str, iloc=iloc)
- end if
- if (json%exception_thrown) return
-
- ! get the next child the list:
- element => element%next
-
- end do
-
- !indent the closing array character:
- if (is_vector) then
- s = end_array
- call write_it( comma=print_comma )
- else
- s = repeat(space, max(0_IK,spaces-json%spaces_per_tab))//end_array
- call write_it( comma=print_comma )
- end if
- nullify(element)
-
- end if
-
- case (json_null)
-
- s = s_indent//null_str
- call write_it( comma=print_comma, &
- advance=(.not. is_vector),&
- space_after_comma=is_vector )
-
- case (json_string)
-
- if (allocated(p%str_value)) then
- ! have to escape the string for printing:
- call escape_string(p%str_value,str_escaped,json%escape_solidus)
- s = s_indent//quotation_mark//str_escaped//quotation_mark
- call write_it( comma=print_comma, &
- advance=(.not. is_vector),&
- space_after_comma=is_vector )
- else
- call json%throw_exception('Error in json_value_print:'//&
- ' p%value_string not allocated')
- return
- end if
-
- case (json_logical)
-
- if (p%log_value) then
- s = s_indent//true_str
- call write_it( comma=print_comma, &
- advance=(.not. is_vector),&
- space_after_comma=is_vector )
- else
- s = s_indent//false_str
- call write_it( comma=print_comma, &
- advance=(.not. is_vector),&
- space_after_comma=is_vector )
- end if
-
- case (json_integer)
-
- call integer_to_string(p%int_value,int_fmt,tmp)
-
- s = s_indent//trim(tmp)
- call write_it( comma=print_comma, &
- advance=(.not. is_vector),&
- space_after_comma=is_vector )
-
- case (json_real)
-
- if (allocated(json%real_fmt)) then
- call real_to_string(p%dbl_value,json%real_fmt,json%compact_real,json%non_normals_to_null,tmp)
- else
- !use the default format (user has not called initialize() or specified one):
- call real_to_string(p%dbl_value,default_real_fmt,json%compact_real,json%non_normals_to_null,tmp)
- end if
-
- s = s_indent//trim(tmp)
- call write_it( comma=print_comma, &
- advance=(.not. is_vector),&
- space_after_comma=is_vector )
-
- case default
-
- call integer_to_string(p%var_type,int_fmt,tmp)
- call json%throw_exception('Error in json_value_print: '//&
- 'unknown data type: '//trim(tmp))
-
- end select
-
- end if
-
- contains
-
- subroutine write_it(advance,comma,space_after_comma)
-
- !! write the string `s` to the file (or the output string)
-
- implicit none
-
- logical(LK),intent(in),optional :: advance !! to add line break or not
- logical(LK),intent(in),optional :: comma !! print comma after the string
- logical(LK),intent(in),optional :: space_after_comma !! print a space after the comma
-
- logical(LK) :: add_comma !! if a delimiter is to be added after string
- logical(LK) :: add_line_break !! if a line break is to be added after string
- logical(LK) :: add_space !! if a space is to be added after the comma
- integer(IK) :: n !! length of actual string `s` appended to `str`
- integer(IK) :: room_left !! number of characters left in `str`
- integer(IK) :: n_chunks_to_add !! number of chunks to add to `str` for appending `s`
-
- if (present(comma)) then
- add_comma = comma
- else
- add_comma = .false. !default is not to add comma
- end if
- if (json%no_whitespace) then
- add_space = .false.
- else
- if (present(space_after_comma)) then
- add_space = space_after_comma
- else
- add_space = .false. !default is not to add space
- end if
- end if
- if (present(advance)) then
- if (json%no_whitespace) then
- ! overrides input value:
- add_line_break = .false.
- else
- add_line_break = advance
- end if
- else
- add_line_break = .not. json%no_whitespace ! default is to advance if
- ! we are printing whitespace
- end if
-
- ! string to print:
- if (add_comma) then
- if (add_space) then
- s = s // delimiter // space
- else
- s = s // delimiter
- end if
- end if
-
- if (write_file) then
-
- if (add_line_break) then
- write(iunit,fmt='(A)') s
- else
- write(iunit,fmt='(A)',advance='NO') s
- end if
-
- else !write string
-
- if (add_line_break) s = s // newline
-
- n = len(s)
- room_left = len(str)-iloc
- if (room_left < n) then
- ! need to add another chunk to fit this string:
- n_chunks_to_add = max(1_IK, ceiling( real(len(s)-room_left,RK) / real(chunk_size,RK), IK ) )
- str = str // repeat(space, print_str_chunk_size*n_chunks_to_add)
- end if
- ! append s to str:
- str(iloc+1:iloc+n) = s
- iloc = iloc + n
-
- end if
-
- end subroutine write_it
-
- end subroutine json_value_print
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns true if all the children are the same type (and a scalar).
- ! Note that integers and reals are considered the same type for this purpose.
- ! This routine is used for the `compress_vectors` option.
-
- function json_is_vector(json, p) result(is_vector)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- logical(LK) :: is_vector !! if all elements of a vector
- !! are scalars of the same type
-
- integer(IK) :: var_type_prev !! for getting the variable type of children
- integer(IK) :: var_type !! for getting the variable type of children
- type(json_value),pointer :: element !! for getting children
- integer(IK) :: i !! counter
- integer(IK) :: count !! number of children
-
- integer(IK),parameter :: json_invalid = -1_IK !! to initialize the flag. an invalid value
- integer(IK),parameter :: json_numeric = -2_IK !! indicates `json_integer` or `json_real`
-
- if (json%compress_vectors) then
- ! check to see if every child is the same type,
- ! and a scalar:
- is_vector = .true.
- var_type_prev = json_invalid
- count = json%count(p)
- element => p%children
- do i = 1_IK, count
- if (.not. associated(element)) then
- call json%throw_exception('Error in json_is_vector: '//&
- 'Malformed JSON linked list')
- return
- end if
- ! check variable type of all the children.
- ! They must all be the same, and a scalar.
- call json%info(element,var_type=var_type)
- ! special check for numeric values:
- if (var_type==json_integer .or. var_type==json_real) var_type = json_numeric
- if (var_type==json_object .or. &
- var_type==json_array .or. &
- (i>1_IK .and. var_type/=var_type_prev)) then
- is_vector = .false.
- exit
- end if
- var_type_prev = var_type
- ! get the next child the list:
- element => element%next
- end do
- else
- is_vector = .false.
- end if
-
- end function json_is_vector
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns true if the `path` is present in the `p` JSON structure.
- !
- !@note Just a wrapper for [[json_get_by_path]], so it uses the
- ! specified `path_mode` and other settings.
-
- function json_valid_path(json, p, path) result(found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- logical(LK) :: found !! true if it was found
-
- type(json_value),pointer :: tmp !! pointer to the variable specified by `path`
-
- call json%get(p, path, tmp, found)
-
- end function json_valid_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_valid_path]] where "path" is kind=CDK.
-
- function wrap_json_valid_path(json, p, path) result(found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! a JSON linked list
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable
- logical(LK) :: found !! true if it was found
-
- found = json%valid_path(p, to_unicode(path))
-
- end function wrap_json_valid_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns the [[json_value]] pointer given the path string.
- !
- ! It uses one of three methods:
- !
- ! * The original JSON-Fortran defaults
- ! * [RFC 6901](https://tools.ietf.org/html/rfc6901)
- ! * [JSONPath](http://goessner.net/articles/JsonPath/) "bracket-notation"
-
- subroutine json_get_by_path(json, me, path, p, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- type(json_value),pointer,intent(out) :: p !! pointer to the variable
- !! specified by `path`
- logical(LK),intent(out),optional :: found !! true if it was found
-
- character(kind=CK,len=max_integer_str_len),allocatable :: path_mode_str !! string version
- !! of `json%path_mode`
-
- nullify(p)
-
- if (.not. json%exception_thrown) then
-
- select case (json%path_mode)
- case(1_IK)
- call json%json_get_by_path_default(me, path, p, found)
- case(2_IK)
- call json%json_get_by_path_rfc6901(me, path, p, found)
- case(3_IK)
- call json%json_get_by_path_jsonpath_bracket(me, path, p, found)
- case default
- call integer_to_string(json%path_mode,int_fmt,path_mode_str)
- call json%throw_exception('Error in json_get_by_path: Unsupported path_mode: '//&
- trim(path_mode_str))
- if (present(found)) found = .false.
- end select
-
- if (present(found)) then
- if (.not. found) call json%clear_exceptions()
- end if
-
- else
- if (present(found)) found = .false.
- end if
-
- end subroutine json_get_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns the [[json_value]] pointer given the path string,
- ! If necessary, by creating the variables as needed.
- !
- ! By default, the leaf node and any empty array elements
- ! are created as `json_null` values.
- !
- ! It only works for `path_mode=1` or `path_mode=3`.
- ! An error will be thrown for `path_mode=2` (RFC 6901).
- !
- !### See also
- ! * [[json_get_by_path]]
-
- subroutine json_create_by_path(json,me,path,p,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- type(json_value),pointer,intent(out),optional :: p !! pointer to the variable
- !! specify by `path`
- logical(LK),intent(out),optional :: found !! true if there were no errors
- !! (variable found or created)
- logical(LK),intent(out),optional :: was_created !! true if it was actually created
- !! (as opposed to already being there)
-
- type(json_value),pointer :: tmp
- character(kind=CK,len=max_integer_str_len) :: path_mode_str !! string version
- !! of `json%path_mode`
-
- if (present(p)) nullify(p)
-
- if (.not. json%exception_thrown) then
-
- select case (json%path_mode)
- case(1_IK)
- call json%json_get_by_path_default(me,path,tmp,found,&
- create_it=.true.,&
- was_created=was_created)
- if (present(p)) p => tmp
- case(3_IK)
- call json%json_get_by_path_jsonpath_bracket(me,path,tmp,found,&
- create_it=.true.,&
- was_created=was_created)
- if (present(p)) p => tmp
-
- case default
-
- if (json%path_mode==2_IK) then
- ! the problem here is there isn't really a way to disambiguate
- ! the array elements, so '/a/0' could be 'a(1)' or 'a.0'.
- call json%throw_exception('Error in json_create_by_path: '//&
- 'Create by path not supported in RFC 6901 path mode.')
- else
- call integer_to_string(json%path_mode,int_fmt,path_mode_str)
- call json%throw_exception('Error in json_create_by_path: Unsupported path_mode: '//&
- trim(path_mode_str))
- end if
- if (present(found)) then
- call json%clear_exceptions()
- found = .false.
- end if
- if (present(was_created)) was_created = .false.
- end select
-
- else
- if (present(was_created)) was_created = .false.
- if (present(found)) found = .false.
- end if
-
- end subroutine json_create_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_create_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_create_by_path(json,me,path,p,found,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me !! a JSON linked list
- character(kind=CDK,len=*),intent(in) :: path !! path to the variable
- type(json_value),pointer,intent(out),optional :: p !! pointer to the variable
- !! specify by `path`
- logical(LK),intent(out),optional :: found !! true if there were no errors
- !! (variable found or created)
- logical(LK),intent(out),optional :: was_created !! true if it was actually created
- !! (as opposed to already being there)
-
- call json%create(me,to_unicode(path),p,found,was_created)
-
- end subroutine wrap_json_create_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Rename a [[json_value]], given the path.
- !
- !@note this is a wrapper for [[json_value_rename]].
-
- subroutine json_rename_by_path(json, me, path, name, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path !! path to the variable to rename
- character(kind=CK,len=*),intent(in) :: name !! the new name
- logical(LK),intent(out),optional :: found !! if there were no errors
-
- type(json_value),pointer :: p
-
- if ( json%exception_thrown ) then
- if ( present(found) ) found = .false.
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in json_rename_by_path:'//&
- ' Unable to resolve path: '//trim(path),found)
- else
- call json%rename(p,name)
- nullify(p)
- end if
-
- if (json%exception_thrown) then
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- else
- if (present(found)) found = .true.
- end if
-
- end subroutine json_rename_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_rename_by_path]], where "path" and "name" are kind=CDK
-
- subroutine wrap_json_rename_by_path(json, me, path, name, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- character(kind=CDK,len=*),intent(in) :: name
- logical(LK),intent(out),optional :: found
-
- call json%rename(me,to_unicode(path),to_unicode(name),found)
-
- end subroutine wrap_json_rename_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_rename_by_path]], where "name" is kind=CDK
-
- subroutine json_rename_by_path_name_ascii(json, me, path, name, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- character(kind=CDK,len=*),intent(in) :: name
- logical(LK),intent(out),optional :: found
-
- call json%rename(me,path,to_unicode(name),found)
-
- end subroutine json_rename_by_path_name_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_rename_by_path]], where "path" is kind=CDK
-
- subroutine json_rename_by_path_path_ascii(json, me, path, name, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- character(kind=CK,len=*),intent(in) :: name
- logical(LK),intent(out),optional :: found
-
- call json%rename(me,to_unicode(path),name,found)
-
- end subroutine json_rename_by_path_path_ascii
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns the [[json_value]] pointer given the path string.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: dat,p
- ! logical :: found
- ! !...
- ! call json%initialize(path_mode=1) ! this is the default so not strictly necessary.
- ! call json%get(dat,'data(2).version',p,found)
- !````
- !
- !### Notes
- ! The syntax used here is a subset of the
- ! [http://goessner.net/articles/JsonPath/](JSONPath) "dot–notation".
- ! The following special characters are used to denote paths:
- !
- ! * `$` - root
- ! * `@` - this
- ! * `.` - child object member (note this can be changed using `json%path_separator`)
- ! * `[]` or `()` - child array element (note that indices are 1-based)
- !
- ! Thus, if any of these characters are present in the name key,
- ! this routine cannot be used to get the value.
- ! In that case, the `get_child` methods would need to be used.
- ! Or, the alternate [[json_get_by_path_rfc6901]] could be used.
- !
- !### See also
- ! * [[json_get_by_path_rfc6901]]
- ! * [[json_get_by_path_jsonpath_bracket]]
- !
- !@note The syntax is inherited from FSON, and is basically a subset
- ! of JSONPath "dot-notation", with the additional allowance of
- ! () for array elements.
- !
- !@note JSON `null` values are used here for unknown variables when `create_it` is True.
- ! So, it is possible that an existing null variable can be converted to another
- ! type (object or array) if a child is specified in the path. Doing it this way
- ! to avoid having to use another type (say `json_unknown`) that would have to be
- ! converted to null once all the variables have been created (user would have
- ! had to do this).
- !
- !@warning See (**) in code. I think we need to protect for memory leaks when
- ! changing the type of a variable that already exists.
-
- subroutine json_get_by_path_default(json,me,path,p,found,create_it,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- type(json_value),pointer,intent(out) :: p !! pointer to the variable
- !! specify by `path`
- logical(LK),intent(out),optional :: found !! true if it was found
- logical(LK),intent(in),optional :: create_it !! if a variable is not present
- !! in the path, then it is created.
- !! the leaf node is returned as
- !! a `null` json type and can be
- !! changed by the caller.
- logical(LK),intent(out),optional :: was_created !! if `create_it` is true, this
- !! will be true if the variable
- !! was actually created. Otherwise
- !! it will be false.
-
- integer(IK) :: i !! counter of characters in `path`
- integer(IK) :: length !! significant length of `path`
- integer(IK) :: child_i !! index for getting children
- character(kind=CK,len=1) :: c !! a character in the `path`
- logical(LK) :: array !! flag when searching for array index in `path`
- type(json_value),pointer :: tmp !! temp variables for getting child objects
- logical(LK) :: child_found !! if the child value was found
- logical(LK) :: create !! if the object is to be created
- logical(LK) :: created !! if `create` is true, then this will be
- !! true if the leaf object had to be created
- integer(IK) :: j !! counter of children when creating object
- logical(LK) :: status_ok !! integer to string conversion flag
-
- nullify(p)
-
- if (.not. json%exception_thrown) then
-
- if (present(create_it)) then
- create = create_it
- else
- create = .false.
- end if
-
- ! default to assuming relative to me
- p => me
-
- child_i = 1
- array = .false.
- created = .false.
-
- !keep trailing space or not:
- if (json%trailing_spaces_significant) then
- length = len(path)
- else
- length = len_trim(path)
- end if
-
- do i=1, length
-
- c = path(i:i)
-
- select case (c)
- case (root)
-
- ! root
- do while (associated (p%parent))
- p => p%parent
- end do
- child_i = i + 1
- if (create) created = .false. ! should always exist
-
- case (this)
-
- ! this
- p => me
- child_i = i + 1
- if (create) created = .false. ! should always exist
-
- case (start_array,start_array_alt)
-
- ! start looking for the array element index
- array = .true.
-
- ! get child member from p
- if (child_i < i) then
- nullify(tmp)
- if (create) then
-
- ! Example:
- ! 'aaa.bbb(1)'
- ! -> and aaa is a null, need to make it an object
- !
- ! What about the case: aaa.bbb(1)(3) ?
- ! Is that already handled?
-
- if (p%var_type==json_null) then ! (**)
- ! if p was also created, then we need to
- ! convert it into an object here:
- p%var_type = json_object
- end if
-
- ! don't want to throw exceptions in this case
- call json%get_child(p, path(child_i:i-1), tmp, child_found)
- if (.not. child_found) then
- ! have to create this child
- ! [make it an array]
- call json_value_create(tmp)
- call json%to_array(tmp,path(child_i:i-1))
- call json%add(p,tmp)
- created = .true.
- else
- created = .false.
- end if
- else
- ! call the normal way
- call json%get_child(p, path(child_i:i-1), tmp)
- end if
- p => tmp
- else
- child_i = i + 1 ! say, '@('
- cycle
- end if
- if (.not. associated(p)) then
- call json%throw_exception('Error in json_get_by_path_default:'//&
- ' Error getting array element',found)
- exit
- end if
- child_i = i + 1
-
- case (end_array,end_array_alt)
-
- if (.not. array) then
- call json%throw_exception('Error in json_get_by_path_default:'//&
- ' Unexpected '//c,found)
- exit
- end if
- array = .false.
- call string_to_integer(path(child_i:i-1),child_i,status_ok)
- if (.not. status_ok) then
- call json%throw_exception('Error in json_get_by_path_default:'//&
- ' Could not convert array index to integer: '//&
- trim(path(child_i:i-1)),found)
- exit
- end if
-
- nullify(tmp)
- if (create) then
- ! don't want to throw exceptions in this case
- call json%get_child(p, child_i, tmp, child_found)
- if (.not. child_found) then
-
- if (p%var_type==json_null) then ! (**)
- ! if p was also created, then we need to
- ! convert it into an array here:
- p%var_type = json_array
- end if
-
- ! have to create this element
- ! [make it a null]
- ! (and any missing ones before it)
- do j = 1, child_i
- nullify(tmp)
- call json%get_child(p, j, tmp, child_found)
- if (.not. child_found) then
- call json_value_create(tmp)
- call json%to_null(tmp) ! array element doesn't need a name
- call json%add(p,tmp)
- if (j==child_i) created = .true.
- else
- if (j==child_i) created = .false.
- end if
- end do
-
- else
- created = .false.
- end if
-
- else
- ! call the normal way:
- call json%get_child(p, child_i, tmp)
- end if
-
- p => tmp
-
- child_i = i + 1
-
- case default
-
- if (c==json%path_separator) then
-
- ! get child member from p
- if (child_i < i) then
- nullify(tmp)
- if (create) then
- if (p%var_type==json_null) then ! (**)
- ! if p was also created, then we need to
- ! convert it into an object here:
- p%var_type = json_object
- end if
-
- ! don't want to throw exceptions in this case
- call json%get_child(p, path(child_i:i-1), tmp, child_found)
- if (.not. child_found) then
- ! have to create this child
- ! [make it an object]
- call json_value_create(tmp)
- call json%to_object(tmp,path(child_i:i-1))
- call json%add(p,tmp)
- created = .true.
- else
- created = .false.
- end if
- else
- ! call the normal way
- call json%get_child(p, path(child_i:i-1), tmp)
- end if
- p => tmp
- else
- child_i = i + 1 ! say '$.', '@.', or ').'
- cycle
- end if
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in json_get_by_path_default:'//&
- ' Error getting child member.',found)
- exit
- end if
-
- child_i = i + 1
-
- end if
-
- end select
-
- end do
-
- if (json%exception_thrown) then
-
- if (present(found)) then
- nullify(p) ! just in case
- found = .false.
- call json%clear_exceptions()
- end if
-
- else
-
- ! grab the last child if present in the path
- if (child_i <= length) then
- nullify(tmp)
- if (create) then
- if (p%var_type==json_null) then ! (**)
- ! if p was also created, then we need to
- ! convert it into an object here:
- p%var_type = json_object
- end if
-
- call json%get_child(p, path(child_i:i-1), tmp, child_found)
- if (.not. child_found) then
- ! have to create this child
- ! (make it a null since it is the leaf)
- call json_value_create(tmp)
- call json%to_null(tmp,path(child_i:i-1))
- call json%add(p,tmp)
- created = .true.
- else
- created = .false.
- end if
- else
- ! call the normal way
- call json%get_child(p, path(child_i:i-1), tmp)
- end if
- p => tmp
- else
- ! we already have p
- if (create .and. created) then
- ! make leaf p a null, but only
- ! if it wasn't there
- call json%to_null(p)
- end if
- end if
-
- ! error checking
- if (associated(p)) then
- if (present(found)) found = .true. !everything seems to be ok
- else
- call json%throw_exception('Error in json_get_by_path_default:'//&
- ' variable not found: '//trim(path),found)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- end if
-
- end if
-
- ! if it had to be created:
- if (present(was_created)) was_created = created
-
- else
- if (present(found)) found = .false.
- if (present(was_created)) was_created = .false.
- end if
-
- end subroutine json_get_by_path_default
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 2/4/2017
- !
- ! Returns the [[json_value]] pointer given the path string,
- ! using the "JSON Pointer" path specification defined by RFC 6901.
- !
- ! Note that trailing whitespace significance and case sensitivity
- ! are user-specified. To fully conform to the RFC 6901 standard,
- ! should probably set (via `initialize`):
- !
- ! * `case_sensitive_keys = .true.` [this is the default setting]
- ! * `trailing_spaces_significant = .true.` [this is *not* the default setting]
- ! * `allow_duplicate_keys = .false.` [this is *not* the default setting]
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: dat,p
- ! logical :: found
- ! !...
- ! call json%initialize(path_mode=2)
- ! call json%get(dat,'/data/2/version',p,found)
- !````
- !
- !### See also
- ! * [[json_get_by_path_default]]
- ! * [[json_get_by_path_jsonpath_bracket]]
- !
- !### Reference
- ! * [JavaScript Object Notation (JSON) Pointer](https://tools.ietf.org/html/rfc6901)
- !
- !@note Not doing anything special about the `-` character to index an array.
- ! This is considered a normal error.
- !
- !@note Unlike in the default path mode, the array indices here are 0-based
- ! (in accordance with the RFC 6901 standard)
- !
- !@warning Not checking if the member that is referenced is unique.
- ! (according to the standard, evaluation of non-unique references
- ! should fail). Like [[json_get_by_path_default]], this one will just return
- ! the first instance it encounters. This might be changed in the future.
- !
- !@warning I think the standard indicates that the input paths should use
- ! escaped JSON strings (currently we are assuming they are not escaped).
-
- subroutine json_get_by_path_rfc6901(json, me, path, p, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- !! (an RFC 6901 "JSON Pointer")
- type(json_value),pointer,intent(out) :: p !! pointer to the variable
- !! specify by `path`
- logical(LK),intent(out),optional :: found !! true if it was found
-
- character(kind=CK,len=:),allocatable :: token !! a token in the path (between the `/` characters)
- integer(IK) :: i !! counter
- integer(IK) :: islash_curr !! location of current '/' character in the path
- integer(IK) :: islash_next !! location of next '/' character in the path
- integer(IK) :: ilen !! length of `path` string
- type(json_value),pointer :: tmp !! temporary variable for traversing the structure
- integer(IK) :: ival !! integer array index value (0-based)
- logical(LK) :: status_ok !! error flag
- logical(LK) :: child_found !! for getting child values
-
- nullify(p)
-
- if (.not. json%exception_thrown) then
-
- p => me ! initialize
-
- if (path/=CK_'') then
-
- if (path(1:1)==slash) then ! the first character must be a slash
-
- islash_curr = 1 ! initialize current slash index
-
- !keep trailing space or not:
- if (json%trailing_spaces_significant) then
- ilen = len(path)
- else
- ilen = len_trim(path)
- end if
-
- do
-
- ! get the next token by finding the slashes
- !
- ! 1 2 3
- ! /abc/d/efg
-
- if (islash_curr==ilen) then
- !the last token is an empty string
- token = CK_''
- islash_next = 0 ! will signal to stop
- else
-
- ! .
- ! '/123/567/'
-
- ! index in remaining string:
- islash_next = index(path(islash_curr+1:ilen),slash)
- if (islash_next<=0) then
- !last token:
- token = path(islash_curr+1:ilen)
- else
- ! convert to actual index in path:
- islash_next = islash_curr + index(path(islash_curr+1:ilen),slash)
- if (islash_next>islash_curr+1) then
- token = path(islash_curr+1:islash_next-1)
- else
- !empty token:
- token = CK_''
- end if
- end if
-
- end if
-
- ! remove trailing spaces in the token here if necessary:
- if (.not. json%trailing_spaces_significant) &
- token = trim(token)
-
- ! decode the token:
- token = decode_rfc6901(token)
-
- ! now, parse the token:
-
- ! first see if there is a child with this name
- call json%get_child(p,token,tmp,child_found)
- if (child_found) then
- ! it was found
- p => tmp
- else
- ! No key with this name.
- ! Is it an integer? If so,
- ! it might be an array index.
- status_ok = (len(token)>0)
- if (status_ok) then
- do i=1,len(token)
- ! It must only contain (0..9) characters
- ! (it must be unsigned)
- if (scan(token(i:i),CK_'0123456789')<1) then
- status_ok = .false.
- exit
- end if
- end do
- if (status_ok) then
- if (len(token)>1 .and. token(1:1)==CK_'0') then
- ! leading zeros not allowed for some reason
- status_ok = .false.
- end if
- end if
- if (status_ok) then
- ! if we make it this far, it should be
- ! convertible to an integer, so do it.
- call string_to_integer(token,ival,status_ok)
- end if
- end if
- if (status_ok) then
- ! ival is an array index (0-based)
- call json%get_child(p,ival+1_IK,tmp,child_found)
- if (child_found) then
- p => tmp
- else
- ! not found
- status_ok = .false.
- end if
- end if
- if (.not. status_ok) then
- call json%throw_exception('Error in json_get_by_path_rfc6901: '//&
- 'invalid path specification: '//trim(path),found)
- exit
- end if
- end if
-
- if (islash_next<=0) exit ! finished
-
- ! set up for next token:
- islash_curr = islash_next
-
- end do
-
- else
- call json%throw_exception('Error in json_get_by_path_rfc6901: '//&
- 'invalid path specification: '//trim(path),found)
- end if
- end if
-
- if (json%exception_thrown) then
- nullify(p)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- else
- if (present(found)) found = .true.
- end if
-
- else
- if (present(found)) found = .false.
- end if
-
- end subroutine json_get_by_path_rfc6901
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 9/2/2017
- !
- ! Returns the [[json_value]] pointer given the path string,
- ! using the "JSON Pointer" path specification defined by the
- ! JSONPath "bracket-notation".
- !
- ! The first character `$` is optional, and signifies the root
- ! of the structure. If it is not present, then the first key
- ! is taken to be in the `me` object.
- !
- ! Single or real quotes may be used.
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: dat,p
- ! logical :: found
- ! !...
- ! call json%initialize(path_mode=3)
- ! call json%get(dat,"$['store']['book'][1]['title']",p,found)
- !````
- !
- !### See also
- ! * [[json_get_by_path_default]]
- ! * [[json_get_by_path_rfc6901]]
- !
- !### Reference
- ! * [JSONPath](http://goessner.net/articles/JsonPath/)
- !
- !@note Uses 1-based array indices (same as [[json_get_by_path_default]],
- ! but unlike [[json_get_by_path_rfc6901]] which uses 0-based indices).
- !
- !@note When `create_it=True`, if the variable already exists and is a type
- ! that is not compatible with the usage in the `path`, then it is
- ! destroyed and replaced with what is specified in the `path`. Note that
- ! this applies the all variables in the path as it is created. Currently,
- ! this behavior is different from [[json_get_by_path_default]].
- !
- !@note JSON `null` values are used here for unknown variables
- ! when `create_it` is True.
- !
- !@warning Note that if using single quotes, this routine cannot parse
- ! a key containing `']`. If using real quotes, this routine
- ! cannot parse a key containing `"]`. If the key contains both
- ! `']` and `"]`, there is no way to parse it using this routine.
-
- subroutine json_get_by_path_jsonpath_bracket(json,me,path,p,found,create_it,was_created)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me !! a JSON linked list
- character(kind=CK,len=*),intent(in) :: path !! path to the variable
- !! (using JSONPath
- !! "bracket-notation")
- type(json_value),pointer,intent(out) :: p !! pointer to the variable
- !! specify by `path`
- logical(LK),intent(out),optional :: found !! true if it was found
- logical(LK),intent(in),optional :: create_it !! if a variable is not present
- !! in the path, then it is created.
- !! the leaf node is returned as
- !! a `null` json type and can be
- !! changed by the caller.
- logical(LK),intent(out),optional :: was_created !! if `create_it` is true, this
- !! will be true if the variable
- !! was actually created. Otherwise
- !! it will be false.
-
- character(kind=CK,len=:),allocatable :: token !! a token in the path
- !! (between the `['']` or
- !! `[]` characters)
- integer(IK) :: istart !! location of current '['
- !! character in the path
- integer(IK) :: iend !! location of current ']'
- !! character in the path
- integer(IK) :: ival !! integer array index value
- logical(LK) :: status_ok !! error flag
- type(json_value),pointer :: tmp !! temporary variable for
- !! traversing the structure
- integer(IK) :: i !! counter
- integer(IK) :: ilen !! length of `path` string
- logical(LK) :: real_quotes !! if the keys are enclosed in `"`,
- !! rather than `'` tokens.
- logical(LK) :: create !! if the object is to be created
- logical(LK) :: created !! if `create` is true, then this will be
- !! true if the leaf object had to be created
- integer(IK) :: j !! counter of children when creating object
-
- !TODO instead of reallocating `token` all the time, just
- ! allocate a big size and keep track of the length,
- ! then just reallocate only if necessary.
- ! [would probably be inefficient if there was a very large token,
- ! and then a bunch of small ones... but for similarly-sized ones
- ! it should be way more efficient since it would avoid most
- ! reallocations.]
-
- nullify(p)
-
- if (.not. json%exception_thrown) then
-
- if (present(create_it)) then
- create = create_it
- else
- create = .false.
- end if
-
- p => me ! initialize
- created = .false.
-
- if (path==CK_'') then
- call json%throw_exception('Error in json_get_by_path_jsonpath_bracket: '//&
- 'invalid path specification: '//trim(path),found)
- else
-
- if (path(1:1)==root .or. path(1:1)==start_array) then ! the first character must be
- ! a `$` (root) or a `[`
- ! (element of `me`)
-
- if (path(1:1)==root) then
- ! go to the root
- do while (associated (p%parent))
- p => p%parent
- end do
- if (create) created = .false. ! should always exist
- end if
-
- !path length (don't need trailing spaces:)
- ilen = len_trim(path)
-
- if (ilen>1) then
-
- istart = 2 ! initialize first '[' location index
-
- do
-
- if (istart>ilen) exit ! finished
-
- ! must be the next start bracket:
- if (path(istart:istart) /= start_array) then
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'expecting "[", found: "'//trim(path(istart:istart))//&
- '" in path: '//trim(path),found)
- exit
- end if
-
- ! get the next token by checking:
- !
- ! * [''] -- is the token after istart a quote?
- ! if so, then search for the next `']`
- !
- ! * [1] -- if not, then maybe it is a number,
- ! so search for the next `]`
-
- ! verify length of remaining string
- if (istart+2<=ilen) then
-
- real_quotes = path(istart+1:istart+1) == quotation_mark ! ["
-
- if (real_quotes .or. path(istart+1:istart+1)==single_quote) then ! ['
-
- ! it might be a key value: ['abc']
-
- istart = istart + 1 ! move counter to ' index
- if (real_quotes) then
- iend = istart + index(path(istart+1:ilen),&
- quotation_mark//end_array) ! "]
- else
- iend = istart + index(path(istart+1:ilen),&
- single_quote//end_array) ! ']
- end if
- if (iend>istart) then
-
- ! istart iend
- ! | |
- ! ['p']['abcdefg']
-
- if (iend>istart+1) then
- token = path(istart+1:iend-1)
- else
- token = CK_'' ! blank string
- end if
- ! remove trailing spaces in
- ! the token here if necessary:
- if (.not. json%trailing_spaces_significant) &
- token = trim(token)
-
- if (create) then
- ! have a token, create it if necessary
-
- ! we need to convert it into an object here
- ! (e.g., if p was also just created)
- ! and destroy its data to prevent a memory leak
- call json%convert(p,json_object)
-
- ! don't want to throw exceptions in this case
- call json%get_child(p,token,tmp,status_ok)
- if (.not. status_ok) then
- ! have to create this child
- ! [make it a null since we don't
- ! know what it is yet]
- call json_value_create(tmp)
- call json%to_null(tmp,token)
- call json%add(p,tmp)
- status_ok = .true.
- created = .true.
- else
- ! it was already there.
- created = .false.
- end if
- else
- ! have a token, see if it is valid:
- call json%get_child(p,token,tmp,status_ok)
- end if
-
- if (status_ok) then
- ! it was found
- p => tmp
- else
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'invalid token found: "'//token//&
- '" in path: '//trim(path),found)
- exit
- end if
- iend = iend + 1 ! move counter to ] index
- else
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'invalid path: '//trim(path),found)
- exit
- end if
-
- else
-
- ! it might be an integer value: [123]
-
- iend = istart + index(path(istart+1:ilen),end_array) ! ]
- if (iend>istart+1) then
-
- ! this should be an integer:
- token = path(istart+1:iend-1)
-
- ! verify that there are no spaces or other
- ! characters in the string:
- status_ok = .true.
- do i=1,len(token)
- ! It must only contain (0..9) characters
- ! (it must be unsigned)
- if (scan(token(i:i),CK_'0123456789')<1) then
- status_ok = .false.
- exit
- end if
- end do
- if (status_ok) then
- call string_to_integer(token,ival,status_ok)
- if (status_ok) status_ok = ival>0 ! assuming 1-based array indices
- end if
-
- if (status_ok) then
-
- ! have a valid integer to use as an index
- ! see if this element is really there:
- call json%get_child(p,ival,tmp,status_ok)
-
- if (create .and. .not. status_ok) then
-
- ! have to create it:
-
- if (.not.(p%var_type==json_object .or. p%var_type==json_array)) then
- ! we need to convert it into an array here
- ! (e.g., if p was also just created)
- ! and destroy its data to prevent a memory leak
- call json%convert(p,json_array)
- end if
-
- ! have to create this element
- ! [make it a null]
- ! (and any missing ones before it)
- do j = 1, ival
- nullify(tmp)
- call json%get_child(p, j, tmp, status_ok)
- if (.not. status_ok) then
- call json_value_create(tmp)
- call json%to_null(tmp) ! array element doesn't need a name
- call json%add(p,tmp)
- if (j==ival) created = .true.
- else
- if (j==ival) created = .false.
- end if
- end do
- status_ok = .true.
-
- else
- created = .false.
- end if
-
- if (status_ok) then
- ! found it
- p => tmp
- else
- ! not found
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'invalid array index found: "'//token//&
- '" in path: '//trim(path),found)
- exit
- end if
- else
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'invalid token: "'//token//&
- '" in path: '//trim(path),found)
- exit
- end if
-
- else
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'invalid path: '//trim(path),found)
- exit
- end if
-
- end if
-
- else
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'invalid path: '//trim(path),found)
- exit
- end if
-
- ! set up for next token:
- istart = iend + 1
-
- end do
-
- end if
-
- else
- call json%throw_exception(&
- 'Error in json_get_by_path_jsonpath_bracket: '//&
- 'expecting "'//root//'", found: "'//path(1:1)//&
- '" in path: '//trim(path),found)
- end if
-
- end if
-
- if (json%exception_thrown) then
- nullify(p)
- if (present(found)) then
- found = .false.
- call json%clear_exceptions()
- end if
- else
- if (present(found)) found = .true.
- end if
-
- ! if it had to be created:
- if (present(was_created)) was_created = created
-
- else
- if (present(found)) found = .false.
- if (present(was_created)) was_created = .false.
- end if
-
- end subroutine json_get_by_path_jsonpath_bracket
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Convert an existing JSON variable `p` to a different variable type.
- ! The existing variable (and its children) is destroyed. It is replaced
- ! in the structure by a new variable of type `var_type`
- ! (which can be a `json_null`, `json_object` or `json_array`).
- !
- !@note This is an internal routine used when creating variables by path.
-
- subroutine convert(json,p,var_type)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! the variable to convert
- integer(IK),intent(in) :: var_type !! the variable type to convert `p` to
-
- type(json_value),pointer :: tmp !! temporary variable
- character(kind=CK,len=:),allocatable :: name !! the name of a JSON variable
-
- logical :: convert_it !! if `p` needs to be converted
-
- convert_it = p%var_type /= var_type
-
- if (convert_it) then
-
- call json%info(p,name=name) ! get existing name
-
- select case (var_type)
- case(json_object)
- call json%create_object(tmp,name)
- case(json_array)
- call json%create_array(tmp,name)
- case(json_null)
- call json%create_null(tmp,name)
- case default
- call json%throw_exception('Error in convert: invalid var_type value.')
- return
- end select
-
- call json%replace(p,tmp,destroy=.true.)
- p => tmp
- nullify(tmp)
-
- end if
-
- end subroutine convert
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_by_path]] where "path" is kind=CDK.
-
- subroutine wrap_json_get_by_path(json, me, path, p, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- type(json_value),pointer,intent(out) :: p
- logical(LK),intent(out),optional :: found
-
- call json%get(me, to_unicode(path), p, found)
-
- end subroutine wrap_json_get_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Returns the path to a JSON object that is part
- ! of a linked list structure.
- !
- ! The path returned would be suitable for input to
- ! [[json_get_by_path]] and related routines.
- !
- !@note If an error occurs (which in this case means a malformed
- ! JSON structure) then an exception will be thrown, unless
- ! `found` is present, which will be set to `false`. `path`
- ! will be a blank string.
- !
- !@note If `json%path_mode/=1`, then the `use_alt_array_tokens`
- ! and `path_sep` inputs are ignored if present.
- !
- !@note [http://goessner.net/articles/JsonPath/](JSONPath) (`path_mode=3`)
- ! does not specify whether or not the keys should be escaped (this routine
- ! assumes not, as does http://jsonpath.com).
- ! Also, we are using Fortran-style 1-based array indices,
- ! not 0-based, to agree with the assumption in `path_mode=1`
-
- subroutine json_get_path(json, p, path, found, use_alt_array_tokens, path_sep)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! a JSON linked list object
- character(kind=CK,len=:),allocatable,intent(out) :: path !! path to the variable
- logical(LK),intent(out),optional :: found !! true if there were no problems
- logical(LK),intent(in),optional :: use_alt_array_tokens !! if true, then '()' are used for array elements
- !! otherwise, '[]' are used [default]
- !! (only used if `path_mode=1`)
- character(kind=CK,len=1),intent(in),optional :: path_sep !! character to use for path separator
- !! (otherwise use `json%path_separator`)
- !! (only used if `path_mode=1`)
-
- character(kind=CK,len=:),allocatable :: name !! variable name
- character(kind=CK,len=:),allocatable :: parent_name !! variable's parent name
- character(kind=CK,len=max_integer_str_len) :: istr !! for integer to string conversion
- !! (array indices)
- type(json_value),pointer :: tmp !! for traversing the structure
- type(json_value),pointer :: element !! for traversing the structure
- integer(IK) :: var_type !! JSON variable type flag
- integer(IK) :: i !! counter
- integer(IK) :: n_children !! number of children for parent
- logical(LK) :: use_brackets !! to use '[]' characters for arrays
- logical(LK) :: parent_is_root !! if the parent is the root
- character(kind=CK,len=1) :: array_start !! for `path_mode=1`, the character to start arrays
- character(kind=CK,len=1) :: array_end !! for `path_mode=1`, the character to end arrays
- logical :: consecutive_arrays !! check for array of array case
- integer(IK) :: parents_parent_var_type !! `var_type` for parent's parent
-
- !optional input:
- if (present(use_alt_array_tokens)) then
- use_brackets = .not. use_alt_array_tokens
- else
- use_brackets = .true.
- end if
-
- if (json%path_mode==1_IK) then
- if (use_brackets) then
- array_start = start_array
- array_end = end_array
- else
- array_start = start_array_alt
- array_end = end_array_alt
- end if
- end if
-
- ! initialize:
- consecutive_arrays = .false.
-
- if (associated(p)) then
-
- !traverse the structure via parents up to the root
- tmp => p
- do
-
- if (.not. associated(tmp)) exit !finished
-
- !get info about the current variable:
- call json%info(tmp,name=name)
- if (json%path_mode==2_IK) then
- name = encode_rfc6901(name)
- end if
-
- ! if tmp a child of an object, or an element of an array
- if (associated(tmp%parent)) then
-
- !get info about the parent:
- call json%info(tmp%parent,var_type=var_type,&
- n_children=n_children,name=parent_name)
- if (json%path_mode==2_IK) then
- parent_name = encode_rfc6901(parent_name)
- end if
- if (associated(tmp%parent%parent)) then
- call json%info(tmp%parent%parent,var_type=parents_parent_var_type)
- consecutive_arrays = parents_parent_var_type == json_array .and. &
- var_type == json_array
- else
- consecutive_arrays = .false.
- end if
-
- select case (var_type)
- case (json_array)
-
- !get array index of this element:
- element => tmp%parent%children
- do i = 1, n_children
- if (.not. associated(element)) then
- call json%throw_exception('Error in json_get_path: '//&
- 'malformed JSON structure. ',found)
- exit
- end if
- if (associated(element,tmp)) then
- exit
- else
- element => element%next
- end if
- if (i==n_children) then ! it wasn't found (should never happen)
- call json%throw_exception('Error in json_get_path: '//&
- 'malformed JSON structure. ',found)
- exit
- end if
- end do
- select case(json%path_mode)
- case(3_IK)
- ! JSONPath "bracket-notation"
- ! example: `$['key'][1]`
- ! [note: this uses 1-based indices]
- call integer_to_string(i,int_fmt,istr)
- if (consecutive_arrays) then
- call add_to_path(start_array//trim(adjustl(istr))//end_array,CK_'')
- else
- call add_to_path(start_array//single_quote//parent_name//&
- single_quote//end_array//&
- start_array//trim(adjustl(istr))//end_array,CK_'')
- end if
- case(2_IK)
- ! rfc6901
- ! Example: '/key/0'
- call integer_to_string(i-1_IK,int_fmt,istr) ! 0-based index
- if (consecutive_arrays) then
- call add_to_path(trim(adjustl(istr)))
- else
- call add_to_path(parent_name//slash//trim(adjustl(istr)))
- end if
- case(1_IK)
- ! default
- ! Example: `key[1]`
- call integer_to_string(i,int_fmt,istr)
- if (consecutive_arrays) then
- call add_to_path(array_start//trim(adjustl(istr))//array_end,path_sep)
- else
- call add_to_path(parent_name//array_start//&
- trim(adjustl(istr))//array_end,path_sep)
- end if
- end select
-
- if (.not. consecutive_arrays) tmp => tmp%parent ! already added parent name
-
- case (json_object)
-
- if (.not. consecutive_arrays) then
- ! idea is not to print the array name if
- ! it was already printed with the array
-
- !process parent on the next pass
- select case(json%path_mode)
- case(3_IK)
- call add_to_path(start_array//single_quote//name//&
- single_quote//end_array,CK_'')
- case default
- call add_to_path(name,path_sep)
- end select
-
- end if
-
- case default
-
- call json%throw_exception('Error in json_get_path: '//&
- 'malformed JSON structure. '//&
- 'A variable that is not an object '//&
- 'or array should not have a child.',found)
- exit
-
- end select
-
- else
- !the last one:
- select case(json%path_mode)
- case(3_IK)
- call add_to_path(start_array//single_quote//name//&
- single_quote//end_array,CK_'')
- case default
- call add_to_path(name,path_sep)
- end select
- end if
-
- if (associated(tmp%parent)) then
- !check if the parent is the root:
- parent_is_root = (.not. associated(tmp%parent%parent))
- if (parent_is_root) exit
- end if
-
- !go to parent:
- tmp => tmp%parent
-
- end do
-
- else
- call json%throw_exception('Error in json_get_path: '//&
- 'input pointer is not associated',found)
- end if
-
- !for errors, return blank string:
- if (json%exception_thrown .or. .not. allocated(path)) then
- path = CK_''
- else
- select case (json%path_mode)
- case(3_IK)
- ! add the outer level object identifier:
- path = root//path
- case(2_IK)
- ! add the root slash:
- path = slash//path
- end select
- end if
-
- !optional output:
- if (present(found)) then
- if (json%exception_thrown) then
- found = .false.
- call json%clear_exceptions()
- else
- found = .true.
- end if
- end if
-
- contains
-
- subroutine add_to_path(str,path_sep)
- !! prepend the string to the path
- implicit none
- character(kind=CK,len=*),intent(in) :: str !! string to prepend to `path`
- character(kind=CK,len=*),intent(in),optional :: path_sep
- !! path separator (default is '.').
- !! (ignored if `json%path_mode/=1`)
-
- select case (json%path_mode)
- case(3_IK)
- ! in this case, the options are ignored
- if (.not. allocated(path)) then
- path = str
- else
- path = str//path
- end if
- case(2_IK)
- ! in this case, the options are ignored
- if (.not. allocated(path)) then
- path = str
- else
- path = str//slash//path
- end if
- case(1_IK)
- ! default path format
- if (.not. allocated(path)) then
- path = str
- else
- ! shouldn't add the path_sep for cases like x[1][2]
- ! [if current is an array element, and the previous was
- ! also an array element] so check for that here:
- if (.not. ( str(len(str):len(str))==array_end .and. &
- path(1:1)==array_start )) then
- if (present(path_sep)) then
- ! use user specified:
- path = str//path_sep//path
- else
- ! use the default:
- path = str//json%path_separator//path
- end if
- else
- path = str//path
- end if
- end if
- end select
-
- end subroutine add_to_path
-
- end subroutine json_get_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Wrapper for [[json_get_path]] where "path" and "path_sep" are kind=CDK.
-
- subroutine wrap_json_get_path(json, p, path, found, use_alt_array_tokens, path_sep)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p !! a JSON linked list object
- character(kind=CDK,len=:),allocatable,intent(out) :: path !! path to the variable
- logical(LK),intent(out),optional :: found !! true if there were no problems
- logical(LK),intent(in),optional :: use_alt_array_tokens !! if true, then '()' are used
- !! for array elements otherwise,
- !! '[]' are used [default]
- character(kind=CDK,len=1),intent(in),optional :: path_sep !! character to use for path
- !! separator (default is '.')
-
- character(kind=CK,len=:),allocatable :: ck_path !! path to the variable
-
- ! call the main routine:
- if (present(path_sep)) then
- call json%get_path(p,ck_path,found,use_alt_array_tokens,to_unicode(path_sep))
- else
- call json%get_path(p,ck_path,found,use_alt_array_tokens)
- end if
-
- ! from unicode:
- path = ck_path
-
- end subroutine wrap_json_get_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Convert a string into an integer.
- !
- !@note Replacement for the `parse_integer` function in the original code.
-
- function string_to_int(json,str) result(ival)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- character(kind=CK,len=*),intent(in) :: str !! a string
- integer(IK) :: ival !! `str` converted to an integer
-
- logical(LK) :: status_ok !! error flag for [[string_to_integer]]
-
- ! call the core routine:
- call string_to_integer(str,ival,status_ok)
-
- if (.not. status_ok) then
- ival = 0
- call json%throw_exception('Error in string_to_int: '//&
- 'string cannot be converted to an integer: '//&
- trim(str))
- end if
-
- end function string_to_int
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Convert a string into a `real(RK)` value.
-
- function string_to_dble(json,str) result(rval)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- character(kind=CK,len=*),intent(in) :: str !! a string
- real(RK) :: rval !! `str` converted to a `real(RK)`
-
- logical(LK) :: status_ok !! error flag for [[string_to_real]]
-
- call string_to_real(str,json%use_quiet_nan,rval,status_ok)
-
- if (.not. status_ok) then !if there was an error
- rval = 0.0_RK
- call json%throw_exception('Error in string_to_dble: '//&
- 'string cannot be converted to a real: '//&
- trim(str))
- end if
-
- end function string_to_dble
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get an integer value from a [[json_value]].
-
- subroutine json_get_integer(json, me, value)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- integer(IK),intent(out) :: value !! the integer value
-
- logical(LK) :: status_ok !! for [[string_to_integer]]
-
- value = 0_IK
- if ( json%exception_thrown ) return
-
- if (me%var_type == json_integer) then
- value = me%int_value
- else
- if (json%strict_type_checking) then
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_integer:'//&
- ' Unable to resolve value to integer: '//me%name)
- else
- call json%throw_exception('Error in json_get_integer:'//&
- ' Unable to resolve value to integer')
- end if
- else
- !type conversions
- select case(me%var_type)
- case (json_real)
- value = int(me%dbl_value, IK)
- case (json_logical)
- if (me%log_value) then
- value = 1_IK
- else
- value = 0_IK
- end if
- case (json_string)
- call string_to_integer(me%str_value,value,status_ok)
- if (.not. status_ok) then
- value = 0_IK
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_integer:'//&
- ' Unable to convert string value to integer: '//&
- me%name//' = '//trim(me%str_value))
- else
- call json%throw_exception('Error in json_get_integer:'//&
- ' Unable to convert string value to integer: '//&
- trim(me%str_value))
- end if
- end if
- case default
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_integer:'//&
- ' Unable to resolve value to integer: '//me%name)
- else
- call json%throw_exception('Error in json_get_integer:'//&
- ' Unable to resolve value to integer')
- end if
- end select
- end if
- end if
-
- end subroutine json_get_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get an integer value from a [[json_value]], given the path string.
-
- subroutine json_get_integer_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- integer(IK),intent(out) :: value
- logical(LK),intent(out),optional :: found
- integer(IK),intent(in),optional :: default !! default value if not found
-
- integer(IK),parameter :: default_if_not_specified = 0_IK
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_integer_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
- type(json_value),pointer :: p
-
- if (present(default)) then
- value = default
- else
- value = default_if_not_specified
- end if
-
- if ( json%exception_thrown ) then
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,value)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) value = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 8210 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_integer_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_integer_by_path]], where "path" is kind=CDK.
-
- subroutine wrap_json_get_integer_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- integer(IK),intent(out) :: value
- logical(LK),intent(out),optional :: found
- integer(IK),intent(in),optional :: default !! default value if not found
-
- call json%get(me, to_unicode(path), value, found, default)
-
- end subroutine wrap_json_get_integer_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 5/14/2014
- !
- ! Get an integer vector from a [[json_value]].
-
- subroutine json_get_integer_vec(json, me, vec)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- integer(IK),dimension(:),allocatable,intent(out) :: vec
-
- logical(LK) :: initialized
-
- if ( json%exception_thrown ) return
-
- ! check for 0-length arrays first:
- select case (me%var_type)
- case (json_array)
- if (json%count(me)==0) then
- allocate(vec(0))
- return
- end if
- end select
-
- initialized = .false.
-
- !the callback function is called for each element of the array:
- call json%get(me, array_callback=get_int_from_array)
-
- if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
-
- contains
-
- subroutine get_int_from_array(json, element, i, count)
-
- !! callback function for integer
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: element
- integer(IK),intent(in) :: i !! index
- integer(IK),intent(in) :: count !! size of array
-
- !size the output array:
- if (.not. initialized) then
- allocate(vec(count))
- initialized = .true.
- end if
-
- !populate the elements:
- call json%get(element, value=vec(i))
-
- end subroutine get_int_from_array
-
- end subroutine json_get_integer_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! If `found` is present, set it it false.
-
- subroutine flag_not_found(found)
-
- implicit none
-
- logical(LK),intent(out),optional :: found
-
- if (present(found)) found = .false.
-
- end subroutine flag_not_found
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get an integer vector from a [[json_value]], given the path string.
-
- subroutine json_get_integer_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- integer(IK),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- integer(IK),dimension(:),intent(in),optional :: default !! default value if not found
-
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_integer_vec_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
- type(json_value),pointer :: p
-
- if ( json%exception_thrown ) then
- if (present(default)) vec = default
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,vec)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) vec = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 8328 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_integer_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_integer_vec_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_integer_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- character(kind=CDK,len=*),intent(in) :: path
- integer(IK),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- integer(IK),dimension(:),intent(in),optional :: default !! default value if not found
-
- call json%get(me,path=to_unicode(path),vec=vec,found=found,default=default)
-
- end subroutine wrap_json_get_integer_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a real value from a [[json_value]].
-
- subroutine json_get_real(json, me, value)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- real(RK),intent(out) :: value
-
- logical(LK) :: status_ok !! for [[string_to_real]]
-
- value = 0.0_RK
- if ( json%exception_thrown ) return
-
- if (me%var_type == json_real) then
- value = me%dbl_value
- else
- if (json%strict_type_checking) then
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_real:'//&
- ' Unable to resolve value to real: '//me%name)
- else
- call json%throw_exception('Error in json_get_real:'//&
- ' Unable to resolve value to real')
- end if
- else
- !type conversions
- select case (me%var_type)
- case (json_integer)
- value = real(me%int_value, RK)
- case (json_logical)
- if (me%log_value) then
- value = 1.0_RK
- else
- value = 0.0_RK
- end if
- case (json_string)
- call string_to_real(me%str_value,json%use_quiet_nan,value,status_ok)
- if (.not. status_ok) then
- value = 0.0_RK
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_real:'//&
- ' Unable to convert string value to real: '//&
- me%name//' = '//trim(me%str_value))
- else
- call json%throw_exception('Error in json_get_real:'//&
- ' Unable to convert string value to real: '//&
- trim(me%str_value))
- end if
- end if
- case (json_null)
- if (ieee_support_nan(value) .and. json%null_to_real_mode/=1_IK) then
- select case (json%null_to_real_mode)
- case(2_IK)
- if (json%use_quiet_nan) then
- value = ieee_value(value,ieee_quiet_nan)
- else
- value = ieee_value(value,ieee_signaling_nan)
- end if
- case(3_IK)
- value = 0.0_RK
- end select
- else
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_real:'//&
- ' Cannot convert null to NaN: '//me%name)
- else
- call json%throw_exception('Error in json_get_real:'//&
- ' Cannot convert null to NaN')
- end if
- end if
- case default
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_real:'//&
- ' Unable to resolve value to real: '//me%name)
- else
- call json%throw_exception('Error in json_get_real:'//&
- ' Unable to resolve value to real')
- end if
- end select
- end if
- end if
-
- end subroutine json_get_real
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a real value from a [[json_value]], given the path.
-
- subroutine json_get_real_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- character(kind=CK,len=*),intent(in) :: path
- real(RK),intent(out) :: value
- logical(LK),intent(out),optional :: found
- real(RK),intent(in),optional :: default !! default value if not found
-
- real(RK),parameter :: default_if_not_specified = 0.0_RK
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_real_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
- type(json_value),pointer :: p
-
- if (present(default)) then
- value = default
- else
- value = default_if_not_specified
- end if
-
- if ( json%exception_thrown ) then
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,value)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) value = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 8460 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_real_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_real_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- character(kind=CDK,len=*),intent(in) :: path
- real(RK),intent(out) :: value
- logical(LK),intent(out),optional :: found
- real(RK),intent(in),optional :: default !! default value if not found
-
- call json%get(me,to_unicode(path),value,found,default)
-
- end subroutine wrap_json_get_real_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 5/14/2014
- !
- ! Get a real vector from a [[json_value]].
-
- subroutine json_get_real_vec(json, me, vec)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- real(RK),dimension(:),allocatable,intent(out) :: vec
-
- logical(LK) :: initialized
-
- if ( json%exception_thrown ) return
-
- ! check for 0-length arrays first:
- select case (me%var_type)
- case (json_array)
- if (json%count(me)==0) then
- allocate(vec(0))
- return
- end if
- end select
-
- initialized = .false.
-
- !the callback function is called for each element of the array:
- call json%get(me, array_callback=get_real_from_array)
-
- if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
-
- contains
-
- subroutine get_real_from_array(json, element, i, count)
-
- !! callback function for real
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: element
- integer(IK),intent(in) :: i !! index
- integer(IK),intent(in) :: count !! size of array
-
- !size the output array:
- if (.not. initialized) then
- allocate(vec(count))
- initialized = .true.
- end if
-
- !populate the elements:
- call json%get(element, value=vec(i))
-
- end subroutine get_real_from_array
-
- end subroutine json_get_real_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a real vector from a [[json_value]], given the path.
-
- subroutine json_get_real_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- real(RK),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- real(RK),dimension(:),intent(in),optional :: default !! default value if not found
-
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_real_vec_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
- type(json_value),pointer :: p
-
- if ( json%exception_thrown ) then
- if (present(default)) vec = default
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,vec)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) vec = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 8563 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_real_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real_vec_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_real_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- character(kind=CDK,len=*),intent(in) :: path
- real(RK),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- real(RK),dimension(:),intent(in),optional :: default !! default value if not found
-
- call json%get(me, to_unicode(path), vec, found, default)
-
- end subroutine wrap_json_get_real_vec_by_path
- !*****************************************************************************************
-
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real]] where value=real32.
-
- subroutine json_get_real32(json, me, value)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- real(real32),intent(out) :: value
-
- real(RK) :: tmp
-
- call json%get(me, tmp)
- value = real(tmp,real32)
-
- end subroutine json_get_real32
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real_by_path]] where value=real32.
-
- subroutine json_get_real32_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- character(kind=CK,len=*),intent(in) :: path
- real(real32),intent(out) :: value
- logical(LK),intent(out),optional :: found
- real(real32),intent(in),optional :: default !! default value if not found
-
- real(RK) :: tmp
- real(RK) :: tmp_default
-
- if (present(default)) then
- tmp_default = real(default,RK)
- call json%get(me, path, tmp, found, tmp_default)
- else
- call json%get(me, path, tmp, found)
- end if
-
- value = real(tmp,real32)
-
- end subroutine json_get_real32_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real32_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_real32_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- character(kind=CDK,len=*),intent(in) :: path
- real(real32),intent(out) :: value
- logical(LK),intent(out),optional :: found
- real(real32),intent(in),optional :: default !! default value if not found
-
- call json%get(me,to_unicode(path),value,found,default)
-
- end subroutine wrap_json_get_real32_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real_vec]] where `vec` is `real32`.
-
- subroutine json_get_real32_vec(json, me, vec)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- real(real32),dimension(:),allocatable,intent(out) :: vec
-
- real(RK),dimension(:),allocatable :: tmp
-
- call json%get(me, tmp)
- if (allocated(tmp)) vec = real(tmp,real32)
-
- end subroutine json_get_real32_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real_vec_by_path]] where `vec` is `real32`.
-
- subroutine json_get_real32_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- real(real32),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- real(real32),dimension(:),intent(in),optional :: default !! default value if not found
-
- real(RK),dimension(:),allocatable :: tmp
- real(RK),dimension(:),allocatable :: tmp_default
-
- if (present(default)) then
- tmp_default = real(default,RK)
- call json%get(me, path, tmp, found, tmp_default)
- else
- call json%get(me, path, tmp, found)
- end if
-
- if (allocated(tmp)) vec = real(tmp,real32)
-
- end subroutine json_get_real32_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_real32_vec_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_real32_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: me
- character(kind=CDK,len=*),intent(in) :: path
- real(real32),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- real(real32),dimension(:),intent(in),optional :: default !! default value if not found
-
- call json%get(me, to_unicode(path), vec, found, default)
-
- end subroutine wrap_json_get_real32_vec_by_path
- !*****************************************************************************************
-
-
- # 8855
-
-
- !*****************************************************************************************
- !>
- ! Get a logical value from a [[json_value]].
- !
- !### Note
- ! If `strict_type_checking` is False, then the following assumptions are made:
- !
- ! * For integers: a value > 0 is True
- ! * For reals: a value > 0 is True
- ! * For strings: 'true' is True, and everything else is false. [case sensitive match]
-
- subroutine json_get_logical(json, me, value)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- logical(LK),intent(out) :: value
-
- value = .false.
- if ( json%exception_thrown ) return
-
- if (me%var_type == json_logical) then
- value = me%log_value
- else
- if (json%strict_type_checking) then
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_logical: '//&
- 'Unable to resolve value to logical: '//&
- me%name)
- else
- call json%throw_exception('Error in json_get_logical: '//&
- 'Unable to resolve value to logical')
- end if
- else
- !type conversions
- select case (me%var_type)
- case (json_integer)
- value = (me%int_value > 0_IK)
- case (json_real)
- value = (me%dbl_value > 0.0_RK)
- case (json_string)
- value = (me%str_value == true_str)
- case default
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_logical: '//&
- 'Unable to resolve value to logical: '//&
- me%name)
- else
- call json%throw_exception('Error in json_get_logical: '//&
- 'Unable to resolve value to logical')
- end if
- end select
- end if
- end if
-
- end subroutine json_get_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a logical value from a [[json_value]], given the path.
-
- subroutine json_get_logical_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- logical(LK),intent(out) :: value
- logical(LK),intent(out),optional :: found
- logical(LK),intent(in),optional :: default !! default value if not found
-
- logical(LK),parameter :: default_if_not_specified = .false.
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_logical_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
- type(json_value),pointer :: p
-
- if (present(default)) then
- value = default
- else
- value = default_if_not_specified
- end if
-
- if ( json%exception_thrown ) then
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,value)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) value = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 8935 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_logical_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_logical_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_logical_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- logical(LK),intent(out) :: value
- logical(LK),intent(out),optional :: found
- logical(LK),intent(in),optional :: default !! default value if not found
-
- call json%get(me,to_unicode(path),value,found,default)
-
- end subroutine wrap_json_get_logical_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 5/14/2014
- !
- ! Get a logical vector from [[json_value]].
-
- subroutine json_get_logical_vec(json, me, vec)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- logical(LK),dimension(:),allocatable,intent(out) :: vec
-
- logical(LK) :: initialized
-
- if ( json%exception_thrown ) return
-
- ! check for 0-length arrays first:
- select case (me%var_type)
- case (json_array)
- if (json%count(me)==0) then
- allocate(vec(0))
- return
- end if
- end select
-
- initialized = .false.
-
- !the callback function is called for each element of the array:
- call json%get(me, array_callback=get_logical_from_array)
-
- if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
-
- contains
-
- subroutine get_logical_from_array(json, element, i, count)
-
- !! callback function for logical
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: element
- integer(IK),intent(in) :: i !! index
- integer(IK),intent(in) :: count !! size of array
-
- !size the output array:
- if (.not. initialized) then
- allocate(vec(count))
- initialized = .true.
- end if
-
- !populate the elements:
- call json%get(element, value=vec(i))
-
- end subroutine get_logical_from_array
-
- end subroutine json_get_logical_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a logical vector from a [[json_value]], given the path.
-
- subroutine json_get_logical_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- logical(LK),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- logical(LK),dimension(:),intent(in),optional :: default
-
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_logical_vec_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
- type(json_value),pointer :: p
-
- if ( json%exception_thrown ) then
- if (present(default)) vec = default
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,vec)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) vec = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 9038 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_logical_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_logical_vec_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_logical_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- logical(LK),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- logical(LK),dimension(:),intent(in),optional :: default
-
- call json%get(me,to_unicode(path),vec,found,default)
-
- end subroutine wrap_json_get_logical_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a character string from a [[json_value]].
-
- subroutine json_get_string(json, me, value)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=:),allocatable,intent(out) :: value
-
- value = CK_''
- if (.not. json%exception_thrown) then
-
- if (me%var_type == json_string) then
-
- if (allocated(me%str_value)) then
- if (json%unescaped_strings) then
- ! default: it is stored already unescaped:
- value = me%str_value
- else
- ! return the escaped version:
- call escape_string(me%str_value, value, json%escape_solidus)
- end if
- else
- call json%throw_exception('Error in json_get_string: '//&
- 'me%str_value not allocated')
- end if
-
- else
-
- if (json%strict_type_checking) then
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_string:'//&
- ' Unable to resolve value to string: '//me%name)
- else
- call json%throw_exception('Error in json_get_string:'//&
- ' Unable to resolve value to string')
- end if
- else
-
- select case (me%var_type)
-
- case (json_integer)
-
- if (allocated(me%int_value)) then
- value = repeat(space, max_integer_str_len)
- call integer_to_string(me%int_value,int_fmt,value)
- value = trim(value)
- else
- call json%throw_exception('Error in json_get_string: '//&
- 'me%int_value not allocated')
- end if
-
- case (json_real)
-
- if (allocated(me%dbl_value)) then
- value = repeat(space, max_numeric_str_len)
- call real_to_string(me%dbl_value,json%real_fmt,&
- json%non_normals_to_null,&
- json%compact_real,value)
- value = trim(value)
- else
- call json%throw_exception('Error in json_get_string: '//&
- 'me%int_value not allocated')
- end if
-
- case (json_logical)
-
- if (allocated(me%log_value)) then
- if (me%log_value) then
- value = true_str
- else
- value = false_str
- end if
- else
- call json%throw_exception('Error in json_get_string: '//&
- 'me%log_value not allocated')
- end if
-
- case (json_null)
-
- value = null_str
-
- case default
- if (allocated(me%name)) then
- call json%throw_exception('Error in json_get_string: '//&
- 'Unable to resolve value to characters: '//&
- me%name)
- else
- call json%throw_exception('Error in json_get_string: '//&
- 'Unable to resolve value to characters')
- end if
- end select
-
- end if
- end if
-
- end if
-
- end subroutine json_get_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a character string from a [[json_value]], given the path.
-
- subroutine json_get_string_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- character(kind=CK,len=:),allocatable,intent(out) :: value
- logical(LK),intent(out),optional :: found
- character(kind=CK,len=*),intent(in),optional :: default
-
- character(kind=CK,len=*),parameter :: default_if_not_specified = CK_''
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_string_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_scalar_by_path.inc" 1
- type(json_value),pointer :: p
-
- if (present(default)) then
- value = default
- else
- value = default_if_not_specified
- end if
-
- if ( json%exception_thrown ) then
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,value)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) value = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 9185 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_string_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_string_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_string_by_path(json, me, path, value, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- character(kind=CK,len=:),allocatable,intent(out) :: value
- logical(LK),intent(out),optional :: found
- character(kind=CK,len=*),intent(in),optional :: default
-
- call json%get(me,to_unicode(path),value,found,default)
-
- end subroutine wrap_json_get_string_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 5/14/2014
- !
- ! Get a string vector from a [[json_value(type)]].
-
- subroutine json_get_string_vec(json, me, vec)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
-
- logical(LK) :: initialized
-
- if ( json%exception_thrown ) return
-
- ! check for 0-length arrays first:
- select case (me%var_type)
- case (json_array)
- if (json%count(me)==0) then
- allocate(vec(0))
- return
- end if
- end select
-
- initialized = .false.
-
- !the callback function is called for each element of the array:
- call json%get(me, array_callback=get_chars_from_array)
-
- if (json%exception_thrown .and. allocated(vec)) deallocate(vec)
-
- contains
-
- subroutine get_chars_from_array(json, element, i, count)
-
- !! callback function for chars
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: element
- integer(IK),intent(in) :: i !! index
- integer(IK),intent(in) :: count !! size of array
-
- character(kind=CK,len=:),allocatable :: cval
-
- !size the output array:
- if (.not. initialized) then
- allocate(vec(count))
- initialized = .true.
- end if
-
- !populate the elements:
- call json%get(element, value=cval)
- if (allocated(cval)) then
- vec(i) = cval
- deallocate(cval)
- else
- vec(i) = CK_''
- end if
-
- end subroutine get_chars_from_array
-
- end subroutine json_get_string_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get a string vector from a [[json_value(type)]], given the path.
-
- subroutine json_get_string_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- character(kind=CK,len=*),dimension(:),intent(in),optional :: default
-
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_string_vec_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_vec_by_path.inc" 1
- type(json_value),pointer :: p
-
- if ( json%exception_thrown ) then
- if (present(default)) vec = default
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,vec)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) vec = default
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 9296 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_string_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_string_vec_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_string_vec_by_path(json, me, path, vec, found, default)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- character(kind=CK,len=*),dimension(:),allocatable,intent(out) :: vec
- logical(LK),intent(out),optional :: found
- character(kind=CK,len=*),dimension(:),intent(in),optional :: default
-
- call json%get(me,to_unicode(path),vec,found,default)
-
- end subroutine wrap_json_get_string_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 12/16/2016
- !
- ! Get a string vector from a [[json_value(type)]]. This is an alternate
- ! version of [[json_get_string_vec]]. This one returns an allocatable
- ! length character (where the string length is the maximum length of
- ! any element in the array). It also returns an integer array of the
- ! actual sizes of the strings in the JSON structure.
- !
- !@note This is somewhat inefficient since it does
- ! cycle through the array twice.
- !
- !@warning The allocation of `vec` doesn't work with
- ! gfortran 4.9 or 5 due to compiler bugs
-
- subroutine json_get_alloc_string_vec(json, me, vec, ilen)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
- integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
- !! of each character
- !! string in the array
-
- logical(LK) :: initialized !! if the output array has been sized
- integer(IK) :: max_len !! the length of the longest string in the array
-
- if ( json%exception_thrown ) return
-
- ! check for 0-length arrays first:
- select case (me%var_type)
- case (json_array)
- if (json%count(me)==0) then
- allocate(character(kind=CK,len=0) :: vec(0))
- allocate(ilen(0))
- return
- end if
- end select
-
- initialized = .false.
-
- call json%string_info(me,ilen=ilen,max_str_len=max_len)
- if (.not. json%exception_thrown) then
- ! now get each string using the callback function:
- call json%get(me, array_callback=get_chars_from_array)
- end if
-
- if (json%exception_thrown) then
- if (allocated(vec)) deallocate(vec)
- if (allocated(ilen)) deallocate(ilen)
- end if
-
- contains
-
- subroutine get_chars_from_array(json, element, i, count)
-
- !! callback function for chars
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: element
- integer(IK),intent(in) :: i !! index
- integer(IK),intent(in) :: count !! size of array
-
- character(kind=CK,len=:),allocatable :: cval !! for getting string
-
- !size the output array:
- if (.not. initialized) then
- ! string length long enough to hold the longest one
- ! Note that this doesn't work with gfortran 4.9 or 5.
- allocate( character(kind=CK,len=max_len) :: vec(count) )
- initialized = .true.
- end if
-
- !populate the elements:
- call json%get(element, value=cval)
- if (allocated(cval)) then
- vec(i) = cval
- ilen(i) = len(cval) ! return the actual length
- deallocate(cval)
- else
- vec(i) = CK_''
- ilen(i) = 0
- end if
-
- end subroutine get_chars_from_array
-
- end subroutine json_get_alloc_string_vec
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_alloc_string_vec]] where input is the path.
- !
- ! This is an alternate version of [[json_get_string_vec_by_path]].
- ! This one returns an allocatable length character (where the string
- ! length is the maximum length of any element in the array). It also
- ! returns an integer array of the actual sizes of the strings in the
- ! JSON structure.
- !
- !@note An alternative to using this routine is to use [[json_get_array]] with
- ! a callback function that gets the string from each element and populates
- ! a user-defined string type.
- !
- !@note If the `default` argument is used, and `default_ilen` is not present,
- ! then `ilen` will just be returned as the length of the `default` dummy
- ! argument (all elements with the same length).
-
- subroutine json_get_alloc_string_vec_by_path(json,me,path,vec,ilen,found,default,default_ilen)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
- integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
- !! of each character
- !! string in the array
- logical(LK),intent(out),optional :: found
- character(kind=CK,len=*),dimension(:),intent(in),optional :: default
- integer(IK),dimension(:),intent(in),optional :: default_ilen !! the actual
- !! length of `default`
-
- character(kind=CK,len=*),parameter :: routine = CK_'json_get_alloc_string_vec_by_path'
-
- # 1 "/home/admin/SimulationCore2/Common/json-fortran/json_get_vec_by_path_alloc.inc" 1
- type(json_value),pointer :: p
-
- if ( json%exception_thrown ) then
- if (present(default)) then
- vec = default
- if (present(default_ilen)) then
- ilen = default_ilen
- else
- allocate(ilen(size(default)))
- ilen = len(default)
- end if
- end if
- call flag_not_found(found)
- return
- end if
-
- nullify(p)
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in '//routine//':'//&
- ' Unable to resolve path: '// trim(path),found)
- else
- call json%get(p,vec,ilen)
- end if
-
- if ( json%exception_thrown ) then
- if ( present(found) .or. present(default)) then
- call flag_not_found(found)
- if (present(default)) then
- vec = default
- if (present(default_ilen)) then
- ilen = default_ilen
- else
- allocate(ilen(size(default)))
- ilen = len(default)
- end if
- end if
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
- # 9451 "/home/admin/SimulationCore2/Common/json-fortran/json_value_module.F90" 2
-
- end subroutine json_get_alloc_string_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_alloc_string_vec_by_path]], where "path" is kind=CDK
-
- subroutine wrap_json_get_alloc_string_vec_by_path(json,me,path,vec,ilen,found,default,default_ilen)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- character(kind=CK,len=:),dimension(:),allocatable,intent(out) :: vec
- integer(IK),dimension(:),allocatable,intent(out) :: ilen !! the actual length
- !! of each character
- !! string in the array
- logical(LK),intent(out),optional :: found
- character(kind=CK,len=*),dimension(:),intent(in),optional :: default
- integer(IK),dimension(:),intent(in),optional :: default_ilen !! the actual
- !! length of `default`
-
- call json%get(me,to_unicode(path),vec,ilen,found,default,default_ilen)
-
- end subroutine wrap_json_get_alloc_string_vec_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! This routine calls the user-supplied [[json_array_callback_func]]
- ! subroutine for each element in the array.
- !
- !@note For integer, real, logical, and character arrays,
- ! higher-level routines are provided (see `get` methods), so
- ! this routine does not have to be used for those cases.
-
- recursive subroutine json_get_array(json, me, array_callback)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- procedure(json_array_callback_func) :: array_callback
-
- type(json_value),pointer :: element !! temp variable for getting elements
- integer(IK) :: i !! counter
- integer(IK) :: count !! number of elements in the array
-
- if ( json%exception_thrown ) return
-
- select case (me%var_type)
- case (json_array)
- count = json%count(me)
- element => me%children
- do i = 1, count ! callback for each child
- if (.not. associated(element)) then
- call json%throw_exception('Error in json_get_array: '//&
- 'Malformed JSON linked list')
- return
- end if
- call array_callback(json, element, i, count)
- if (json%exception_thrown) exit
- element => element%next
- end do
- case default
- call json%throw_exception('Error in json_get_array:'//&
- ' Resolved value is not an array ')
- end select
-
- end subroutine json_get_array
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 4/28/2016
- !
- ! Traverse a JSON structure.
- ! This routine calls the user-specified [[json_traverse_callback_func]]
- ! for each element of the structure.
-
- subroutine json_traverse(json,p,traverse_callback)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: p
- procedure(json_traverse_callback_func) :: traverse_callback
-
- logical(LK) :: finished !! can be used to stop the process
-
- if (.not. json%exception_thrown) call traverse(p)
-
- contains
-
- recursive subroutine traverse(p)
-
- !! recursive [[json_value]] traversal.
-
- implicit none
-
- type(json_value),pointer,intent(in) :: p
-
- type(json_value),pointer :: element !! a child element
- integer(IK) :: i !! counter
- integer(IK) :: icount !! number of children
-
- if (json%exception_thrown) return
- call traverse_callback(json,p,finished) ! first call for this object
- if (finished) return
-
- !for arrays and objects, have to also call for all children:
- if (p%var_type==json_array .or. p%var_type==json_object) then
-
- icount = json%count(p) ! number of children
- if (icount>0) then
- element => p%children ! first one
- do i = 1, icount ! call for each child
- if (.not. associated(element)) then
- call json%throw_exception('Error in json_traverse: '//&
- 'Malformed JSON linked list')
- return
- end if
- call traverse(element)
- if (finished .or. json%exception_thrown) exit
- element => element%next
- end do
- end if
- nullify(element)
-
- end if
-
- end subroutine traverse
-
- end subroutine json_traverse
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! This routine calls the user-supplied array_callback subroutine
- ! for each element in the array (specified by the path).
-
- recursive subroutine json_get_array_by_path(json, me, path, array_callback, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CK,len=*),intent(in) :: path
- procedure(json_array_callback_func) :: array_callback
- logical(LK),intent(out),optional :: found
-
- type(json_value),pointer :: p
-
- if ( json%exception_thrown ) then
- if ( present(found) ) found = .false.
- return
- end if
-
- nullify(p)
-
- ! resolve the path to the value
- call json%get(me=me, path=path, p=p)
-
- if (.not. associated(p)) then
- call json%throw_exception('Error in json_get_array:'//&
- ' Unable to resolve path: '//trim(path),found)
- else
- call json%get(me=p,array_callback=array_callback)
- nullify(p)
- end if
- if ( json%exception_thrown ) then
- if ( present(found) ) then
- found = .false.
- call json%clear_exceptions()
- end if
- else
- if ( present(found) ) found = .true.
- end if
-
- end subroutine json_get_array_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_get_array_by_path]], where "path" is kind=CDK
-
- recursive subroutine wrap_json_get_array_by_path(json, me, path, array_callback, found)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer,intent(in) :: me
- character(kind=CDK,len=*),intent(in) :: path
- procedure(json_array_callback_func) :: array_callback
- logical(LK),intent(out),optional :: found
-
- call json%get(me, to_unicode(path), array_callback, found)
-
- end subroutine wrap_json_get_array_by_path
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Internal routine to be called before parsing JSON.
- ! Currently, all this does it allocate the `comment_char` if none was specified.
-
- subroutine json_prepare_parser(json)
-
- implicit none
-
- class(json_core),intent(inout) :: json
-
- if (json%allow_comments .and. .not. allocated(json%comment_char)) then
- ! comments are enabled, but user hasn't set the comment char,
- ! so in this case use the default:
- json%comment_char = CK_'/!#'
- end if
-
- end subroutine json_prepare_parser
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Parse the JSON file and populate the [[json_value]] tree.
- !
- !### Inputs
- !
- ! The inputs can be:
- !
- ! * `file` & `unit` : the specified unit is used to read JSON from file.
- ! [note if unit is already open, then the filename is ignored]
- ! * `file` : JSON is read from file using internal unit number
- !
- !### Example
- !
- !````fortran
- ! type(json_core) :: json
- ! type(json_value),pointer :: p
- ! call json%load(file='myfile.json', p=p)
- !````
- !
- !### History
- ! * Jacob Williams : 01/13/2015 : added read from string option.
- ! * Izaak Beekman : 03/08/2015 : moved read from string to separate
- ! subroutine, and error annotation to separate subroutine.
- !
- !@note When calling this routine, any exceptions thrown from previous
- ! calls will automatically be cleared.
-
- subroutine json_parse_file(json, file, p, unit)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- character(kind=CDK,len=*),intent(in) :: file !! JSON file name
- type(json_value),pointer :: p !! output structure
- integer(IK),intent(in),optional :: unit !! file unit number (/= 0)
-
- integer(IK) :: iunit !! file unit actually used
- integer(IK) :: istat !! iostat flag
- logical(LK) :: is_open !! if the file is already open
- logical(LK) :: has_duplicate !! if checking for duplicate keys
- character(kind=CK,len=:),allocatable :: path !! path to any duplicate key
-
- ! clear any exceptions and initialize:
- call json%initialize()
- call json%prepare_parser()
-
- if ( present(unit) ) then
-
- if (unit==0) then
- call json%throw_exception('Error in json_parse_file: unit number must not be 0.')
- return
- end if
-
- iunit = unit
-
- ! check to see if the file is already open
- ! if it is, then use it, otherwise open the file with the name given.
- inquire(unit=iunit, opened=is_open, iostat=istat)
- if (istat==0 .and. .not. is_open) then
- ! open the file
- open ( unit = iunit, &
- file = file, &
- status = 'OLD', &
- action = 'READ', &
- form = form_spec, &
- access = access_spec, &
- iostat = istat &
- )
- else
- ! if the file is already open, then we need to make sure
- ! that it is open with the correct form/access/etc...
- end if
-
- else
-
- ! open the file with a new unit number:
- open ( newunit = iunit, &
- file = file, &
- status = 'OLD', &
- action = 'READ', &
- form = form_spec, &
- access = access_spec, &
- iostat = istat &
- )
-
- end if
-
- if (istat==0) then
-
- if (use_unformatted_stream) then
- ! save the file size to be read:
- inquire(unit=iunit, size=json%filesize, iostat=istat)
- end if
-
- ! create the value and associate the pointer
- call json_value_create(p)
-
- ! Note: the name of the root json_value doesn't really matter,
- ! but we'll allocate something here just in case.
- p%name = trim(file) !use the file name
-
- ! parse as a value
- call json%parse_value(unit=iunit, str=CK_'', value=p)
- call json%parse_end(unit=iunit, str=CK_'')
-
- ! check for errors:
- if (json%exception_thrown) then
- call json%annotate_invalid_json(iunit,CK_'')
- else
- if (.not. json%allow_duplicate_keys) then
- call json%check_for_duplicate_keys(p,has_duplicate,path=path)
- if (.not. json%exception_thrown) then
- if (has_duplicate) then
- call json%throw_exception('Error in json_parse_file: '//&
- 'Duplicate key found: '//path)
- end if
- end if
- end if
- end if
-
- ! close the file:
- close(unit=iunit, iostat=istat)
-
- else
-
- call json%throw_exception('Error in json_parse_file: Error opening file: '//trim(file))
- nullify(p)
-
- end if
-
- end subroutine json_parse_file
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Parse the JSON string and populate the [[json_value]] tree.
- !
- !### See also
- ! * [[json_parse_file]]
-
- subroutine json_parse_string(json, p, str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! output structure
- character(kind=CK,len=*),intent(in) :: str !! string with JSON data
-
- integer(IK),parameter :: iunit = 0 !! indicates that json data will be read from buffer
-
- logical(LK) :: has_duplicate !! if checking for duplicate keys
- character(kind=CK,len=:),allocatable :: path !! path to any duplicate key
-
- ! clear any exceptions and initialize:
- call json%initialize()
- call json%prepare_parser()
-
- ! create the value and associate the pointer
- call json_value_create(p)
-
- ! Note: the name of the root json_value doesn't really matter,
- ! but we'll allocate something here just in case.
- p%name = CK_''
-
- ! parse as a value
- call json%parse_value(unit=iunit, str=str, value=p)
- call json%parse_end(unit=iunit, str=str)
-
- if (json%exception_thrown) then
- call json%annotate_invalid_json(iunit,str)
- else
- if (.not. json%allow_duplicate_keys) then
- call json%check_for_duplicate_keys(p,has_duplicate,path=path)
- if (.not. json%exception_thrown) then
- if (has_duplicate) then
- call json%throw_exception('Error in json_parse_string: '//&
- 'Duplicate key found: '//path)
- end if
- end if
- end if
- end if
-
- end subroutine json_parse_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! An error checking routine to call after a file (or string) has been parsed.
- ! It will throw an exception if there are any other non-whitespace characters
- ! in the file.
-
- subroutine json_parse_end(json, unit, str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number
- character(kind=CK,len=*),intent(in) :: str !! string containing JSON
- !! data (only used if `unit=0`)
-
- logical(LK) :: eof !! end-of-file flag
- character(kind=CK,len=1) :: c !! character read from file
- !! (or string) by [[pop_char]]
-
- ! first check for exceptions:
- if (json%exception_thrown) return
-
- ! pop the next non whitespace character off the file
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
- skip_comments=json%allow_comments, popped=c)
-
- if (.not. eof) then
- call json%throw_exception('Error in json_parse_end:'//&
- ' Unexpected character found after parsing value. "'//&
- c//'"')
- end if
-
- end subroutine json_parse_end
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_parse_string]], where `str` is kind=CDK.
-
- subroutine wrap_json_parse_string(json, p, str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p !! output structure
- character(kind=CDK,len=*),intent(in) :: str !! string with JSON data
-
- call json%deserialize(p,to_unicode(str))
-
- end subroutine wrap_json_parse_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Generate a warning message if there was an error parsing a JSON
- ! file or string.
-
- subroutine annotate_invalid_json(json,iunit,str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: iunit !! file unit number
- character(kind=CK,len=*),intent(in) :: str !! string with JSON data
-
- character(kind=CK,len=:),allocatable :: line !! line containing the error
- character(kind=CK,len=:),allocatable :: arrow_str !! arrow string that points
- !! to the current character
- character(kind=CK,len=max_integer_str_len) :: line_str !! current line number string
- character(kind=CK,len=max_integer_str_len) :: char_str !! current character count string
- integer(IK) :: i !! line number counter
- integer(IK) :: i_nl_prev !! index of previous newline character
- integer(IK) :: i_nl !! index of current newline character
-
- ! If there was an error reading the file, then
- ! print the line where the error occurred:
- if (json%exception_thrown) then
-
- !the counters for the current line and the last character read:
- call integer_to_string(json%line_count, int_fmt, line_str)
- call integer_to_string(json%char_count, int_fmt, char_str)
-
- !draw the arrow string that points to the current character:
- arrow_str = repeat('-',max( 0_IK, json%char_count - 1_IK) )//'^'
-
- if (json%line_count>0 .and. json%char_count>0) then
-
- if (iunit/=0) then
-
- if (use_unformatted_stream) then
- call json%get_current_line_from_file_stream(iunit,line)
- else
- call json%get_current_line_from_file_sequential(iunit,line)
- end if
-
- else
-
- !get the current line from the string:
- ! [this is done by counting the newline characters]
- i_nl_prev = 0 !index of previous newline character
- i_nl = 2 !just in case line_count = 0
- do i=1,json%line_count
- i_nl = index(str(i_nl_prev+1:),newline)
- if (i_nl==0) then !last line - no newline character
- i_nl = len(str)+1
- exit
- end if
- i_nl = i_nl + i_nl_prev !index of current newline character
- i_nl_prev = i_nl !update for next iteration
- end do
- line = str(i_nl_prev+1 : i_nl-1) !extract current line
-
- end if
-
- else
- !in this case, it was an empty line or file
- line = CK_''
- end if
-
- ! add a newline for the error display if necessary:
- line = trim(line)
- if (len(line)>0) then
- i = len(line)
- if (line(i:i)/=newline) line = line//newline
- else
- line = line//newline
- end if
-
- !create the error message:
- if (allocated(json%err_message)) then
- json%err_message = json%err_message//newline
- else
- json%err_message = ''
- end if
- json%err_message = json%err_message//&
- 'line: '//trim(adjustl(line_str))//', '//&
- 'character: '//trim(adjustl(char_str))//newline//&
- line//arrow_str
-
- if (allocated(line)) deallocate(line)
-
- end if
-
- end subroutine annotate_invalid_json
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Rewind the file to the beginning of the current line, and return this line.
- ! The file is assumed to be opened.
- ! This is the SEQUENTIAL version (see also [[get_current_line_from_file_stream]]).
-
- subroutine get_current_line_from_file_sequential(iunit,line)
-
- implicit none
-
- integer(IK),intent(in) :: iunit !! file unit number
- character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
-
- character(kind=CK,len=seq_chunk_size) :: chunk !! for reading line in chunks
- integer(IK) :: istat !! iostat flag
- integer(IK) :: isize !! number of characters read in read statement
-
- !initialize:
- line = CK_''
-
- !rewind to beginning of the current record:
- backspace(iunit, iostat=istat)
-
- !loop to read in all the characters in the current record.
- ![the line is read in chunks until the end of the line is reached]
- if (istat==0) then
- do
- isize = 0
- read(iunit,fmt='(A)',advance='NO',size=isize,iostat=istat) chunk
- if (istat==0) then
- line = line//chunk
- else
- if (isize>0 .and. isize<=seq_chunk_size) line = line//chunk(1:isize)
- exit
- end if
- end do
- end if
-
- end subroutine get_current_line_from_file_sequential
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Rewind the file to the beginning of the current line, and return this line.
- ! The file is assumed to be opened.
- ! This is the STREAM version (see also [[get_current_line_from_file_sequential]]).
-
- subroutine get_current_line_from_file_stream(json,iunit,line)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: iunit !! file unit number
- character(kind=CK,len=:),allocatable,intent(out) :: line !! current line
-
- integer(IK) :: istart !! start position of current line
- integer(IK) :: iend !! end position of current line
- integer(IK) :: ios !! file read `iostat` code
- character(kind=CK,len=1) :: c !! a character read from the file
- logical :: done !! flag to exit the loop
-
- istart = json%ipos
- do
- if (istart<=1) then
- istart = 1
- exit
- end if
- read(iunit,pos=istart,iostat=ios) c
- done = ios /= 0_IK
- if (.not. done) done = c==newline
- if (done) then
- if (istart/=1) istart = istart - 1
- exit
- end if
- istart = istart-1 !rewind until the beginning of the line
- end do
- iend = json%ipos
- do
- read(iunit,pos=iend,iostat=ios) c
- if (IS_IOSTAT_END(ios)) then
- ! account for end of file without linebreak
- iend=iend-1
- exit
- end if
- if (c==newline .or. ios/=0) exit
- iend=iend+1
- end do
- allocate( character(kind=CK,len=iend-istart+1) :: line )
- read(iunit,pos=istart,iostat=ios) line
-
- end subroutine get_current_line_from_file_stream
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Core parsing routine.
-
- recursive subroutine parse_value(json, unit, str, value)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number
- character(kind=CK,len=*),intent(in) :: str !! string containing JSON
- !! data (only used if `unit=0`)
- type(json_value),pointer :: value !! JSON data that is extracted
-
- logical(LK) :: eof !! end-of-file flag
- character(kind=CK,len=1) :: c !! character read from file
- !! (or string) by [[pop_char]]
- # 10121
-
-
- if (.not. json%exception_thrown) then
-
- !the routine is being called incorrectly.
- if (.not. associated(value)) then
- call json%throw_exception('Error in parse_value: value pointer not associated.')
- return
- end if
-
- ! pop the next non whitespace character off the file
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
- skip_comments=json%allow_comments, popped=c)
-
- if (eof) then
- return
- else
-
- select case (c)
-
- case (start_object)
-
- ! start object
- call json%to_object(value) !allocate class
- call json%parse_object(unit, str, value)
-
- case (start_array)
-
- ! start array
- call json%to_array(value) !allocate class
- call json%parse_array(unit, str, value)
-
- case (end_array)
-
- ! end an empty array
- call json%push_char(c)
- if (associated(value)) then
- deallocate(value)
- nullify(value)
- end if
-
- case (quotation_mark)
-
- ! string
- call json%to_string(value) !allocate class
-
- select case (value%var_type)
- case (json_string)
- # 10175
-
- call json%parse_string(unit,str,value%str_value)
-
- end select
-
- case (CK_'t') !true_str(1:1) gfortran bug work around
-
- !true
- call json%parse_for_chars(unit, str, true_str(2:))
- !allocate class and set value:
- if (.not. json%exception_thrown) call json%to_logical(value,.true.)
-
- case (CK_'f') !false_str(1:1) gfortran bug work around
-
- !false
- call json%parse_for_chars(unit, str, false_str(2:))
- !allocate class and set value:
- if (.not. json%exception_thrown) call json%to_logical(value,.false.)
-
- case (CK_'n') !null_str(1:1) gfortran bug work around
-
- !null
- call json%parse_for_chars(unit, str, null_str(2:))
- if (.not. json%exception_thrown) call json%to_null(value) ! allocate class
-
- case(CK_'-', CK_'0': CK_'9', CK_'.', CK_'+')
-
- call json%push_char(c)
- call json%parse_number(unit, str, value)
-
- case default
-
- call json%throw_exception('Error in parse_value:'//&
- ' Unexpected character while parsing value. "'//&
- c//'"')
-
- end select
- end if
-
- end if
-
- end subroutine parse_value
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Allocate a [[json_value]] pointer and make it a logical(LK) variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !````fortran
- ! type(json_value),pointer :: p
- ! type(json_core) :: json
- ! call json%create_logical(p,'value',.true.)
- !````
-
- subroutine json_value_create_logical(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- logical(LK),intent(in) :: val !! variable value
- character(kind=CK,len=*),intent(in) :: name !! variable name
-
- call json_value_create(p)
- call json%to_logical(p,val,name)
-
- end subroutine json_value_create_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Izaak Beekman
- !
- ! Wrapper for [[json_value_create_logical]] so `create_logical` method can
- ! be called with name of character kind 'DEFAULT' or 'ISO_10646'
-
- subroutine wrap_json_value_create_logical(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- logical(LK),intent(in) :: val
- character(kind=CDK,len=*),intent(in) :: name
-
- call json%create_logical(p,val,to_unicode(name))
-
- end subroutine wrap_json_value_create_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Allocate a [[json_value]] pointer and make it an integer(IK) variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !````fortran
- ! type(json_value),pointer :: p
- ! type(json_core) :: json
- ! call json%create_integer(p,'value',1)
- !````
-
- subroutine json_value_create_integer(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- integer(IK),intent(in) :: val
- character(kind=CK,len=*),intent(in) :: name
-
- call json_value_create(p)
- call json%to_integer(p,val,name)
-
- end subroutine json_value_create_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Izaak Beekman
- !
- ! A wrapper procedure for [[json_value_create_integer]] so that `create_integer`
- ! method may be called with either a 'DEFAULT' or 'ISO_10646' character kind
- ! `name` actual argument.
-
- subroutine wrap_json_value_create_integer(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- integer(IK),intent(in) :: val
- character(kind=CDK,len=*),intent(in) :: name
-
- call json%create_integer(p,val,to_unicode(name))
-
- end subroutine wrap_json_value_create_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Allocate a [[json_value]] pointer and make it a real(RK) variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !````fortran
- ! type(json_value),pointer :: p
- ! type(json_core) :: json
- ! call json%create_real(p,'value',1.0_RK)
- !````
-
- subroutine json_value_create_real(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- real(RK),intent(in) :: val
- character(kind=CK,len=*),intent(in) :: name
-
- call json_value_create(p)
- call json%to_real(p,val,name)
-
- end subroutine json_value_create_real
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Izaak Beekman
- !
- ! A wrapper for [[json_value_create_real]] so that `create_real` method
- ! may be called with an actual argument corresponding to the dummy argument,
- ! `name` that may be of 'DEFAULT' or 'ISO_10646' character kind.
-
- subroutine wrap_json_value_create_real(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- real(RK),intent(in) :: val
- character(kind=CDK,len=*),intent(in) :: name
-
- call json%create_real(p,val,to_unicode(name))
-
- end subroutine wrap_json_value_create_real
- !*****************************************************************************************
-
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_create_real]] where val=real32.
- !
- !@note The value is converted into a `real(RK)` variable internally.
-
- subroutine json_value_create_real32(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- real(real32),intent(in) :: val
- character(kind=CK,len=*),intent(in) :: name
-
- call json%create_real(p,real(val,RK),name)
-
- end subroutine json_value_create_real32
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Alternate version of [[json_value_create_real32]] where "name" is kind(CDK).
-
- subroutine wrap_json_value_create_real32(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- real(real32),intent(in) :: val
- character(kind=CDK,len=*),intent(in) :: name
-
- call json%create_real(p,val,to_unicode(name))
-
- end subroutine wrap_json_value_create_real32
- !*****************************************************************************************
-
-
- # 10443
-
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Allocate a json_value pointer and make it a string variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !````fortran
- ! type(json_value),pointer :: p
- ! type(json_core) :: json
- ! call json%create_string(p,'value','hello')
- !````
-
- subroutine json_value_create_string(json,p,val,name,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: val
- character(kind=CK,len=*),intent(in) :: name
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
-
- call json_value_create(p)
- call json%to_string(p,val,name,trim_str,adjustl_str)
-
- end subroutine json_value_create_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Izaak Beekman
- !
- ! Wrap [[json_value_create_string]] so that `create_string` method may be called
- ! with actual character string arguments for `name` and `val` that are BOTH of
- ! 'DEFAULT' or 'ISO_10646' character kind.
-
- subroutine wrap_json_value_create_string(json,p,val,name,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: val
- character(kind=CDK,len=*),intent(in) :: name
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
-
- call json%create_string(p,to_unicode(val),to_unicode(name),trim_str,adjustl_str)
-
- end subroutine wrap_json_value_create_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Allocate a json_value pointer and make it a null variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !````fortran
- ! type(json_value),pointer :: p
- ! type(json_core) :: json
- ! call json%create_null(p,'value')
- !````
-
- subroutine json_value_create_null(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name
-
- call json_value_create(p)
- call json%to_null(p,name)
-
- end subroutine json_value_create_null
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Izaak Beekman
- !
- ! Wrap [[json_value_create_null]] so that `create_null` method may be called with
- ! an actual argument corresponding to the dummy argument `name` that is either
- ! of 'DEFAULT' or 'ISO_10646' character kind.
-
- subroutine wrap_json_value_create_null(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name
-
- call json%create_null(p,to_unicode(name))
-
- end subroutine wrap_json_value_create_null
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Allocate a [[json_value]] pointer and make it an object variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !````fortran
- ! type(json_value),pointer :: p
- ! type(json_core) :: json
- ! call json%create_object(p,'objectname')
- !````
- !
- !@note The name is not significant for the root structure or an array element.
- ! In those cases, an empty string can be used.
-
- subroutine json_value_create_object(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name
-
- call json_value_create(p)
- call json%to_object(p,name)
-
- end subroutine json_value_create_object
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Izaak Beekman
- !
- ! Wrap [[json_value_create_object]] so that `create_object` method may be called
- ! with an actual argument corresponding to the dummy argument `name` that is of
- ! either 'DEFAULT' or 'ISO_10646' character kind.
-
- subroutine wrap_json_value_create_object(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name
-
- call json%create_object(p,to_unicode(name))
-
- end subroutine wrap_json_value_create_object
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Allocate a [[json_value]] pointer and make it an array variable.
- ! The pointer should not already be allocated.
- !
- !### Example
- !````fortran
- ! type(json_value),pointer :: p
- ! type(json_core) :: json
- ! call json%create_array(p,'arrayname')
- !````
-
- subroutine json_value_create_array(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in) :: name
-
- call json_value_create(p)
- call json%to_array(p,name)
-
- end subroutine json_value_create_array
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Izaak Beekman
- !
- ! A wrapper for [[json_value_create_array]] so that `create_array` method may be
- ! called with an actual argument, corresponding to the dummy argument `name`,
- ! that is either of 'DEFAULT' or 'ISO_10646' character kind.
-
- subroutine wrap_json_value_create_array(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CDK,len=*),intent(in) :: name
-
- call json%create_array(p,to_unicode(name))
-
- end subroutine wrap_json_value_create_array
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Change the [[json_value]] variable to a logical.
-
- subroutine to_logical(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- logical(LK),intent(in),optional :: val !! if the value is also to be set
- !! (if not present, then .false. is used).
- character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-
- !set type and value:
- call destroy_json_data(p)
- p%var_type = json_logical
- allocate(p%log_value)
- if (present(val)) then
- p%log_value = val
- else
- p%log_value = .false. !default value
- end if
-
- !name:
- if (present(name)) call json%rename(p,name)
-
- end subroutine to_logical
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Change the [[json_value]] variable to an integer.
-
- subroutine to_integer(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- integer(IK),intent(in),optional :: val !! if the value is also to be set
- !! (if not present, then 0 is used).
- character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-
- !set type and value:
- call destroy_json_data(p)
- p%var_type = json_integer
- allocate(p%int_value)
- if (present(val)) then
- p%int_value = val
- else
- p%int_value = 0_IK !default value
- end if
-
- !name:
- if (present(name)) call json%rename(p,name)
-
- end subroutine to_integer
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Change the [[json_value]] variable to a real.
-
- subroutine to_real(json,p,val,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- real(RK),intent(in),optional :: val !! if the value is also to be set
- !! (if not present, then 0.0_rk is used).
- character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-
- !set type and value:
- call destroy_json_data(p)
- p%var_type = json_real
- allocate(p%dbl_value)
- if (present(val)) then
- p%dbl_value = val
- else
- p%dbl_value = 0.0_RK !default value
- end if
-
- !name:
- if (present(name)) call json%rename(p,name)
-
- end subroutine to_real
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Change the [[json_value]] variable to a string.
- !
- !### Modified
- ! * Izaak Beekman : 02/24/2015
-
- subroutine to_string(json,p,val,name,trim_str,adjustl_str)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in),optional :: val !! if the value is also to be set
- !! (if not present, then '' is used).
- character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
- logical(LK),intent(in),optional :: trim_str !! if TRIM() should be called for the `val`
- !! (only used if `val` is present)
- logical(LK),intent(in),optional :: adjustl_str !! if ADJUSTL() should be called for the `val`
- !! (only used if `val` is present)
- !! (note that ADJUSTL is done before TRIM)
-
- character(kind=CK,len=:),allocatable :: str !! temp string for `trim()` and/or `adjustl()`
- logical :: trim_string !! if the string is to be trimmed
- logical :: adjustl_string !! if the string is to be adjusted left
-
- !set type and value:
- call destroy_json_data(p)
- p%var_type = json_string
- if (present(val)) then
-
- if (present(trim_str)) then
- trim_string = trim_str
- else
- trim_string = .false.
- end if
- if (present(adjustl_str)) then
- adjustl_string = adjustl_str
- else
- adjustl_string = .false.
- end if
-
- if (trim_string .or. adjustl_string) then
- str = val
- if (adjustl_string) str = adjustl(str)
- if (trim_string) str = trim(str)
- p%str_value = str
- else
- p%str_value = val
- end if
-
- else
- p%str_value = CK_'' ! default value
- end if
-
- !name:
- if (present(name)) call json%rename(p,name)
-
- end subroutine to_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Change the [[json_value]] variable to a null.
-
- subroutine to_null(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-
- !set type and value:
- call destroy_json_data(p)
- p%var_type = json_null
-
- !name:
- if (present(name)) call json%rename(p,name)
-
- end subroutine to_null
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Change the [[json_value]] variable to an object.
-
- subroutine to_object(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-
- !set type and value:
- call destroy_json_data(p)
- p%var_type = json_object
-
- !name:
- if (present(name)) call json%rename(p,name)
-
- end subroutine to_object
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Change the [[json_value]] variable to an array.
-
- subroutine to_array(json,p,name)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- type(json_value),pointer :: p
- character(kind=CK,len=*),intent(in),optional :: name !! if the name is also to be changed.
-
- !set type and value:
- call destroy_json_data(p)
- p%var_type = json_array
-
- !name:
- if (present(name)) call json%rename(p,name)
-
- end subroutine to_array
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Core parsing routine.
-
- recursive subroutine parse_object(json, unit, str, parent)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
- character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
- type(json_value),pointer :: parent !! the parsed object will be added as a child of this
-
- type(json_value),pointer :: pair !! temp variable
- logical(LK) :: eof !! end of file flag
- character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
- # 10885
-
-
- if (.not. json%exception_thrown) then
-
- !the routine is being called incorrectly.
- if (.not. associated(parent)) then
- call json%throw_exception('Error in parse_object: parent pointer not associated.')
- end if
-
- nullify(pair) !probably not necessary
-
- ! pair name
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
- skip_comments=json%allow_comments, popped=c)
- if (eof) then
- call json%throw_exception('Error in parse_object:'//&
- ' Unexpected end of file while parsing start of object.')
- return
- else if (end_object == c) then
- ! end of an empty object
- return
- else if (quotation_mark == c) then
- call json_value_create(pair)
- # 10912
-
- call json%parse_string(unit,str,pair%name)
-
- if (json%exception_thrown) then
- call json%destroy(pair)
- return
- end if
- else
- call json%throw_exception('Error in parse_object: Expecting string: "'//c//'"')
- return
- end if
-
- ! pair value
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
- skip_comments=json%allow_comments, popped=c)
- if (eof) then
- call json%destroy(pair)
- call json%throw_exception('Error in parse_object:'//&
- ' Unexpected end of file while parsing object member.')
- return
- else if (colon_char == c) then
- ! parse the value
- call json%parse_value(unit, str, pair)
- if (json%exception_thrown) then
- call json%destroy(pair)
- return
- else
- call json%add(parent, pair)
- end if
- else
- call json%destroy(pair)
- call json%throw_exception('Error in parse_object:'//&
- ' Expecting : and then a value: '//c)
- return
- end if
-
- ! another possible pair
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
- skip_comments=json%allow_comments, popped=c)
- if (eof) then
- call json%throw_exception('Error in parse_object: '//&
- 'End of file encountered when parsing an object')
- return
- else if (delimiter == c) then
- ! read the next member
- call json%parse_object(unit = unit, str=str, parent = parent)
- else if (end_object == c) then
- ! end of object
- return
- else
- call json%throw_exception('Error in parse_object: Expecting end of object: '//c)
- return
- end if
-
- end if
-
- end subroutine parse_object
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Core parsing routine.
-
- recursive subroutine parse_array(json, unit, str, array)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
- character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
- type(json_value),pointer :: array
-
- type(json_value),pointer :: element !! temp variable for array element
- logical(LK) :: eof !! end of file flag
- character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
-
- do
-
- if (json%exception_thrown) exit
-
- ! try to parse an element value
- nullify(element)
- call json_value_create(element)
- call json%parse_value(unit, str, element)
- if (json%exception_thrown) then
- if (associated(element)) call json%destroy(element)
- exit
- end if
-
- ! parse value will deallocate an empty array value
- if (associated(element)) call json%add(array, element)
-
- ! popped the next character
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., &
- skip_comments=json%allow_comments, popped=c)
-
- if (eof) then
- ! The file ended before array was finished:
- call json%throw_exception('Error in parse_array: '//&
- 'End of file encountered when parsing an array.')
- exit
- else if (delimiter == c) then
- ! parse the next element
- cycle
- else if (end_array == c) then
- ! end of array
- exit
- else
- call json%throw_exception('Error in parse_array: '//&
- 'Unexpected character encountered when parsing array.')
- exit
- end if
-
- end do
-
- end subroutine parse_array
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Parses a string while reading a JSON file.
- !
- !### History
- ! * Jacob Williams : 6/16/2014 : Added hex validation.
- ! * Jacob Williams : 12/3/2015 : Fixed some bugs.
- ! * Jacob Williams : 8/23/2015 : `string` is now returned unescaped.
- ! * Jacob Williams : 7/21/2018 : moved hex validate to [[unescape_string]].
-
- subroutine parse_string(json, unit, str, string)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number (if
- !! parsing from a file)
- character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing
- !! from a string)
- character(kind=CK,len=:),allocatable,intent(out) :: string !! the string (unescaped
- !! if necessary)
-
- logical(LK) :: eof !! end of file flag
- logical(LK) :: escape !! for escape string parsing
- character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
- integer(IK) :: ip !! index to put next character,
- !! to speed up by reducing the number
- !! of character string reallocations.
- character(kind=CK,len=:),allocatable :: error_message !! for string unescaping
-
- !at least return a blank string if there is a problem:
- string = blank_chunk
-
- if (.not. json%exception_thrown) then
-
- !initialize:
- escape = .false.
- ip = 1
-
- do
-
- !get the next character from the file:
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c)
-
- if (eof) then
-
- call json%throw_exception('Error in parse_string: Expecting end of string')
- return
-
- else if (c==quotation_mark .and. .not. escape) then !end of string
-
- exit
-
- else
-
- !if the string is not big enough, then add another chunk:
- if (ip>len(string)) string = string // blank_chunk
-
- !append to string:
- string(ip:ip) = c
- ip = ip + 1
-
- ! check for escape character, so we don't
- ! exit prematurely if escaping a quotation
- ! character:
- if (escape) then
- escape = .false.
- else
- escape = (c==backslash)
- end if
-
- end if
-
- end do
-
- !trim the string if necessary:
- if (ip<len(string)+1) then
- if (ip==1) then
- string = CK_''
- else
- string = string(1:ip-1)
- end if
- end if
-
- ! string is returned unescaped:
- ! (this will also validate any hex strings present)
- call unescape_string(string,error_message)
- if (allocated(error_message)) then
- call json%throw_exception(error_message)
- deallocate(error_message) !cleanup
- end if
-
- end if
-
- end subroutine parse_string
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Core parsing routine.
- !
- ! This is used to verify the strings `true`, `false`, and `null` during parsing.
-
- subroutine parse_for_chars(json, unit, str, chars)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
- character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
- character(kind=CK,len=*),intent(in) :: chars !! the string to check for.
-
- integer(IK) :: i !! counter
- integer(IK) :: length !! trimmed length of `chars`
- logical(LK) :: eof !! end of file flag
- character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
-
- if (.not. json%exception_thrown) then
-
- length = len_trim(chars)
-
- do i = 1, length
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.false., popped=c)
- if (eof) then
- call json%throw_exception('Error in parse_for_chars:'//&
- ' Unexpected end of file while parsing.')
- return
- else if (c /= chars(i:i)) then
- call json%throw_exception('Error in parse_for_chars:'//&
- ' Unexpected character: "'//c//'" (expecting "'//&
- chars(i:i)//'")')
- return
- end if
- end do
-
- end if
-
- end subroutine parse_for_chars
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- ! date: 1/20/2014
- !
- ! Read a numerical value from the file (or string).
- ! The routine will determine if it is an integer or a real, and
- ! allocate the type accordingly.
- !
- !@note Complete rewrite of the original FSON routine, which had some problems.
-
- subroutine parse_number(json, unit, str, value)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number (if parsing from a file)
- character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a string)
- type(json_value),pointer :: value
-
- character(kind=CK,len=:),allocatable :: tmp !! temp string
- character(kind=CK,len=:),allocatable :: saved_err_message !! temp error message for
- !! string to int conversion
- character(kind=CK,len=1) :: c !! character returned by [[pop_char]]
- logical(LK) :: eof !! end of file flag
- real(RK) :: rval !! real value
- integer(IK) :: ival !! integer value
- logical(LK) :: first !! first character
- logical(LK) :: is_integer !! it is an integer
- integer(IK) :: ip !! index to put next character
- !! [to speed up by reducing the number
- !! of character string reallocations]
-
- if (.not. json%exception_thrown) then
-
- tmp = blank_chunk
- ip = 1
- first = .true.
- is_integer = .true. !assume it may be an integer, unless otherwise determined
-
- !read one character at a time and accumulate the string:
- do
-
- !get the next character:
- call json%pop_char(unit, str=str, eof=eof, skip_ws=.true., popped=c)
-
- select case (c)
- case(CK_'-',CK_'+') !note: allowing a '+' as the first character here.
-
- if (is_integer .and. (.not. first)) is_integer = .false.
-
- !add it to the string:
- !tmp = tmp // c !...original
- if (ip>len(tmp)) tmp = tmp // blank_chunk
- tmp(ip:ip) = c
- ip = ip + 1
-
- case(CK_'.',CK_'E',CK_'e',CK_'D',CK_'d') !can be present in real numbers
-
- if (is_integer) is_integer = .false.
-
- !add it to the string:
- !tmp = tmp // c !...original
- if (ip>len(tmp)) tmp = tmp // blank_chunk
- tmp(ip:ip) = c
- ip = ip + 1
-
- case(CK_'0':CK_'9') !valid characters for numbers
-
- !add it to the string:
- !tmp = tmp // c !...original
- if (ip>len(tmp)) tmp = tmp // blank_chunk
- tmp(ip:ip) = c
- ip = ip + 1
-
- case default
-
- !push back the last character read:
- call json%push_char(c)
-
- !string to value:
- if (is_integer) then
- ! it is an integer:
- ival = json%string_to_int(tmp)
-
- if (json%exception_thrown .and. .not. json%strict_integer_type_checking) then
- ! if it couldn't be converted to an integer,
- ! then try to convert it to a real value and see if that works
-
- saved_err_message = json%err_message ! keep the original error message
- call json%clear_exceptions() ! clear exceptions
- rval = json%string_to_dble(tmp)
- if (json%exception_thrown) then
- ! restore original error message and continue
- json%err_message = saved_err_message
- call json%to_integer(value,ival) ! just so we have something
- else
- ! in this case, we return a real
- call json%to_real(value,rval)
- end if
-
- else
- call json%to_integer(value,ival)
- end if
-
- else
- ! it is a real:
- rval = json%string_to_dble(tmp)
- call json%to_real(value,rval)
- end if
-
- exit !finished
-
- end select
-
- if (first) first = .false.
-
- end do
-
- !cleanup:
- if (allocated(tmp)) deallocate(tmp)
-
- end if
-
- end subroutine parse_number
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Get the next character from the file (or string).
- !
- !### See also
- ! * [[push_char]]
- !
- !@note This routine ignores non-printing ASCII characters
- ! (`iachar<=31`) that are in strings.
-
- subroutine pop_char(json,unit,str,skip_ws,skip_comments,eof,popped)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer(IK),intent(in) :: unit !! file unit number (if parsing
- !! from a file)
- character(kind=CK,len=*),intent(in) :: str !! JSON string (if parsing from a
- !! string) -- only used if `unit=0`
- logical(LK),intent(in),optional :: skip_ws !! to ignore whitespace [default False]
- logical(LK),intent(in),optional :: skip_comments !! to ignore comment lines [default False]
- logical(LK),intent(out) :: eof !! true if the end of the file has
- !! been reached.
- character(kind=CK,len=1),intent(out) :: popped !! the popped character returned
-
- integer(IK) :: ios !! `iostat` flag
- integer(IK) :: str_len !! length of `str`
- character(kind=CK,len=1) :: c !! a character read from the file (or string)
- logical(LK) :: ignore !! if whitespace is to be ignored
- logical(LK) :: ignore_comments !! if comment lines are to be ignored
- logical(LK) :: parsing_comment !! if we are in the process
- !! of parsing a comment line
-
- if (.not. json%exception_thrown) then
-
- eof = .false.
- if (.not. present(skip_ws)) then
- ignore = .false.
- else
- ignore = skip_ws
- end if
- parsing_comment = .false.
- if (.not. present(skip_comments)) then
- ignore_comments = .false.
- else
- ignore_comments = skip_comments
- end if
-
- do
-
- if (json%pushed_index > 0) then
-
- ! there is a character pushed back on, most likely
- ! from the number parsing. Note: this can only occur if
- ! reading from a file when use_unformatted_stream=.false.
- c = json%pushed_char(json%pushed_index:json%pushed_index)
- json%pushed_index = json%pushed_index - 1
-
- else
-
- if (unit/=0) then !read from the file
-
- !read the next character:
- if (use_unformatted_stream) then
-
- ! in this case, we read the file in chunks.
- ! if we already have the character we need,
- ! then get it from the chunk. Otherwise,
- ! read in another chunk.
- if (json%ichunk<1) then
- ! read in a chunk:
- json%ichunk = 0
- if (json%filesize<json%ipos+len(json%chunk)-1) then
- ! for the last chunk, we resize
- ! it to the correct size:
- json%chunk = repeat(space, json%filesize-json%ipos+1)
- end if
- read(unit=unit,pos=json%ipos,iostat=ios) json%chunk
- else
- ios = 0
- end if
- json%ichunk = json%ichunk + 1
- if (json%ichunk>len(json%chunk)) then
- ! check this just in case
- ios = IOSTAT_END
- else
- ! get the next character from the chunk:
- c = json%chunk(json%ichunk:json%ichunk)
- if (json%ichunk==len(json%chunk)) then
- json%ichunk = 0 ! reset for next chunk
- end if
- end if
-
- else
- ! a formatted read:
- read(unit=unit,fmt='(A1)',advance='NO',iostat=ios) c
- end if
- json%ipos = json%ipos + 1
-
- else !read from the string
-
- str_len = len(str) !length of the string
- if (json%ipos<=str_len) then
- c = str(json%ipos:json%ipos)
- ios = 0
- else
- ios = IOSTAT_END !end of the string
- end if
- json%ipos = json%ipos + 1
-
- end if
-
- json%char_count = json%char_count + 1 !character count in the current line
-
- if (IS_IOSTAT_END(ios)) then !end of file
-
- ! no character to return
- json%char_count = 0
- eof = .true.
- popped = space ! just to set a value
- exit
-
- else if (IS_IOSTAT_EOR(ios) .or. c==newline) then !end of record
-
- json%char_count = 0
- json%line_count = json%line_count + 1
- if (ignore_comments) parsing_comment = .false. ! done parsing this comment line
- cycle
-
- end if
-
- end if
-
- if (ignore_comments .and. (parsing_comment .or. scan(c,json%comment_char,kind=IK)>0_IK) ) then
-
- ! skipping the comment
- parsing_comment = .true.
- cycle
-
- else if (any(c == control_chars)) then
-
- ! non printing ascii characters
- cycle
-
- else if (ignore .and. c == space) then
-
- ! ignoring whitespace
- cycle
-
- else
-
- ! return the character
- popped = c
- exit
-
- end if
-
- end do
-
- end if
-
- end subroutine pop_char
- !*****************************************************************************************
-
- !*****************************************************************************************
- !>
- ! Core routine.
- !
- !### See also
- ! * [[pop_char]]
- !
- !### History
- ! * Jacob Williams : 5/3/2015 : replaced original version of this routine.
-
- subroutine push_char(json,c)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- character(kind=CK,len=1),intent(in) :: c !! to character to push
-
- character(kind=CK,len=max_numeric_str_len) :: istr !! for error printing
-
- if (.not. json%exception_thrown) then
-
- if (use_unformatted_stream) then
-
- !in this case, c is ignored, and we just
- !decrement the stream position counter:
- json%ipos = json%ipos - 1
- json%ichunk = json%ichunk - 1
-
- else
-
- json%pushed_index = json%pushed_index + 1
-
- if (json%pushed_index>0 .and. json%pushed_index<=len(json%pushed_char)) then
- json%pushed_char(json%pushed_index:json%pushed_index) = c
- else
- call integer_to_string(json%pushed_index,int_fmt,istr)
- call json%throw_exception('Error in push_char: '//&
- 'invalid valid of pushed_index: '//trim(istr))
- end if
-
- end if
-
- !character count in the current line
- json%char_count = json%char_count - 1
-
- end if
-
- end subroutine push_char
- !*****************************************************************************************
-
- !*****************************************************************************************
- !> author: Jacob Williams
- !
- ! Print any error message, and then clear the exceptions.
- !
- !@note This routine is used by the unit tests.
- ! It was originally in json_example.f90, and was
- ! moved here 2/26/2015 by Izaak Beekman.
-
- subroutine json_print_error_message(json,io_unit)
-
- implicit none
-
- class(json_core),intent(inout) :: json
- integer, intent(in), optional :: io_unit !! unit number for
- !! printing error message
-
- character(kind=CK,len=:),allocatable :: error_msg !! error message
- logical :: status_ok !! false if there were any errors thrown
-
- !get error message:
- call json%check_for_errors(status_ok, error_msg)
-
- !print it if there is one:
- if (.not. status_ok) then
- if (present(io_unit)) then
- write(io_unit,'(A)') error_msg
- else
- write(output_unit,'(A)') error_msg
- end if
- deallocate(error_msg)
- call json%clear_exceptions()
- end if
-
- end subroutine json_print_error_message
- !*****************************************************************************************
-
- !*****************************************************************************************
- end module json_value_module
- !*****************************************************************************************
|