db.pas 212 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882
  1. {
  2. This file is part of the Free Pascal run time library.
  3. Copyright (c) 1999-2017 by Michael Van Canneyt, member of the
  4. Free Pascal development team
  5. DB database unit
  6. See the file COPYING.FPC, included in this distribution,
  7. for details about the copyright.
  8. This program is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  11. **********************************************************************}
  12. unit DB;
  13. {$mode objfpc}
  14. { $define dsdebug}
  15. interface
  16. uses Classes, SysUtils, JS, Types, DateUtils;
  17. const
  18. dsMaxBufferCount = MAXINT div 8;
  19. dsMaxStringSize = 8192;
  20. // Used in AsBoolean for string fields to determine
  21. // whether it's true or false.
  22. YesNoChars : Array[Boolean] of char = ('N', 'Y');
  23. SQLDelimiterCharacters = [';',',',' ','(',')',#13,#10,#9];
  24. type
  25. { Misc Dataset types }
  26. TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey,
  27. dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead,
  28. dsInternalCalc, dsOpening, dsRefreshFields);
  29. TDataEvent = (deFieldChange, deRecordChange, deDataSetChange,
  30. deDataSetScroll, deLayoutChange, deUpdateRecord, deUpdateState,
  31. deCheckBrowseMode, dePropertyChange, deFieldListChange, deFocusControl,
  32. deParentScroll,deConnectChange,deReconcileError,deDisabledStateChange);
  33. TUpdateStatus = (usUnmodified, usModified, usInserted, usDeleted, usResolved, usResolveFailed);
  34. TUpdateStatusSet = Set of TUpdateStatus;
  35. TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);
  36. TResolverResponse = (rrSkip, rrAbort, rrMerge, rrApply, rrIgnore);
  37. TProviderFlag = (pfInUpdate, pfInWhere, pfInKey, pfHidden, pfRefreshOnInsert,pfRefreshOnUpdate);
  38. TProviderFlags = set of TProviderFlag;
  39. { Forward declarations }
  40. TFieldDef = class;
  41. TFieldDefs = class;
  42. TField = class;
  43. TFields = Class;
  44. TDataSet = class;
  45. TDataSource = Class;
  46. TDataLink = Class;
  47. TDataProxy = Class;
  48. TDataRequest = class;
  49. TRecordUpdateDescriptor = class;
  50. TRecordUpdateDescriptorList = class;
  51. TRecordUpdateBatch = class;
  52. { Exception classes }
  53. EDatabaseError = class(Exception);
  54. EUpdateError = class(EDatabaseError)
  55. private
  56. FContext : String;
  57. FErrorCode : integer;
  58. FOriginalException : Exception;
  59. FPreviousError : Integer;
  60. public
  61. constructor Create(NativeError, Context : String;
  62. ErrCode, PrevError : integer; E: Exception); reintroduce;
  63. Destructor Destroy; override;
  64. property Context : String read FContext;
  65. property ErrorCode : integer read FErrorcode;
  66. property OriginalException : Exception read FOriginalException;
  67. property PreviousError : Integer read FPreviousError;
  68. end;
  69. { TFieldDef }
  70. TFieldClass = class of TField;
  71. // Data type for field.
  72. TFieldType = (
  73. ftUnknown, ftString, ftInteger, ftLargeInt, ftBoolean, ftFloat, ftDate,
  74. ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftFixedChar,
  75. ftVariant,ftDataset
  76. );
  77. { TDateTimeRec }
  78. TFieldAttribute = (faHiddenCol, faReadonly, faRequired, faLink, faUnNamed, faFixed);
  79. TFieldAttributes = set of TFieldAttribute;
  80. { TNamedItem }
  81. TNamedItem = class(TCollectionItem)
  82. private
  83. FName: string;
  84. protected
  85. function GetDisplayName: string; override;
  86. procedure SetDisplayName(const Value: string); override;
  87. Public
  88. property DisplayName : string read GetDisplayName write SetDisplayName;
  89. published
  90. property Name : string read FName write SetDisplayName;
  91. end;
  92. { TDefCollection }
  93. TDefCollection = class(TOwnedCollection)
  94. private
  95. FDataset: TDataset;
  96. FUpdated: boolean;
  97. protected
  98. procedure SetItemName(Item: TCollectionItem); override;
  99. public
  100. constructor create(ADataset: TDataset; AOwner: TPersistent; AClass: TCollectionItemClass); reintroduce;
  101. function Find(const AName: string): TNamedItem;
  102. procedure GetItemNames(List: TStrings);
  103. function IndexOf(const AName: string): Longint;
  104. property Dataset: TDataset read FDataset;
  105. property Updated: boolean read FUpdated write FUpdated;
  106. end;
  107. { TFieldDef }
  108. TFieldDef = class(TNamedItem)
  109. Private
  110. FAttributes : TFieldAttributes;
  111. FDataType : TFieldType;
  112. FFieldNo : Longint;
  113. FInternalCalcField : Boolean;
  114. FPrecision : Longint;
  115. FRequired : Boolean;
  116. FSize : Integer;
  117. Function GetFieldClass : TFieldClass;
  118. procedure SetAttributes(AValue: TFieldAttributes);
  119. procedure SetDataType(AValue: TFieldType);
  120. procedure SetPrecision(const AValue: Longint);
  121. procedure SetSize(const AValue: Integer);
  122. procedure SetRequired(const AValue: Boolean);
  123. public
  124. constructor Create(ACollection : TCollection); override;
  125. constructor Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint); overload;
  126. destructor Destroy; override;
  127. procedure Assign(Source: TPersistent); override;
  128. function CreateField(AOwner: TComponent): TField;
  129. property FieldClass: TFieldClass read GetFieldClass;
  130. property FieldNo: Longint read FFieldNo;
  131. property InternalCalcField: Boolean read FInternalCalcField write FInternalCalcField;
  132. property Required: Boolean read FRequired write SetRequired;
  133. Published
  134. property Attributes: TFieldAttributes read FAttributes write SetAttributes default [];
  135. property DataType: TFieldType read FDataType write SetDataType;
  136. property Precision: Longint read FPrecision write SetPrecision default 0;
  137. property Size: Integer read FSize write SetSize default 0;
  138. end;
  139. TFieldDefClass = Class of TFieldDef;
  140. { TFieldDefs }
  141. TFieldDefs = class(TDefCollection)
  142. private
  143. FHiddenFields : Boolean;
  144. function GetItem(Index: Longint): TFieldDef; reintroduce;
  145. procedure SetItem(Index: Longint; const AValue: TFieldDef); reintroduce;
  146. Protected
  147. Class Function FieldDefClass : TFieldDefClass; virtual;
  148. public
  149. constructor Create(ADataSet: TDataSet); reintroduce;
  150. // destructor Destroy; override;
  151. Function Add(const AName: string; ADataType: TFieldType; ASize, APrecision{%H-}: Integer; ARequired, AReadOnly: Boolean; AFieldNo : Integer) : TFieldDef; overload;
  152. Function Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo : Integer) : TFieldDef; overload;
  153. procedure Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean); overload;
  154. procedure Add(const AName: string; ADataType: TFieldType; ASize: Word); overload;
  155. procedure Add(const AName: string; ADataType: TFieldType); overload;
  156. Function AddFieldDef : TFieldDef;
  157. procedure Assign(FieldDefs: TFieldDefs); overload;
  158. function Find(const AName: string): TFieldDef; reintroduce;
  159. // procedure Clear;
  160. // procedure Delete(Index: Longint);
  161. procedure Update; overload;
  162. Function MakeNameUnique(const AName : String) : string; virtual;
  163. Property HiddenFields : Boolean Read FHiddenFields Write FHiddenFields;
  164. property Items[Index: Longint]: TFieldDef read GetItem write SetItem; default;
  165. end;
  166. TFieldDefsClass = Class of TFieldDefs;
  167. { TField }
  168. TFieldKind = (fkData, fkCalculated, fkLookup, fkInternalCalc);
  169. TFieldKinds = Set of TFieldKind;
  170. TFieldNotifyEvent = procedure(Sender: TField) of object;
  171. TFieldGetTextEvent = procedure(Sender: TField; var aText: string;
  172. DisplayText: Boolean) of object;
  173. TFieldSetTextEvent = procedure(Sender: TField; const aText: string) of object;
  174. TFieldChars = Array of Char;
  175. { TLookupList }
  176. TLookupList = class(TObject)
  177. private
  178. FList: TFPList;
  179. public
  180. constructor Create; reintroduce;
  181. destructor Destroy; override;
  182. procedure Add(const AKey, AValue: JSValue);
  183. procedure Clear;
  184. function FirstKeyByValue(const AValue: JSValue): JSValue;
  185. function ValueOfKey(const AKey: JSValue): JSValue;
  186. procedure ValuesToStrings(AStrings: TStrings);
  187. end;
  188. { TField }
  189. TField = class(TComponent)
  190. private
  191. FAlignment : TAlignment;
  192. FAttributeSet : String;
  193. FCalculated : Boolean;
  194. FConstraintErrorMessage : String;
  195. FCustomConstraint : String;
  196. FDataSet : TDataSet;
  197. // FDataSize : Word;
  198. FDataType : TFieldType;
  199. FDefaultExpression : String;
  200. FDisplayLabel : String;
  201. FDisplayWidth : Longint;
  202. // FEditMask: TEditMask;
  203. FFieldDef: TFieldDef;
  204. FFieldKind : TFieldKind;
  205. FFieldName : String;
  206. FFieldNo : Longint;
  207. FFields : TFields;
  208. FHasConstraints : Boolean;
  209. FImportedConstraint : String;
  210. FIsIndexField : Boolean;
  211. FKeyFields : String;
  212. FLookupCache : Boolean;
  213. FLookupDataSet : TDataSet;
  214. FLookupKeyfields : String;
  215. FLookupresultField : String;
  216. FLookupList: TLookupList;
  217. FOnChange : TFieldNotifyEvent;
  218. FOnGetText: TFieldGetTextEvent;
  219. FOnSetText: TFieldSetTextEvent;
  220. FOnValidate: TFieldNotifyEvent;
  221. FOrigin : String;
  222. FReadOnly : Boolean;
  223. FRequired : Boolean;
  224. FSize : integer;
  225. FValidChars : TFieldChars;
  226. FValueBuffer : JSValue;
  227. FValidating : Boolean;
  228. FVisible : Boolean;
  229. FProviderFlags : TProviderFlags;
  230. function GetIndex : longint;
  231. function GetLookup: Boolean;
  232. procedure SetAlignment(const AValue: TAlignMent);
  233. procedure SetIndex(const AValue: Longint);
  234. function GetDisplayText: String;
  235. function GetEditText: String;
  236. procedure SetEditText(const AValue: string);
  237. procedure SetDisplayLabel(const AValue: string);
  238. procedure SetDisplayWidth(const AValue: Longint);
  239. function GetDisplayWidth: integer;
  240. procedure SetLookup(const AValue: Boolean);
  241. procedure SetReadOnly(const AValue: Boolean);
  242. procedure SetVisible(const AValue: Boolean);
  243. function IsDisplayLabelStored : Boolean;
  244. function IsDisplayWidthStored: Boolean;
  245. function GetLookupList: TLookupList;
  246. procedure CalcLookupValue;
  247. protected
  248. Procedure RaiseAccessError(const TypeName: string);
  249. function AccessError(const TypeName: string): EDatabaseError;
  250. procedure CheckInactive;
  251. class procedure CheckTypeSize(AValue: Longint); virtual;
  252. procedure Change; virtual;
  253. procedure Bind(Binding: Boolean); virtual;
  254. procedure DataChanged;
  255. function GetAsBoolean: Boolean; virtual;
  256. function GetAsBytes: TBytes; virtual;
  257. function GetAsLargeInt: NativeInt; virtual;
  258. function GetAsDateTime: TDateTime; virtual;
  259. function GetAsFloat: Double; virtual;
  260. function GetAsLongint: Longint; virtual;
  261. function GetAsInteger: Longint; virtual;
  262. function GetAsJSValue: JSValue; virtual;
  263. function GetOldValue: JSValue; virtual;
  264. function GetAsString: string; virtual;
  265. function GetCanModify: Boolean; virtual;
  266. function GetClassDesc: String; virtual;
  267. function GetDataSize: Integer; virtual;
  268. function GetDefaultWidth: Longint; virtual;
  269. function GetDisplayName : String;
  270. function GetCurValue: JSValue; virtual;
  271. function GetNewValue: JSValue; virtual;
  272. function GetIsNull: Boolean; virtual;
  273. procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); virtual;
  274. procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  275. procedure PropertyChanged(LayoutAffected: Boolean);
  276. procedure SetAsBoolean(AValue{%H-}: Boolean); virtual;
  277. procedure SetAsDateTime(AValue{%H-}: TDateTime); virtual;
  278. procedure SetAsFloat(AValue{%H-}: Double); virtual;
  279. procedure SetAsLongint(AValue: Longint); virtual;
  280. procedure SetAsInteger(AValue{%H-}: Longint); virtual;
  281. procedure SetAsLargeInt(AValue{%H-}: NativeInt); virtual;
  282. procedure SetAsJSValue(const AValue: JSValue); virtual;
  283. procedure SetAsString(const AValue{%H-}: string); virtual;
  284. procedure SetDataset(AValue : TDataset); virtual;
  285. procedure SetDataType(AValue: TFieldType);
  286. procedure SetNewValue(const AValue: JSValue);
  287. procedure SetSize(AValue: Integer); virtual;
  288. procedure SetParentComponent(Value: TComponent); override;
  289. procedure SetText(const AValue: string); virtual;
  290. procedure SetVarValue(const AValue{%H-}: JSValue); virtual;
  291. procedure SetAsBytes(const AValue{%H-}: TBytes); virtual;
  292. public
  293. constructor Create(AOwner: TComponent); override;
  294. destructor Destroy; override;
  295. function GetParentComponent: TComponent; override;
  296. function HasParent: Boolean; override;
  297. procedure Assign(Source: TPersistent); override;
  298. procedure AssignValue(const AValue: JSValue);
  299. procedure Clear; virtual;
  300. procedure FocusControl;
  301. function GetData : JSValue;
  302. class function IsBlob: Boolean; virtual;
  303. function IsValidChar(InputChar: Char): Boolean; virtual;
  304. procedure RefreshLookupList;
  305. procedure SetData(Buffer: JSValue); overload;
  306. procedure SetFieldType(AValue{%H-}: TFieldType); virtual;
  307. procedure Validate(Buffer: Pointer);
  308. property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
  309. property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
  310. property AsFloat: Double read GetAsFloat write SetAsFloat;
  311. property AsLongint: Longint read GetAsLongint write SetAsLongint;
  312. property AsLargeInt: NativeInt read GetAsLargeInt write SetAsLargeInt;
  313. property AsInteger: Longint read GetAsInteger write SetAsInteger;
  314. property AsString: string read GetAsString write SetAsString;
  315. property AsJSValue: JSValue read GetAsJSValue write SetAsJSValue;
  316. property AttributeSet: string read FAttributeSet write FAttributeSet;
  317. property Calculated: Boolean read FCalculated write FCalculated;
  318. property CanModify: Boolean read GetCanModify;
  319. property CurValue: JSValue read GetCurValue;
  320. property DataSet: TDataSet read FDataSet write SetDataSet;
  321. property DataSize: Integer read GetDataSize;
  322. property DataType: TFieldType read FDataType;
  323. property DisplayName: String Read GetDisplayName;
  324. property DisplayText: String read GetDisplayText;
  325. property FieldNo: Longint read FFieldNo;
  326. property IsIndexField: Boolean read FIsIndexField;
  327. property IsNull: Boolean read GetIsNull;
  328. property Lookup: Boolean read GetLookup write SetLookup; deprecated;
  329. property NewValue: JSValue read GetNewValue write SetNewValue;
  330. property Size: Integer read FSize write SetSize;
  331. property Text: string read GetEditText write SetEditText;
  332. property ValidChars : TFieldChars read FValidChars write FValidChars;
  333. property Value: JSValue read GetAsJSValue write SetAsJSValue;
  334. property OldValue: JSValue read GetOldValue;
  335. property LookupList: TLookupList read GetLookupList;
  336. Property FieldDef : TFieldDef Read FFieldDef;
  337. published
  338. property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify;
  339. property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
  340. property ConstraintErrorMessage: string read FConstraintErrorMessage write FConstraintErrorMessage;
  341. property DefaultExpression: string read FDefaultExpression write FDefaultExpression;
  342. property DisplayLabel : string read GetDisplayName write SetDisplayLabel stored IsDisplayLabelStored;
  343. property DisplayWidth: Longint read GetDisplayWidth write SetDisplayWidth stored IsDisplayWidthStored;
  344. property FieldKind: TFieldKind read FFieldKind write FFieldKind;
  345. property FieldName: string read FFieldName write FFieldName;
  346. property HasConstraints: Boolean read FHasConstraints;
  347. property Index: Longint read GetIndex write SetIndex;
  348. property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
  349. property KeyFields: string read FKeyFields write FKeyFields;
  350. property LookupCache: Boolean read FLookupCache write FLookupCache;
  351. property LookupDataSet: TDataSet read FLookupDataSet write FLookupDataSet;
  352. property LookupKeyFields: string read FLookupKeyFields write FLookupKeyFields;
  353. property LookupResultField: string read FLookupResultField write FLookupResultField;
  354. property Origin: string read FOrigin write FOrigin;
  355. property ProviderFlags : TProviderFlags read FProviderFlags write FProviderFlags;
  356. property ReadOnly: Boolean read FReadOnly write SetReadOnly;
  357. property Required: Boolean read FRequired write FRequired;
  358. property Visible: Boolean read FVisible write SetVisible default True;
  359. property OnChange: TFieldNotifyEvent read FOnChange write FOnChange;
  360. property OnGetText: TFieldGetTextEvent read FOnGetText write FOnGetText;
  361. property OnSetText: TFieldSetTextEvent read FOnSetText write FOnSetText;
  362. property OnValidate: TFieldNotifyEvent read FOnValidate write FOnValidate;
  363. end;
  364. { TStringField }
  365. TStringField = class(TField)
  366. private
  367. FFixedChar : boolean;
  368. FTransliterate : Boolean;
  369. protected
  370. class procedure CheckTypeSize(AValue: Longint); override;
  371. function GetAsBoolean: Boolean; override;
  372. function GetAsDateTime: TDateTime; override;
  373. function GetAsFloat: Double; override;
  374. function GetAsInteger: Longint; override;
  375. function GetAsLargeInt: NativeInt; override;
  376. function GetAsString: String; override;
  377. function GetAsJSValue: JSValue; override;
  378. function GetDefaultWidth: Longint; override;
  379. procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
  380. procedure SetAsBoolean(AValue: Boolean); override;
  381. procedure SetAsDateTime(AValue: TDateTime); override;
  382. procedure SetAsFloat(AValue: Double); override;
  383. procedure SetAsInteger(AValue: Longint); override;
  384. procedure SetAsLargeInt(AValue: NativeInt); override;
  385. procedure SetAsString(const AValue: String); override;
  386. procedure SetVarValue(const AValue: JSValue); override;
  387. public
  388. constructor Create(AOwner: TComponent); override;
  389. procedure SetFieldType(AValue: TFieldType); override;
  390. property FixedChar : Boolean read FFixedChar write FFixedChar;
  391. property Transliterate: Boolean read FTransliterate write FTransliterate;
  392. property Value: String read GetAsString write SetAsString;
  393. published
  394. property Size default 20;
  395. end;
  396. { TNumericField }
  397. TNumericField = class(TField)
  398. Private
  399. FDisplayFormat : String;
  400. FEditFormat : String;
  401. protected
  402. class procedure CheckTypeSize(AValue: Longint); override;
  403. procedure RangeError(AValue, Min, Max: Double);
  404. procedure SetDisplayFormat(const AValue: string);
  405. procedure SetEditFormat(const AValue: string);
  406. function GetAsBoolean: Boolean; override;
  407. Procedure SetAsBoolean(AValue: Boolean); override;
  408. public
  409. constructor Create(AOwner: TComponent); override;
  410. published
  411. property Alignment default taRightJustify;
  412. property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
  413. property EditFormat: string read FEditFormat write SetEditFormat;
  414. end;
  415. { TLongintField }
  416. TIntegerField = class(TNumericField)
  417. private
  418. FMinValue,
  419. FMaxValue,
  420. FMinRange,
  421. FMaxRange : Longint;
  422. Procedure SetMinValue (AValue : longint);
  423. Procedure SetMaxValue (AValue : longint);
  424. protected
  425. function GetAsFloat: Double; override;
  426. function GetAsInteger: Longint; override;
  427. function GetAsString: string; override;
  428. function GetAsJSValue: JSValue; override;
  429. procedure GetText(var AText: string; ADisplayText: Boolean); override;
  430. function GetValue(var AValue: Longint): Boolean;
  431. procedure SetAsFloat(AValue: Double); override;
  432. procedure SetAsInteger(AValue: Longint); override;
  433. procedure SetAsString(const AValue: string); override;
  434. procedure SetVarValue(const AValue: JSValue); override;
  435. function GetAsLargeInt: NativeInt; override;
  436. procedure SetAsLargeInt(AValue: NativeInt); override;
  437. public
  438. constructor Create(AOwner: TComponent); override;
  439. Function CheckRange(AValue : Longint) : Boolean;
  440. property Value: Longint read GetAsInteger write SetAsInteger;
  441. published
  442. property MaxValue: Longint read FMaxValue write SetMaxValue default 0;
  443. property MinValue: Longint read FMinValue write SetMinValue default 0;
  444. end;
  445. { TLargeintField }
  446. TLargeintField = class(TNumericField)
  447. private
  448. FMinValue,
  449. FMaxValue,
  450. FMinRange,
  451. FMaxRange : NativeInt;
  452. Procedure SetMinValue (AValue : NativeInt);
  453. Procedure SetMaxValue (AValue : NativeInt);
  454. protected
  455. function GetAsFloat: Double; override;
  456. function GetAsInteger: Longint; override;
  457. function GetAsLargeInt: NativeInt; override;
  458. function GetAsString: string; override;
  459. function GetAsJSValue: JSValue; override;
  460. procedure GetText(var AText: string; ADisplayText: Boolean); override;
  461. function GetValue(var AValue: NativeInt): Boolean;
  462. procedure SetAsFloat(AValue: Double); override;
  463. procedure SetAsInteger(AValue: Longint); override;
  464. procedure SetAsLargeInt(AValue: NativeInt); override;
  465. procedure SetAsString(const AValue: string); override;
  466. procedure SetVarValue(const AValue: JSValue); override;
  467. public
  468. constructor Create(AOwner: TComponent); override;
  469. Function CheckRange(AValue : NativeInt) : Boolean;
  470. property Value: NativeInt read GetAsLargeInt write SetAsLargeInt;
  471. published
  472. property MaxValue: NativeInt read FMaxValue write SetMaxValue default 0;
  473. property MinValue: NativeInt read FMinValue write SetMinValue default 0;
  474. end;
  475. { TAutoIncField }
  476. TAutoIncField = class(TIntegerField)
  477. Protected
  478. procedure SetAsInteger(AValue: Longint); override;
  479. public
  480. constructor Create(AOwner: TComponent); override;
  481. end;
  482. { TFloatField }
  483. TFloatField = class(TNumericField)
  484. private
  485. FCurrency: Boolean;
  486. FMaxValue : Double;
  487. FMinValue : Double;
  488. FPrecision : Longint;
  489. procedure SetCurrency(const AValue: Boolean);
  490. procedure SetPrecision(const AValue: Longint);
  491. protected
  492. function GetAsFloat: Double; override;
  493. function GetAsLargeInt: NativeInt; override;
  494. function GetAsInteger: Longint; override;
  495. function GetAsJSValue: JSValue; override;
  496. function GetAsString: string; override;
  497. procedure GetText(var AText: string; ADisplayText: Boolean); override;
  498. procedure SetAsFloat(AValue: Double); override;
  499. procedure SetAsLargeInt(AValue: NativeInt); override;
  500. procedure SetAsInteger(AValue: Longint); override;
  501. procedure SetAsString(const AValue: string); override;
  502. procedure SetVarValue(const AValue: JSValue); override;
  503. public
  504. constructor Create(AOwner: TComponent); override;
  505. Function CheckRange(AValue : Double) : Boolean;
  506. property Value: Double read GetAsFloat write SetAsFloat;
  507. published
  508. property Currency: Boolean read FCurrency write SetCurrency default False;
  509. property MaxValue: Double read FMaxValue write FMaxValue;
  510. property MinValue: Double read FMinValue write FMinValue;
  511. property Precision: Longint read FPrecision write SetPrecision default 15; // min 2 instellen, delphi compat
  512. end;
  513. { TBooleanField }
  514. TBooleanField = class(TField)
  515. private
  516. FDisplayValues : String;
  517. // First byte indicates uppercase or not.
  518. FDisplays : Array[Boolean,Boolean] of string;
  519. Procedure SetDisplayValues(const AValue : String);
  520. protected
  521. function GetAsBoolean: Boolean; override;
  522. function GetAsString: string; override;
  523. function GetAsJSValue: JSValue; override;
  524. function GetAsInteger: Longint; override;
  525. function GetDefaultWidth: Longint; override;
  526. procedure SetAsBoolean(AValue: Boolean); override;
  527. procedure SetAsString(const AValue: string); override;
  528. procedure SetAsInteger(AValue: Longint); override;
  529. procedure SetVarValue(const AValue: JSValue); override;
  530. public
  531. constructor Create(AOwner: TComponent); override;
  532. property Value: Boolean read GetAsBoolean write SetAsBoolean;
  533. published
  534. property DisplayValues: string read FDisplayValues write SetDisplayValues;
  535. end;
  536. { TDateTimeField }
  537. TDateTimeField = class(TField)
  538. private
  539. FDisplayFormat : String;
  540. procedure SetDisplayFormat(const AValue: string);
  541. protected
  542. Function ConvertToDateTime(aValue : JSValue; aRaiseError : Boolean) : TDateTime; virtual;
  543. Function DateTimeToNativeDateTime(aValue : TDateTime) : JSValue; virtual;
  544. function GetAsDateTime: TDateTime; override;
  545. function GetAsFloat: Double; override;
  546. function GetAsString: string; override;
  547. function GetAsJSValue: JSValue; override;
  548. function GetDataSize: Integer; override;
  549. procedure GetText(var AText: string; ADisplayText: Boolean); override;
  550. procedure SetAsDateTime(AValue: TDateTime); override;
  551. procedure SetAsFloat(AValue: Double); override;
  552. procedure SetAsString(const AValue: string); override;
  553. procedure SetVarValue(const AValue: JSValue); override;
  554. public
  555. constructor Create(AOwner: TComponent); override;
  556. property Value: TDateTime read GetAsDateTime write SetAsDateTime;
  557. published
  558. property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
  559. end;
  560. { TDateField }
  561. TDateField = class(TDateTimeField)
  562. public
  563. constructor Create(AOwner: TComponent); override;
  564. end;
  565. { TTimeField }
  566. TTimeField = class(TDateTimeField)
  567. protected
  568. procedure SetAsString(const AValue: string); override;
  569. public
  570. constructor Create(AOwner: TComponent); override;
  571. end;
  572. { TBinaryField }
  573. TBinaryField = class(TField)
  574. protected
  575. class procedure CheckTypeSize(AValue: Longint); override;
  576. Function BlobToBytes(aValue : JSValue) : TBytes; virtual;
  577. Function BytesToBlob(aValue : TBytes) : JSValue; virtual;
  578. function GetAsString: string; override;
  579. function GetAsJSValue: JSValue; override;
  580. function GetValue(var AValue: TBytes): Boolean;
  581. procedure SetAsString(const AValue: string); override;
  582. procedure SetVarValue(const AValue: JSValue); override;
  583. public
  584. constructor Create(AOwner: TComponent); override;
  585. published
  586. property Size default 16;
  587. end;
  588. { TBytesField }
  589. { TBlobField }
  590. TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);
  591. // TBlobType = ftBlob..ftMemo;
  592. TBlobField = class(TBinaryField)
  593. private
  594. FModified : Boolean;
  595. // Wrapper that retrieves FDataType as a TBlobType
  596. // function GetBlobType: TBlobType;
  597. // Wrapper that calls SetFieldType
  598. // procedure SetBlobType(AValue: TBlobType);
  599. protected
  600. function GetBlobSize: Longint; virtual;
  601. function GetIsNull: Boolean; override;
  602. procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
  603. public
  604. constructor Create(AOwner: TComponent); override;
  605. procedure Clear; override;
  606. class function IsBlob: Boolean; override;
  607. procedure SetFieldType(AValue: TFieldType); override;
  608. property BlobSize: Longint read GetBlobSize;
  609. property Modified: Boolean read FModified write FModified;
  610. property Value: string read GetAsString write SetAsString;
  611. published
  612. // property BlobType: TBlobType read GetBlobType write SetBlobType; // default ftBlob;
  613. property Size default 0;
  614. end;
  615. { TMemoField }
  616. TMemoField = class(TBlobField)
  617. public
  618. constructor Create(AOwner: TComponent); override;
  619. end;
  620. { TVariantField }
  621. TVariantField = class(TField)
  622. protected
  623. class procedure CheckTypeSize(aValue{%H-}: Integer); override;
  624. function GetAsBoolean: Boolean; override;
  625. procedure SetAsBoolean(aValue: Boolean); override;
  626. function GetAsDateTime: TDateTime; override;
  627. procedure SetAsDateTime(aValue: TDateTime); override;
  628. function GetAsFloat: Double; override;
  629. procedure SetAsFloat(aValue: Double); override;
  630. function GetAsInteger: Longint; override;
  631. procedure SetAsInteger(AValue: Longint); override;
  632. function GetAsString: string; override;
  633. procedure SetAsString(const aValue: string); override;
  634. function GetAsJSValue: JSValue; override;
  635. procedure SetVarValue(const aValue: JSValue); override;
  636. public
  637. constructor Create(AOwner: TComponent); override;
  638. end;
  639. { TIndexDef }
  640. TIndexDefs = class;
  641. TIndexOption = (ixPrimary, ixUnique, ixDescending, ixCaseInsensitive,
  642. ixExpression, ixNonMaintained);
  643. TIndexOptions = set of TIndexOption;
  644. TIndexDef = class(TNamedItem)
  645. Private
  646. FCaseinsFields: string;
  647. FDescFields: string;
  648. FExpression : String;
  649. FFields : String;
  650. FOptions : TIndexOptions;
  651. FSource : String;
  652. protected
  653. function GetExpression: string;
  654. procedure SetCaseInsFields(const AValue: string); virtual;
  655. procedure SetDescFields(const AValue: string);
  656. procedure SetExpression(const AValue: string);
  657. public
  658. constructor Create(Owner: TIndexDefs; const AName, TheFields: string;
  659. TheOptions: TIndexOptions); overload;
  660. procedure Assign(Source: TPersistent); override;
  661. published
  662. property Expression: string read GetExpression write SetExpression;
  663. property Fields: string read FFields write FFields;
  664. property CaseInsFields: string read FCaseinsFields write SetCaseInsFields;
  665. property DescFields: string read FDescFields write SetDescFields;
  666. property Options: TIndexOptions read FOptions write FOptions;
  667. property Source: string read FSource write FSource;
  668. end;
  669. { TIndexDefs }
  670. TIndexDefs = class(TDefCollection)
  671. Private
  672. Function GetItem(Index: Integer): TIndexDef; reintroduce;
  673. Procedure SetItem(Index: Integer; Value: TIndexDef); reintroduce;
  674. public
  675. constructor Create(ADataSet: TDataSet); virtual; overload;
  676. procedure Add(const Name, Fields: string; Options: TIndexOptions); reintroduce;
  677. Function AddIndexDef: TIndexDef;
  678. function Find(const IndexName: string): TIndexDef; reintroduce;
  679. function FindIndexForFields(const Fields{%H-}: string): TIndexDef;
  680. function GetIndexForFields(const Fields: string;
  681. CaseInsensitive: Boolean): TIndexDef;
  682. procedure Update; overload; virtual;
  683. Property Items[Index: Integer] : TIndexDef read GetItem write SetItem; default;
  684. end;
  685. { TCheckConstraint }
  686. TCheckConstraint = class(TCollectionItem)
  687. Private
  688. FCustomConstraint : String;
  689. FErrorMessage : String;
  690. FFromDictionary : Boolean;
  691. FImportedConstraint : String;
  692. public
  693. procedure Assign(Source{%H-}: TPersistent); override;
  694. // function GetDisplayName: string; override;
  695. published
  696. property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
  697. property ErrorMessage: string read FErrorMessage write FErrorMessage;
  698. property FromDictionary: Boolean read FFromDictionary write FFromDictionary;
  699. property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
  700. end;
  701. { TCheckConstraints }
  702. TCheckConstraints = class(TCollection)
  703. Private
  704. Function GetItem(Index{%H-} : Longint) : TCheckConstraint; reintroduce;
  705. Procedure SetItem(index{%H-} : Longint; Value{%H-} : TCheckConstraint); reintroduce;
  706. protected
  707. function GetOwner: TPersistent; override;
  708. public
  709. constructor Create(AOwner{%H-}: TPersistent); reintroduce;
  710. function Add: TCheckConstraint; reintroduce;
  711. property Items[Index: Longint]: TCheckConstraint read GetItem write SetItem; default;
  712. end;
  713. { TFieldsEnumerator }
  714. TFieldsEnumerator = class
  715. private
  716. FPosition: Integer;
  717. FFields: TFields;
  718. function GetCurrent: TField;
  719. public
  720. constructor Create(AFields: TFields); reintroduce;
  721. function MoveNext: Boolean;
  722. property Current: TField read GetCurrent;
  723. end;
  724. { TFields }
  725. TFields = Class(TObject)
  726. Private
  727. FDataset : TDataset;
  728. FFieldList : TFpList;
  729. FOnChange : TNotifyEvent;
  730. FValidFieldKinds : TFieldKinds;
  731. Protected
  732. Procedure ClearFieldDefs;
  733. Procedure Changed;
  734. Procedure CheckfieldKind(Fieldkind : TFieldKind; Field : TField);
  735. Function GetCount : Longint;
  736. Function GetField (Index : Integer) : TField;
  737. Procedure SetField(Index: Integer; Value: TField);
  738. Procedure SetFieldIndex (Field : TField;Value : Integer);
  739. Property OnChange : TNotifyEvent Read FOnChange Write FOnChange;
  740. Property ValidFieldKinds : TFieldKinds Read FValidFieldKinds;
  741. Public
  742. Constructor Create(ADataset : TDataset); reintroduce;
  743. Destructor Destroy;override;
  744. Procedure Add(Field : TField);
  745. Procedure CheckFieldName (Const Value : String);
  746. Procedure CheckFieldNames (Const Value : String);
  747. Procedure Clear;
  748. Function FindField (Const Value : String) : TField;
  749. Function FieldByName (Const Value : String) : TField;
  750. Function FieldByNumber(FieldNo : Integer) : TField;
  751. Function GetEnumerator: TFieldsEnumerator;
  752. Procedure GetFieldNames (Values : TStrings);
  753. Function IndexOf(Field : TField) : Longint;
  754. procedure Remove(Value : TField);
  755. Property Count : Integer Read GetCount;
  756. Property Dataset : TDataset Read FDataset;
  757. Property Fields [Index : Integer] : TField Read GetField Write SetField; default;
  758. end;
  759. TFieldsClass = Class of TFields;
  760. { TParam }
  761. TBlobData = TBytes; // Delphi defines it as alias to TBytes
  762. TParamBinding = array of integer;
  763. TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult);
  764. TParamTypes = set of TParamType;
  765. TParamStyle = (psInterbase,psPostgreSQL,psSimulated);
  766. TParams = class;
  767. TParam = class(TCollectionItem)
  768. private
  769. FValue: JSValue;
  770. FPrecision: Integer;
  771. FNumericScale: Integer;
  772. FName: string;
  773. FDataType: TFieldType;
  774. FBound: Boolean;
  775. FParamType: TParamType;
  776. FSize: Integer;
  777. Function GetDataSet: TDataSet;
  778. Function IsParamStored: Boolean;
  779. protected
  780. Procedure AssignParam(Param: TParam);
  781. Procedure AssignTo(Dest: TPersistent); override;
  782. Function GetAsBoolean: Boolean;
  783. Function GetAsBytes: TBytes;
  784. Function GetAsDateTime: TDateTime;
  785. Function GetAsFloat: Double;
  786. Function GetAsInteger: Longint;
  787. Function GetAsLargeInt: NativeInt;
  788. Function GetAsMemo: string;
  789. Function GetAsString: string;
  790. Function GetAsJSValue: JSValue;
  791. Function GetDisplayName: string; override;
  792. Function GetIsNull: Boolean;
  793. Function IsEqual(AValue: TParam): Boolean;
  794. Procedure SetAsBlob(const AValue: TBlobData);
  795. Procedure SetAsBoolean(AValue: Boolean);
  796. Procedure SetAsBytes(const AValue{%H-}: TBytes);
  797. Procedure SetAsDate(const AValue: TDateTime);
  798. Procedure SetAsDateTime(const AValue: TDateTime);
  799. Procedure SetAsFloat(const AValue: Double);
  800. Procedure SetAsInteger(AValue: Longint);
  801. Procedure SetAsLargeInt(AValue: NativeInt);
  802. Procedure SetAsMemo(const AValue: string);
  803. Procedure SetAsString(const AValue: string);
  804. Procedure SetAsTime(const AValue: TDateTime);
  805. Procedure SetAsJSValue(const AValue: JSValue);
  806. Procedure SetDataType(AValue: TFieldType);
  807. Procedure SetText(const AValue: string);
  808. public
  809. constructor Create(ACollection: TCollection); overload; override;
  810. constructor Create(AParams: TParams; AParamType: TParamType); reintroduce; overload;
  811. Procedure Assign(Source: TPersistent); override;
  812. Procedure AssignField(Field: TField);
  813. Procedure AssignToField(Field: TField);
  814. Procedure AssignFieldValue(Field: TField; const AValue: JSValue);
  815. Procedure AssignFromField(Field : TField);
  816. Procedure Clear;
  817. Property AsBlob : TBlobData read GetAsBytes write SetAsBytes;
  818. Property AsBoolean : Boolean read GetAsBoolean write SetAsBoolean;
  819. Property AsBytes : TBytes read GetAsBytes write SetAsBytes;
  820. Property AsDate : TDateTime read GetAsDateTime write SetAsDate;
  821. Property AsDateTime : TDateTime read GetAsDateTime write SetAsDateTime;
  822. Property AsFloat : Double read GetAsFloat write SetAsFloat;
  823. Property AsInteger : LongInt read GetAsInteger write SetAsInteger;
  824. Property AsLargeInt : NativeInt read GetAsLargeInt write SetAsLargeInt;
  825. Property AsMemo : string read GetAsMemo write SetAsMemo;
  826. Property AsSmallInt : LongInt read GetAsInteger write SetAsInteger;
  827. Property AsString : string read GetAsString write SetAsString;
  828. Property AsTime : TDateTime read GetAsDateTime write SetAsTime;
  829. Property Bound : Boolean read FBound write FBound;
  830. Property Dataset : TDataset Read GetDataset;
  831. Property IsNull : Boolean read GetIsNull;
  832. Property Text : string read GetAsString write SetText;
  833. published
  834. Property DataType : TFieldType read FDataType write SetDataType;
  835. Property Name : string read FName write FName;
  836. Property NumericScale : Integer read FNumericScale write FNumericScale default 0;
  837. Property ParamType : TParamType read FParamType write FParamType;
  838. Property Precision : Integer read FPrecision write FPrecision default 0;
  839. Property Size : Integer read FSize write FSize default 0;
  840. Property Value : JSValue read GetAsJSValue write SetAsJSValue stored IsParamStored;
  841. end;
  842. TParamClass = Class of TParam;
  843. { TParams }
  844. TParams = class(TCollection)
  845. private
  846. FOwner: TPersistent;
  847. Function GetItem(Index: Integer): TParam; reintroduce;
  848. Function GetParamValue(const ParamName: string): JSValue;
  849. Procedure SetItem(Index: Integer; Value: TParam); reintroduce;
  850. Procedure SetParamValue(const ParamName: string; const Value: JSValue);
  851. protected
  852. Procedure AssignTo(Dest: TPersistent); override;
  853. Function GetDataSet: TDataSet;
  854. Function GetOwner: TPersistent; override;
  855. Class Function ParamClass : TParamClass; virtual;
  856. public
  857. Constructor Create(AOwner: TPersistent; AItemClass : TCollectionItemClass); overload;
  858. Constructor Create(AOwner: TPersistent); overload;
  859. Constructor Create; overload; reintroduce;
  860. Procedure AddParam(Value: TParam);
  861. Procedure AssignValues(Value: TParams);
  862. Function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType): TParam;
  863. Function FindParam(const Value: string): TParam;
  864. Procedure GetParamList(List: TList; const ParamNames: string);
  865. Function IsEqual(Value: TParams): Boolean;
  866. Function ParamByName(const Value: string): TParam;
  867. Function ParseSQL(SQL: String; DoCreate: Boolean): String; overload;
  868. Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle): String; overload;
  869. Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding): String; overload;
  870. Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding; out ReplaceString : string): String; overload;
  871. Procedure RemoveParam(Value: TParam);
  872. Procedure CopyParamValuesFromDataset(ADataset : TDataset; CopyBound : Boolean);
  873. Property Dataset : TDataset Read GetDataset;
  874. Property Items[Index: Integer] : TParam read GetItem write SetItem; default;
  875. Property ParamValues[const ParamName: string] : JSValue read GetParamValue write SetParamValue;
  876. end;
  877. { TDataSet }
  878. TBookmarkFlag = (bfCurrent, bfBOF, bfEOF, bfInserted);
  879. TBookmark = record
  880. Data : JSValue;
  881. Flag : TBookmarkFlag;
  882. end; // Bookmark is always the index in the data array.
  883. TBookmarkStr = string; // JSON encoded version of the above
  884. TGetMode = (gmCurrent, gmNext, gmPrior);
  885. TGetResult = (grOK, grBOF, grEOF, grError);
  886. TResyncMode = set of (rmExact, rmCenter);
  887. TDataAction = (daFail, daAbort, daRetry);
  888. TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
  889. TUpdateKind = (ukModify, ukInsert, ukDelete);
  890. TLocateOption = (loCaseInsensitive, loPartialKey);
  891. TLocateOptions = set of TLocateOption;
  892. TDataOperation = procedure of object;
  893. TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;
  894. TDataSetErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
  895. var DataAction: TDataAction) of object;
  896. TFilterOption = (foCaseInsensitive, foNoPartialCompare);
  897. TFilterOptions = set of TFilterOption;
  898. TLoadOption = (loNoOpen,loNoEvents,loAtEOF);
  899. TLoadOptions = Set of TLoadOption;
  900. TDatasetLoadEvent = procedure(DataSet: TDataSet; Data : JSValue) of object;
  901. TDatasetLoadFailEvent = procedure(DataSet: TDataSet; ID : Integer; Const ErrorMsg : String) of object;
  902. TFilterRecordEvent = procedure(DataSet: TDataSet;
  903. var Accept: Boolean) of object;
  904. TDatasetClass = Class of TDataset;
  905. TRecordState = (rsNew,rsClean,rsUpdate,rsDelete);
  906. TDataRecord = record
  907. data : JSValue;
  908. state : TRecordState;
  909. bookmark : JSValue;
  910. bookmarkFlag : TBookmarkFlag;
  911. end;
  912. TBuffers = Array of TDataRecord;
  913. TResolveInfo = record
  914. Data : JSValue;
  915. Status : TUpdateStatus;
  916. Error : String; // Only filled on error.
  917. BookMark : TBookmark;
  918. _private : JSValue; // for use by descendents of TDataset
  919. end;
  920. TResolveInfoArray = Array of TResolveInfo;
  921. // Record so we can extend later on
  922. TResolveResults = record
  923. Records : TResolveInfoArray;
  924. end;
  925. TOnRecordResolveEvent = Procedure (Sender : TDataset; info : TResolveInfo) of object;
  926. TApplyUpdatesEvent = Procedure (Sender : TDataset; info : TResolveResults) of object;
  927. {------------------------------------------------------------------------------}
  928. TDataSet = class(TComponent)
  929. Private
  930. FAfterApplyUpdates: TApplyUpdatesEvent;
  931. FAfterLoad: TDatasetNotifyEvent;
  932. FBeforeApplyUpdates: TDatasetNotifyEvent;
  933. FBeforeLoad: TDatasetNotifyEvent;
  934. FBlockReadSize: Integer;
  935. FCalcBuffer: TDataRecord;
  936. FCalcFieldsCount: Longint;
  937. FOnLoadFail: TDatasetLoadFailEvent;
  938. FOnRecordResolved: TOnRecordResolveEvent;
  939. FOpenAfterRead : boolean;
  940. FActiveRecord: Longint;
  941. FAfterCancel: TDataSetNotifyEvent;
  942. FAfterClose: TDataSetNotifyEvent;
  943. FAfterDelete: TDataSetNotifyEvent;
  944. FAfterEdit: TDataSetNotifyEvent;
  945. FAfterInsert: TDataSetNotifyEvent;
  946. FAfterOpen: TDataSetNotifyEvent;
  947. FAfterPost: TDataSetNotifyEvent;
  948. FAfterRefresh: TDataSetNotifyEvent;
  949. FAfterScroll: TDataSetNotifyEvent;
  950. FAutoCalcFields: Boolean;
  951. FBOF: Boolean;
  952. FBeforeCancel: TDataSetNotifyEvent;
  953. FBeforeClose: TDataSetNotifyEvent;
  954. FBeforeDelete: TDataSetNotifyEvent;
  955. FBeforeEdit: TDataSetNotifyEvent;
  956. FBeforeInsert: TDataSetNotifyEvent;
  957. FBeforeOpen: TDataSetNotifyEvent;
  958. FBeforePost: TDataSetNotifyEvent;
  959. FBeforeRefresh: TDataSetNotifyEvent;
  960. FBeforeScroll: TDataSetNotifyEvent;
  961. FBlobFieldCount: Longint;
  962. FBuffers : TBuffers;
  963. FBufferCount: Longint;
  964. FConstraints: TCheckConstraints;
  965. FDisableControlsCount : Integer;
  966. FDisableControlsState : TDatasetState;
  967. FCurrentRecord: Longint;
  968. FDataSources : TFPList;
  969. FDefaultFields: Boolean;
  970. FEOF: Boolean;
  971. FEnableControlsEvent : TDataEvent;
  972. FFieldList : TFields;
  973. FFieldDefs: TFieldDefs;
  974. FFilterOptions: TFilterOptions;
  975. FFilterText: string;
  976. FFiltered: Boolean;
  977. FFound: Boolean;
  978. FInternalCalcFields: Boolean;
  979. FModified: Boolean;
  980. FOnCalcFields: TDataSetNotifyEvent;
  981. FOnDeleteError: TDataSetErrorEvent;
  982. FOnEditError: TDataSetErrorEvent;
  983. FOnFilterRecord: TFilterRecordEvent;
  984. FOnNewRecord: TDataSetNotifyEvent;
  985. FOnPostError: TDataSetErrorEvent;
  986. FRecordCount: Longint;
  987. FIsUniDirectional: Boolean;
  988. FState : TDataSetState;
  989. FInternalOpenComplete: Boolean;
  990. FDataProxy : TDataProxy;
  991. FDataRequestID : Integer;
  992. FUpdateBatchID : Integer;
  993. FChangeList : TFPList;
  994. FBatchList : TFPList;
  995. Procedure DoInsertAppend(DoAppend : Boolean);
  996. Procedure DoInternalOpen;
  997. Function GetBuffer (Index : longint) : TDataRecord;
  998. function GetBufferCount: Longint;
  999. function GetDataProxy: TDataProxy;
  1000. Procedure RegisterDataSource(ADataSource : TDataSource);
  1001. procedure SetConstraints(Value: TCheckConstraints);
  1002. procedure SetDataProxy(AValue: TDataProxy);
  1003. Procedure ShiftBuffersForward;
  1004. Procedure ShiftBuffersBackward;
  1005. Function TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
  1006. Function GetActive : boolean;
  1007. Procedure UnRegisterDataSource(ADataSource : TDataSource);
  1008. procedure SetBlockReadSize(AValue: Integer); virtual;
  1009. Procedure SetFieldDefs(AFieldDefs: TFieldDefs);
  1010. procedure DoInsertAppendRecord(const Values: array of jsValue; DoAppend : boolean);
  1011. // Callback for Tdataproxy.DoGetData;
  1012. function ResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
  1013. procedure HandleRequestresponse(ARequest: TDataRequest);
  1014. protected
  1015. // Proxy methods
  1016. // Override this to integrate package in local data
  1017. // call OnRecordResolved
  1018. procedure DoOnRecordResolved(anUpdate: TRecordUpdateDescriptor); virtual;
  1019. // Convert TRecordUpdateDescriptor to ResolveInfo
  1020. function RecordUpdateDescriptorToResolveInfo(anUpdate: TRecordUpdateDescriptor): TResolveInfo; virtual;
  1021. function DoResolveRecordUpdate(anUpdate{%H-}: TRecordUpdateDescriptor): Boolean; virtual;
  1022. Function GetRecordUpdates(AList: TRecordUpdateDescriptorList) : Integer; virtual;
  1023. procedure ResolveUpdateBatch(Sender: TObject; aBatch: TRecordUpdateBatch); virtual;
  1024. Function DataPacketReceived(ARequest{%H-}: TDataRequest) : Boolean; virtual;
  1025. function DoLoad(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean; virtual;
  1026. function DoGetDataProxy: TDataProxy; virtual;
  1027. Procedure InitChangeList; virtual;
  1028. Procedure DoneChangeList; virtual;
  1029. Procedure ClearChangeList;
  1030. Function IndexInChangeList(aBookmark: TBookmark): Integer; virtual;
  1031. Function AddToChangeList(aChange : TUpdateStatus) : TRecordUpdateDescriptor ; virtual;
  1032. Procedure RemoveFromChangeList(R : TRecordUpdateDescriptor); virtual;
  1033. Procedure DoApplyUpdates;
  1034. procedure RecalcBufListSize;
  1035. procedure ActivateBuffers; virtual;
  1036. procedure BindFields(Binding: Boolean);
  1037. procedure BlockReadNext; virtual;
  1038. function BookmarkAvailable: Boolean;
  1039. procedure CalculateFields(Var Buffer: TDataRecord); virtual;
  1040. procedure CheckActive; virtual;
  1041. procedure CheckInactive; virtual;
  1042. procedure CheckBiDirectional;
  1043. procedure Loaded; override;
  1044. procedure ClearBuffers; virtual;
  1045. procedure ClearCalcFields(var Buffer{%H-}: TDataRecord); virtual;
  1046. procedure CloseBlob(Field{%H-}: TField); virtual;
  1047. procedure CloseCursor; virtual;
  1048. procedure CreateFields; virtual;
  1049. procedure DataEvent(Event: TDataEvent; Info: JSValue); virtual;
  1050. procedure DestroyFields; virtual;
  1051. procedure DoAfterCancel; virtual;
  1052. procedure DoAfterClose; virtual;
  1053. procedure DoAfterDelete; virtual;
  1054. procedure DoAfterEdit; virtual;
  1055. procedure DoAfterInsert; virtual;
  1056. procedure DoAfterOpen; virtual;
  1057. procedure DoAfterPost; virtual;
  1058. procedure DoAfterScroll; virtual;
  1059. procedure DoAfterRefresh; virtual;
  1060. procedure DoBeforeCancel; virtual;
  1061. procedure DoBeforeClose; virtual;
  1062. procedure DoBeforeDelete; virtual;
  1063. procedure DoBeforeEdit; virtual;
  1064. procedure DoBeforeInsert; virtual;
  1065. procedure DoBeforeOpen; virtual;
  1066. procedure DoBeforePost; virtual;
  1067. procedure DoBeforeScroll; virtual;
  1068. procedure DoBeforeRefresh; virtual;
  1069. procedure DoOnCalcFields; virtual;
  1070. procedure DoOnNewRecord; virtual;
  1071. procedure DoBeforeLoad; virtual;
  1072. procedure DoAfterLoad; virtual;
  1073. procedure DoBeforeApplyUpdates; virtual;
  1074. procedure DoAfterApplyUpdates(const ResolveInfo: TResolveResults); virtual;
  1075. function FieldByNumber(FieldNo: Longint): TField;
  1076. function FindRecord(Restart{%H-}, GoForward{%H-}: Boolean): Boolean; virtual;
  1077. function GetBookmarkStr: TBookmarkStr; virtual;
  1078. procedure GetCalcFields(Var Buffer: TDataRecord); virtual;
  1079. function GetCanModify: Boolean; virtual;
  1080. procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
  1081. function GetFieldClass(FieldType: TFieldType): TFieldClass; virtual;
  1082. Function GetfieldCount : Integer;
  1083. function GetFieldValues(const FieldName : string) : JSValue; virtual;
  1084. function GetIsIndexField(Field{%H-}: TField): Boolean; virtual;
  1085. function GetIndexDefs(IndexDefs : TIndexDefs; IndexTypes : TIndexOptions) : TIndexDefs;
  1086. function GetNextRecords: Longint; virtual;
  1087. function GetNextRecord: Boolean; virtual;
  1088. function GetPriorRecords: Longint; virtual;
  1089. function GetPriorRecord: Boolean; virtual;
  1090. function GetRecordCount: Longint; virtual;
  1091. function GetRecNo: Longint; virtual;
  1092. procedure InitFieldDefs; virtual;
  1093. procedure InitFieldDefsFromfields;
  1094. procedure InitRecord(var Buffer: TDataRecord); virtual;
  1095. procedure InternalCancel; virtual;
  1096. procedure InternalEdit; virtual;
  1097. procedure InternalInsert; virtual;
  1098. procedure InternalRefresh; virtual;
  1099. procedure OpenCursor(InfoQuery: Boolean); virtual;
  1100. procedure OpenCursorcomplete; virtual;
  1101. procedure RefreshInternalCalcFields(Var Buffer{%H-}: TDataRecord); virtual;
  1102. procedure RestoreState(const Value: TDataSetState);
  1103. Procedure SetActive (Value : Boolean); virtual;
  1104. procedure SetBookmarkStr(const Value: TBookmarkStr); virtual;
  1105. procedure SetBufListSize(Value: Longint); virtual;
  1106. procedure SetChildOrder(Child: TComponent; Order: Longint); override;
  1107. procedure SetCurrentRecord(Index: Longint); virtual;
  1108. procedure SetDefaultFields(const Value: Boolean);
  1109. procedure SetFiltered(Value: Boolean); virtual;
  1110. procedure SetFilterOptions(Value: TFilterOptions); virtual;
  1111. procedure SetFilterText(const Value: string); virtual;
  1112. procedure SetFieldValues(const FieldName: string; Value: JSValue); virtual;
  1113. procedure SetFound(const Value: Boolean); virtual;
  1114. procedure SetModified(Value: Boolean);
  1115. procedure SetName(const NewName: TComponentName); override;
  1116. procedure SetOnFilterRecord(const Value: TFilterRecordEvent); virtual;
  1117. procedure SetRecNo(Value{%H-}: Longint); virtual;
  1118. procedure SetState(Value: TDataSetState);
  1119. function SetTempState(const Value: TDataSetState): TDataSetState;
  1120. Function TempBuffer: TDataRecord;
  1121. procedure UpdateIndexDefs; virtual;
  1122. property ActiveRecord: Longint read FActiveRecord;
  1123. property CurrentRecord: Longint read FCurrentRecord;
  1124. property BlobFieldCount: Longint read FBlobFieldCount;
  1125. property Buffers[Index: Longint]: TDataRecord read GetBuffer;
  1126. property BufferCount: Longint read GetBufferCount;
  1127. property CalcBuffer: TDataRecord read FCalcBuffer;
  1128. property CalcFieldsCount: Longint read FCalcFieldsCount;
  1129. property InternalCalcFields: Boolean read FInternalCalcFields;
  1130. property Constraints: TCheckConstraints read FConstraints write SetConstraints;
  1131. function AllocRecordBuffer: TDataRecord; virtual;
  1132. procedure FreeRecordBuffer(var Buffer{%H-}: TDataRecord); virtual;
  1133. procedure GetBookmarkData(Buffer{%H-}: TDataRecord; var Data{%H-}: TBookmark); virtual;
  1134. function GetBookmarkFlag(Buffer{%H-}: TDataRecord): TBookmarkFlag; virtual;
  1135. function GetDataSource: TDataSource; virtual;
  1136. function GetRecordSize: Word; virtual;
  1137. procedure InternalAddRecord(Buffer{%H-}: Pointer; AAppend{%H-}: Boolean); virtual;
  1138. procedure InternalDelete; virtual;
  1139. procedure InternalFirst; virtual;
  1140. procedure InternalGotoBookmark(ABookmark{%H-}: TBookmark); virtual;
  1141. procedure InternalHandleException(E: Exception); virtual;
  1142. procedure InternalInitRecord(var Buffer{%H-}: TDataRecord); virtual;
  1143. procedure InternalLast; virtual;
  1144. procedure InternalPost; virtual;
  1145. procedure InternalSetToRecord(Buffer{%H-}: TDataRecord); virtual;
  1146. procedure SetBookmarkFlag(Var Buffer{%H-}: TDataRecord; Value{%H-}: TBookmarkFlag); virtual;
  1147. procedure SetBookmarkData(Var Buffer{%H-}: TDataRecord; Data{%H-}: TBookmark); virtual;
  1148. procedure SetUniDirectional(const Value: Boolean);
  1149. procedure Notification(AComponent: TComponent; Operation: TOperation); override;
  1150. // These use the active buffer
  1151. function GetFieldData(Field: TField): JSValue; virtual; overload;
  1152. procedure SetFieldData(Field: TField; AValue : JSValue); virtual; overload;
  1153. function GetFieldData(Field: TField; Buffer: TDatarecord): JSValue; virtual; overload;
  1154. procedure SetFieldData(Field: TField; var Buffer: TDatarecord; AValue : JSValue); virtual; overload;
  1155. class function FieldDefsClass : TFieldDefsClass; virtual;
  1156. class function FieldsClass : TFieldsClass; virtual;
  1157. protected { abstract methods }
  1158. function GetRecord(var Buffer: TDataRecord; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
  1159. procedure InternalClose; virtual; abstract;
  1160. procedure InternalOpen; virtual; abstract;
  1161. procedure InternalInitFieldDefs; virtual; abstract;
  1162. function IsCursorOpen: Boolean; virtual; abstract;
  1163. property DataProxy : TDataProxy Read GetDataProxy Write SetDataProxy;
  1164. public
  1165. constructor Create(AOwner: TComponent); override;
  1166. destructor Destroy; override;
  1167. function ActiveBuffer: TDataRecord;
  1168. procedure Append;
  1169. procedure AppendRecord(const Values: array of jsValue);
  1170. function BookmarkValid(ABookmark{%H-}: TBookmark): Boolean; virtual;
  1171. function ConvertToDateTime(aValue : JSValue; ARaiseException : Boolean) : TDateTime; virtual;
  1172. function ConvertDateTimeToNative(aValue : TDateTime) : JSValue; virtual;
  1173. Class function DefaultConvertToDateTime(aValue : JSValue; ARaiseException{%H-} : Boolean) : TDateTime; virtual;
  1174. Class function DefaultConvertDateTimeToNative(aValue : TDateTime) : JSValue; virtual;
  1175. Function BlobDataToBytes(aValue : JSValue) : TBytes; virtual;
  1176. Class Function DefaultBlobDataToBytes(aValue : JSValue) : TBytes; virtual;
  1177. Function BytesToBlobData(aValue : TBytes) : JSValue ; virtual;
  1178. Class Function DefaultBytesToBlobData(aValue : TBytes) : JSValue; virtual;
  1179. procedure Cancel; virtual;
  1180. procedure CheckBrowseMode;
  1181. procedure ClearFields;
  1182. procedure Close;
  1183. Procedure ApplyUpdates;
  1184. function ControlsDisabled: Boolean;
  1185. function CompareBookmarks(Bookmark1{%H-}, Bookmark2{%H-}: TBookmark): Longint; virtual;
  1186. procedure CursorPosChanged;
  1187. procedure Delete; virtual;
  1188. procedure DisableControls;
  1189. procedure Edit;
  1190. procedure EnableControls;
  1191. function FieldByName(const FieldName: string): TField;
  1192. function FindField(const FieldName: string): TField;
  1193. function FindFirst: Boolean; virtual;
  1194. function FindLast: Boolean; virtual;
  1195. function FindNext: Boolean; virtual;
  1196. function FindPrior: Boolean; virtual;
  1197. procedure First;
  1198. procedure FreeBookmark(ABookmark{%H-}: TBookmark); virtual;
  1199. function GetBookmark: TBookmark; virtual;
  1200. function GetCurrentRecord(Buffer{%H-}: TDataRecord): Boolean; virtual;
  1201. procedure GetFieldList(List: TList; const FieldNames: string);
  1202. procedure GetFieldNames(List: TStrings);
  1203. procedure GotoBookmark(const ABookmark: TBookmark);
  1204. procedure Insert; reintroduce;
  1205. procedure InsertRecord(const Values: array of JSValue);
  1206. function IsEmpty: Boolean;
  1207. function IsLinkedTo(ADataSource: TDataSource): Boolean;
  1208. function IsSequenced: Boolean; virtual;
  1209. procedure Last;
  1210. Function Load(aOptions : TLoadOptions; aAfterLoad : TDatasetLoadEvent) : Boolean;
  1211. function Locate(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; Options{%H-}: TLocateOptions) : boolean; virtual;
  1212. function Lookup(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; const ResultFields{%H-}: string): JSValue; virtual;
  1213. function MoveBy(Distance: Longint): Longint;
  1214. procedure Next;
  1215. procedure Open;
  1216. procedure Post; virtual;
  1217. procedure Prior;
  1218. procedure Refresh;
  1219. procedure Resync(Mode: TResyncMode); virtual;
  1220. procedure SetFields(const Values: array of JSValue);
  1221. procedure UpdateCursorPos;
  1222. procedure UpdateRecord;
  1223. Function GetPendingUpdates : TResolveInfoArray;
  1224. function UpdateStatus: TUpdateStatus; virtual;
  1225. property BlockReadSize: Integer read FBlockReadSize write SetBlockReadSize;
  1226. property BOF: Boolean read FBOF;
  1227. property Bookmark: TBookmark read GetBookmark write GotoBookmark;
  1228. property CanModify: Boolean read GetCanModify;
  1229. property DataSource: TDataSource read GetDataSource;
  1230. property DefaultFields: Boolean read FDefaultFields;
  1231. property EOF: Boolean read FEOF;
  1232. property FieldCount: Longint read GetFieldCount;
  1233. property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;
  1234. property Found: Boolean read FFound;
  1235. property Modified: Boolean read FModified;
  1236. property IsUniDirectional: Boolean read FIsUniDirectional default False;
  1237. property RecordCount: Longint read GetRecordCount;
  1238. property RecNo: Longint read GetRecNo write SetRecNo;
  1239. property RecordSize: Word read GetRecordSize;
  1240. property State: TDataSetState read FState;
  1241. property Fields : TFields read FFieldList;
  1242. // property FieldValues[FieldName : string] : JSValue read GetFieldValues write SetFieldValues; default;
  1243. property Filter: string read FFilterText write SetFilterText;
  1244. property Filtered: Boolean read FFiltered write SetFiltered default False;
  1245. property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions;
  1246. property Active: Boolean read GetActive write SetActive default False;
  1247. property AutoCalcFields: Boolean read FAutoCalcFields write FAutoCalcFields default true;
  1248. property BeforeOpen: TDataSetNotifyEvent read FBeforeOpen write FBeforeOpen;
  1249. property AfterOpen: TDataSetNotifyEvent read FAfterOpen write FAfterOpen;
  1250. property BeforeClose: TDataSetNotifyEvent read FBeforeClose write FBeforeClose;
  1251. property AfterClose: TDataSetNotifyEvent read FAfterClose write FAfterClose;
  1252. property BeforeInsert: TDataSetNotifyEvent read FBeforeInsert write FBeforeInsert;
  1253. property AfterInsert: TDataSetNotifyEvent read FAfterInsert write FAfterInsert;
  1254. property BeforeEdit: TDataSetNotifyEvent read FBeforeEdit write FBeforeEdit;
  1255. property AfterEdit: TDataSetNotifyEvent read FAfterEdit write FAfterEdit;
  1256. property BeforePost: TDataSetNotifyEvent read FBeforePost write FBeforePost;
  1257. property AfterPost: TDataSetNotifyEvent read FAfterPost write FAfterPost;
  1258. property BeforeCancel: TDataSetNotifyEvent read FBeforeCancel write FBeforeCancel;
  1259. property AfterCancel: TDataSetNotifyEvent read FAfterCancel write FAfterCancel;
  1260. property BeforeDelete: TDataSetNotifyEvent read FBeforeDelete write FBeforeDelete;
  1261. property AfterDelete: TDataSetNotifyEvent read FAfterDelete write FAfterDelete;
  1262. property BeforeScroll: TDataSetNotifyEvent read FBeforeScroll write FBeforeScroll;
  1263. property AfterScroll: TDataSetNotifyEvent read FAfterScroll write FAfterScroll;
  1264. property BeforeRefresh: TDataSetNotifyEvent read FBeforeRefresh write FBeforeRefresh;
  1265. property BeforeLoad : TDatasetNotifyEvent Read FBeforeLoad Write FBeforeLoad;
  1266. Property AfterLoad : TDatasetNotifyEvent Read FAfterLoad Write FAfterLoad;
  1267. Property BeforeApplyUpdates : TDatasetNotifyEvent Read FBeforeApplyUpdates Write FBeforeApplyUpdates;
  1268. Property AfterApplyUpdates : TApplyUpdatesEvent Read FAfterApplyUpdates Write FAfterApplyUpdates;
  1269. property AfterRefresh: TDataSetNotifyEvent read FAfterRefresh write FAfterRefresh;
  1270. property OnCalcFields: TDataSetNotifyEvent read FOnCalcFields write FOnCalcFields;
  1271. property OnDeleteError: TDataSetErrorEvent read FOnDeleteError write FOnDeleteError;
  1272. property OnEditError: TDataSetErrorEvent read FOnEditError write FOnEditError;
  1273. property OnFilterRecord: TFilterRecordEvent read FOnFilterRecord write SetOnFilterRecord;
  1274. property OnNewRecord: TDataSetNotifyEvent read FOnNewRecord write FOnNewRecord;
  1275. Property OnRecordResolved : TOnRecordResolveEvent Read FOnRecordResolved Write FOnRecordResolved;
  1276. property OnPostError: TDataSetErrorEvent read FOnPostError write FOnPostError;
  1277. property OnLoadFail : TDatasetLoadFailEvent Read FOnLoadFail Write FOnLoadFail;
  1278. end;
  1279. { TDataLink }
  1280. TDataLink = class(TPersistent)
  1281. private
  1282. FFirstRecord,
  1283. FBufferCount : Integer;
  1284. FActive,
  1285. FDataSourceFixed,
  1286. FEditing,
  1287. FReadOnly,
  1288. FUpdatingRecord,
  1289. FVisualControl : Boolean;
  1290. FDataSource : TDataSource;
  1291. Function CalcFirstRecord(Index : Integer) : Integer;
  1292. Procedure CalcRange;
  1293. Procedure CheckActiveAndEditing;
  1294. Function GetDataset : TDataset;
  1295. procedure SetActive(AActive: Boolean);
  1296. procedure SetDataSource(Value: TDataSource);
  1297. Procedure SetReadOnly(Value : Boolean);
  1298. protected
  1299. procedure ActiveChanged; virtual;
  1300. procedure CheckBrowseMode; virtual;
  1301. procedure DataEvent(Event: TDataEvent; Info: JSValue); virtual;
  1302. procedure DataSetChanged; virtual;
  1303. procedure DataSetScrolled(Distance{%H-}: Integer); virtual;
  1304. procedure EditingChanged; virtual;
  1305. procedure FocusControl(Field{%H-}: JSValue); virtual;
  1306. function GetActiveRecord: Integer; virtual;
  1307. function GetBOF: Boolean; virtual;
  1308. function GetBufferCount: Integer; virtual;
  1309. function GetEOF: Boolean; virtual;
  1310. function GetRecordCount: Integer; virtual;
  1311. procedure LayoutChanged; virtual;
  1312. function MoveBy(Distance: Integer): Integer; virtual;
  1313. procedure RecordChanged(Field{%H-}: TField); virtual;
  1314. procedure SetActiveRecord(Value: Integer); virtual;
  1315. procedure SetBufferCount(Value: Integer); virtual;
  1316. procedure UpdateData; virtual;
  1317. property VisualControl: Boolean read FVisualControl write FVisualControl;
  1318. property FirstRecord: Integer read FFirstRecord write FFirstRecord;
  1319. public
  1320. constructor Create; reintroduce;
  1321. destructor Destroy; override;
  1322. function Edit: Boolean;
  1323. procedure UpdateRecord;
  1324. property Active: Boolean read FActive;
  1325. property ActiveRecord: Integer read GetActiveRecord write SetActiveRecord;
  1326. property BOF: Boolean read GetBOF;
  1327. property BufferCount: Integer read GetBufferCount write SetBufferCount;
  1328. property DataSet: TDataSet read GetDataSet;
  1329. property DataSource: TDataSource read FDataSource write SetDataSource;
  1330. property DataSourceFixed: Boolean read FDataSourceFixed write FDataSourceFixed;
  1331. property Editing: Boolean read FEditing;
  1332. property Eof: Boolean read GetEOF;
  1333. property ReadOnly: Boolean read FReadOnly write SetReadOnly;
  1334. property RecordCount: Integer read GetRecordCount;
  1335. end;
  1336. { TDetailDataLink }
  1337. TDetailDataLink = class(TDataLink)
  1338. protected
  1339. function GetDetailDataSet: TDataSet; virtual;
  1340. public
  1341. property DetailDataSet: TDataSet read GetDetailDataSet;
  1342. end;
  1343. { TMasterDataLink }
  1344. TMasterDataLink = class(TDetailDataLink)
  1345. private
  1346. FDetailDataSet: TDataSet;
  1347. FFieldNames: string;
  1348. FFields: TList;
  1349. FOnMasterChange: TNotifyEvent;
  1350. FOnMasterDisable: TNotifyEvent;
  1351. procedure SetFieldNames(const Value: string);
  1352. protected
  1353. procedure ActiveChanged; override;
  1354. procedure CheckBrowseMode; override;
  1355. function GetDetailDataSet: TDataSet; override;
  1356. procedure LayoutChanged; override;
  1357. procedure RecordChanged(Field: TField); override;
  1358. Procedure DoMasterDisable; virtual;
  1359. Procedure DoMasterChange; virtual;
  1360. public
  1361. constructor Create(ADataSet: TDataSet);virtual; reintroduce;
  1362. destructor Destroy; override;
  1363. property FieldNames: string read FFieldNames write SetFieldNames;
  1364. property Fields: TList read FFields;
  1365. property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
  1366. property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
  1367. end;
  1368. { TMasterParamsDataLink }
  1369. TMasterParamsDataLink = Class(TMasterDataLink)
  1370. Private
  1371. FParams : TParams;
  1372. Procedure SetParams(AValue : TParams);
  1373. Protected
  1374. Procedure DoMasterDisable; override;
  1375. Procedure DoMasterChange; override;
  1376. Public
  1377. constructor Create(ADataSet: TDataSet); override;
  1378. Procedure RefreshParamNames; virtual;
  1379. Procedure CopyParamsFromMaster(CopyBound : Boolean); virtual;
  1380. Property Params : TParams Read FParams Write SetParams;
  1381. end;
  1382. { TDataSource }
  1383. TDataChangeEvent = procedure(Sender: TObject; Field: TField) of object;
  1384. TDataSource = class(TComponent)
  1385. private
  1386. FDataSet: TDataSet;
  1387. FDataLinks: TList;
  1388. FEnabled: Boolean;
  1389. FAutoEdit: Boolean;
  1390. FState: TDataSetState;
  1391. FOnStateChange: TNotifyEvent;
  1392. FOnDataChange: TDataChangeEvent;
  1393. FOnUpdateData: TNotifyEvent;
  1394. procedure DistributeEvent(Event: TDataEvent; Info: JSValue);
  1395. procedure RegisterDataLink(DataLink: TDataLink);
  1396. Procedure ProcessEvent(Event : TDataEvent; Info : JSValue);
  1397. procedure SetDataSet(ADataSet: TDataSet);
  1398. procedure SetEnabled(Value: Boolean);
  1399. procedure UnregisterDataLink(DataLink: TDataLink);
  1400. protected
  1401. Procedure DoDataChange (Info : Pointer);virtual;
  1402. Procedure DoStateChange; virtual;
  1403. Procedure DoUpdateData;
  1404. property DataLinks: TList read FDataLinks;
  1405. public
  1406. constructor Create(AOwner: TComponent); override;
  1407. destructor Destroy; override;
  1408. procedure Edit;
  1409. function IsLinkedTo(ADataSet{%H-}: TDataSet): Boolean;
  1410. property State: TDataSetState read FState;
  1411. published
  1412. property AutoEdit: Boolean read FAutoEdit write FAutoEdit default True;
  1413. property DataSet: TDataSet read FDataSet write SetDataSet;
  1414. property Enabled: Boolean read FEnabled write SetEnabled default True;
  1415. property OnStateChange: TNotifyEvent read FOnStateChange write FOnStateChange;
  1416. property OnDataChange: TDataChangeEvent read FOnDataChange write FOnDataChange;
  1417. property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
  1418. end;
  1419. { TDataRequest }
  1420. TDataRequestResult = (rrFail,rrEOF,rrOK);
  1421. TDataRequestEvent = Procedure (ARequest : TDataRequest) of object;
  1422. TDataRequest = Class(TObject)
  1423. private
  1424. FBookmark: TBookMark;
  1425. FCurrent: TBookMark;
  1426. FDataset: TDataset;
  1427. FErrorMsg: String;
  1428. FEvent: TDatasetLoadEvent;
  1429. FLoadOptions: TLoadOptions;
  1430. FRequestID: Integer;
  1431. FSuccess: TDataRequestResult;
  1432. FData : JSValue;
  1433. FAfterRequest : TDataRequestEvent;
  1434. FDataProxy : TDataProxy;
  1435. Protected
  1436. Procedure DoAfterRequest;
  1437. Public
  1438. Constructor Create(aDataProxy : TDataProxy; aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent); virtual; reintroduce;
  1439. property DataProxy : TDataProxy Read FDataProxy;
  1440. Property Dataset : TDataset Read FDataset;
  1441. Property Bookmark : TBookMark Read FBookmark;
  1442. Property RequestID : Integer Read FRequestID;
  1443. Property LoadOptions : TLoadOptions Read FLoadOptions;
  1444. Property Current : TBookMark Read FCurrent;
  1445. Property Success : TDataRequestResult Read FSuccess Write FSuccess;
  1446. Property Event : TDatasetLoadEvent Read FEvent;
  1447. Property ErrorMsg : String Read FErrorMsg Write FErrorMsg;
  1448. Property Data : JSValue read FData Write FData;
  1449. end;
  1450. TDataRequestClass = Class of TDataRequest;
  1451. { TRecordUpdateDescriptor }
  1452. TRecordUpdateDescriptor = Class(TObject)
  1453. private
  1454. FBookmark: TBookmark;
  1455. FData: JSValue;
  1456. FDataset: TDataset;
  1457. FProxy: TDataProxy;
  1458. FResolveError: String;
  1459. FServerData: JSValue;
  1460. FStatus: TUpdateStatus;
  1461. FOriginalStatus : TUpdateStatus;
  1462. Protected
  1463. Procedure SetStatus(aValue : TUpdateStatus); virtual;
  1464. Procedure Reset;
  1465. Public
  1466. Constructor Create(aProxy : TDataProxy; aDataset : TDataset; aBookmark : TBookMark; AData : JSValue; AStatus : TUpdateStatus); reintroduce;
  1467. Procedure Resolve(aData : JSValue);
  1468. Procedure ResolveFailed(aError : String);
  1469. Property Proxy : TDataProxy read FProxy;
  1470. Property Dataset : TDataset Read FDataset;
  1471. Property OriginalStatus : TUpdateStatus Read FOriginalStatus;
  1472. Property Status : TUpdateStatus Read FStatus;
  1473. Property ServerData : JSValue Read FServerData;
  1474. Property Data : JSValue Read FData;
  1475. Property Bookmark : TBookmark Read FBookmark;
  1476. Property ResolveError : String Read FResolveError ;
  1477. end;
  1478. TRecordUpdateDescriptorClass = Class of TRecordUpdateDescriptor;
  1479. { TRecordUpdateDescriptorList }
  1480. TRecordUpdateDescriptorList = Class(TFPList)
  1481. private
  1482. function GetUpdate(AIndex : Integer): TRecordUpdateDescriptor;
  1483. Public
  1484. Property UpdateDescriptors[AIndex : Integer] : TRecordUpdateDescriptor Read GetUpdate; Default;
  1485. end;
  1486. { TRecordUpdateBatch }
  1487. TUpdateBatchStatus = (ubsPending,ubsProcessing,ubsProcessed,ubsResolved);
  1488. TResolveBatchEvent = Procedure (Sender : TObject; ARequest : TRecordUpdateBatch) of object;
  1489. TRecordUpdateBatch = class(TObject)
  1490. private
  1491. FBatchID: Integer;
  1492. FDataset: TDataset;
  1493. FLastChangeIndex: Integer;
  1494. FList: TRecordUpdateDescriptorList;
  1495. FOnResolve: TResolveBatchEvent;
  1496. FOwnsList: Boolean;
  1497. FStatus: TUpdateBatchStatus;
  1498. Protected
  1499. Property LastChangeIndex : Integer Read FLastChangeIndex;
  1500. Public
  1501. Constructor Create (aBatchID : Integer; AList : TRecordUpdateDescriptorList; AOwnsList : Boolean); reintroduce;
  1502. Destructor Destroy; override;
  1503. Procedure FreeList;
  1504. Property Dataset : TDataset Read FDataset Write FDataset;
  1505. Property OnResolve : TResolveBatchEvent Read FOnResolve Write FOnResolve;
  1506. Property OwnsList : Boolean Read FOwnsList;
  1507. property BatchID : Integer Read FBatchID;
  1508. Property Status : TUpdateBatchStatus Read FStatus Write FStatus;
  1509. Property List : TRecordUpdateDescriptorList Read FList;
  1510. end;
  1511. TRecordUpdateBatchClass = Class of TRecordUpdateBatch;
  1512. { TDataProxy }
  1513. TDataProxy = Class(TComponent)
  1514. Protected
  1515. Function GetDataRequestClass : TDataRequestClass; virtual;
  1516. Function GetUpdateDescriptorClass : TRecordUpdateDescriptorClass; virtual;
  1517. Function GetUpdateBatchClass : TRecordUpdateBatchClass; virtual;
  1518. // Use this to call resolve event, and free the batch.
  1519. Procedure ResolveBatch(aBatch : TRecordUpdateBatch);
  1520. Public
  1521. Function GetDataRequest(aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent) : TDataRequest; virtual;
  1522. Function GetUpdateDescriptor(aDataset : TDataset; aBookmark : TBookMark; AData : JSValue; AStatus : TUpdateStatus) : TRecordUpdateDescriptor; virtual;
  1523. function GetRecordUpdateBatch(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList: Boolean=True): TRecordUpdateBatch; virtual;
  1524. // actual calls to do the work. Dataset wi
  1525. Function DoGetData(aRequest : TDataRequest) : Boolean; virtual; abstract;
  1526. // TDataProxy is responsible for calling OnResolve and if not, Freeing the batch.
  1527. Function ProcessUpdateBatch(aBatch : TRecordUpdateBatch): Boolean; virtual; abstract;
  1528. end;
  1529. const
  1530. {
  1531. TFieldType = (
  1532. ftUnknown, ftString, ftInteger, ftLargeInt, ftBoolean, ftFloat, ftDate,
  1533. ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftFixedChar,
  1534. ftVariant
  1535. );
  1536. }
  1537. Const
  1538. Fieldtypenames : Array [TFieldType] of String =
  1539. (
  1540. {ftUnknown} 'Unknown',
  1541. {ftString} 'String',
  1542. {ftInteger} 'Integer',
  1543. {ftLargeint} 'NativeInt',
  1544. {ftBoolean} 'Boolean',
  1545. {ftFloat} 'Float',
  1546. {ftDate} 'Date',
  1547. {ftTime} 'Time',
  1548. {ftDateTime} 'DateTime',
  1549. {ftAutoInc} 'AutoInc',
  1550. {ftBlob} 'Blob',
  1551. {ftMemo} 'Memo',
  1552. {ftFixedChar} 'FixedChar',
  1553. {ftVariant} 'Variant',
  1554. {ftDataset} 'Dataset'
  1555. );
  1556. DefaultFieldClasses : Array [TFieldType] of TFieldClass =
  1557. (
  1558. { ftUnknown} Tfield,
  1559. { ftString} TStringField,
  1560. { ftInteger} TIntegerField,
  1561. { ftLargeint} TLargeIntField,
  1562. { ftBoolean} TBooleanField,
  1563. { ftFloat} TFloatField,
  1564. { ftDate} TDateField,
  1565. { ftTime} TTimeField,
  1566. { ftDateTime} TDateTimeField,
  1567. { ftAutoInc} TAutoIncField,
  1568. { ftBlob} TBlobField,
  1569. { ftMemo} TMemoField,
  1570. { ftFixedChar} TStringField,
  1571. { ftVariant} TVariantField,
  1572. { ftDataset} Nil
  1573. );
  1574. dsEditModes = [dsEdit, dsInsert, dsSetKey];
  1575. dsWriteModes = [dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter,
  1576. dsNewValue, dsInternalCalc, dsRefreshFields];
  1577. // Correct list of all field types that are BLOB types.
  1578. // Please use this instead of checking TBlobType which will give
  1579. // incorrect results
  1580. ftBlobTypes = [ftBlob, ftMemo];
  1581. { Auxiliary functions }
  1582. Procedure DatabaseError (Const Msg : String); overload;
  1583. Procedure DatabaseError (Const Msg : String; Comp : TComponent); overload;
  1584. Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue); overload;
  1585. Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue; Comp : TComponent); overload;
  1586. Function ExtractFieldName(Const Fields: String; var Pos: Integer): String;
  1587. // function SkipComments(var p: PChar; EscapeSlash, EscapeRepeat : Boolean) : boolean;
  1588. // operator Enumerator(ADataSet: TDataSet): TDataSetEnumerator;
  1589. implementation
  1590. uses DBConst,TypInfo;
  1591. { ---------------------------------------------------------------------
  1592. Auxiliary functions
  1593. ---------------------------------------------------------------------}
  1594. Procedure DatabaseError (Const Msg : String);
  1595. begin
  1596. Raise EDataBaseError.Create(Msg);
  1597. end;
  1598. Procedure DatabaseError (Const Msg : String; Comp : TComponent);
  1599. begin
  1600. if assigned(Comp) and (Comp.Name <> '') then
  1601. Raise EDatabaseError.CreateFmt('%s : %s',[Comp.Name,Msg])
  1602. else
  1603. DatabaseError(Msg);
  1604. end;
  1605. Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue);
  1606. begin
  1607. Raise EDatabaseError.CreateFmt(Fmt,Args);
  1608. end;
  1609. Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue;
  1610. Comp : TComponent);
  1611. begin
  1612. if assigned(comp) then
  1613. Raise EDatabaseError.CreateFmt(Format('%s : %s',[Comp.Name,Fmt]),Args)
  1614. else
  1615. DatabaseErrorFmt(Fmt, Args);
  1616. end;
  1617. function ExtractFieldName(const Fields: string; var Pos: Integer): string;
  1618. var
  1619. i: Integer;
  1620. FieldsLength: Integer;
  1621. begin
  1622. i:=Pos;
  1623. FieldsLength:=Length(Fields);
  1624. while (i<=FieldsLength) and (Fields[i]<>';') do Inc(i);
  1625. Result:=Trim(Copy(Fields,Pos,i-Pos));
  1626. if (i<=FieldsLength) and (Fields[i]=';') then Inc(i);
  1627. Pos:=i;
  1628. end;
  1629. { TRecordUpdateBatch }
  1630. constructor TRecordUpdateBatch.Create(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList : Boolean);
  1631. begin
  1632. FBatchID:=aBatchID;
  1633. FList:=AList;
  1634. FOwnsList:=AOwnsList;
  1635. FStatus:=ubsPending;
  1636. end;
  1637. destructor TRecordUpdateBatch.Destroy;
  1638. begin
  1639. if OwnsList then
  1640. FreeList;
  1641. inherited Destroy;
  1642. end;
  1643. procedure TRecordUpdateBatch.FreeList;
  1644. begin
  1645. FreeAndNil(FList);
  1646. end;
  1647. { TRecordUpdateDescriptorList }
  1648. function TRecordUpdateDescriptorList.GetUpdate(AIndex : Integer): TRecordUpdateDescriptor;
  1649. begin
  1650. Result:=TRecordUpdateDescriptor(Items[AIndex]);
  1651. end;
  1652. { TRecordUpdateDescriptor }
  1653. procedure TRecordUpdateDescriptor.SetStatus(aValue: TUpdateStatus);
  1654. begin
  1655. FStatus:=AValue;
  1656. end;
  1657. procedure TRecordUpdateDescriptor.Reset;
  1658. begin
  1659. FStatus:=FOriginalStatus;
  1660. FResolveError:='';
  1661. FServerData:=Null;
  1662. end;
  1663. constructor TRecordUpdateDescriptor.Create(aProxy: TDataProxy; aDataset: TDataset; aBookmark: TBookMark; AData: JSValue;
  1664. AStatus: TUpdateStatus);
  1665. begin
  1666. FDataset:=aDataset;
  1667. FBookmark:=aBookmark;
  1668. FData:=AData;
  1669. FStatus:=AStatus;
  1670. FOriginalStatus:=AStatus;
  1671. FProxy:=aProxy;
  1672. end;
  1673. procedure TRecordUpdateDescriptor.Resolve(aData: JSValue);
  1674. begin
  1675. FStatus:=usResolved;
  1676. FServerData:=AData;
  1677. end;
  1678. procedure TRecordUpdateDescriptor.ResolveFailed(aError: String);
  1679. begin
  1680. SetStatus(usResolveFailed);
  1681. FResolveError:=AError;
  1682. end;
  1683. { TDataRequest }
  1684. procedure TDataRequest.DoAfterRequest;
  1685. begin
  1686. if Assigned(FAfterRequest) then
  1687. FAfterRequest(Self);
  1688. end;
  1689. constructor TDataRequest.Create(aDataProxy : TDataProxy; aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent);
  1690. begin
  1691. FDataProxy:=aDataProxy;
  1692. FLoadOptions:=aOptions;
  1693. FEvent:=aAfterLoad;
  1694. FAfterRequest:=aAfterRequest;
  1695. end;
  1696. { TDataProxy }
  1697. function TDataProxy.GetDataRequestClass: TDataRequestClass;
  1698. begin
  1699. Result:=TDataRequest;
  1700. end;
  1701. function TDataProxy.GetUpdateDescriptorClass: TRecordUpdateDescriptorClass;
  1702. begin
  1703. Result:=TRecordUpdateDescriptor;
  1704. end;
  1705. function TDataProxy.GetUpdateBatchClass: TRecordUpdateBatchClass;
  1706. begin
  1707. Result:=TRecordUpdateBatch;
  1708. end;
  1709. procedure TDataProxy.ResolveBatch(aBatch: TRecordUpdateBatch);
  1710. begin
  1711. try
  1712. If Assigned(ABatch.FOnResolve) then
  1713. ABatch.FOnResolve(Self,ABatch);
  1714. finally
  1715. aBatch.Free;
  1716. end;
  1717. end;
  1718. function TDataProxy.GetDataRequest(aOptions: TLoadOptions; aAfterRequest : TDataRequestEvent; aAfterLoad: TDatasetLoadEvent): TDataRequest;
  1719. begin
  1720. Result:=GetDataRequestClass.Create(Self,aOptions,aAfterRequest,aAfterLoad);
  1721. end;
  1722. function TDataProxy.GetUpdateDescriptor(aDataset : TDataset; aBookmark: TBookMark; AData: JSValue; AStatus: TUpdateStatus): TRecordUpdateDescriptor;
  1723. begin
  1724. Result:=GetUpdateDescriptorClass.Create(Self,aDataset, aBookmark,AData,AStatus);
  1725. end;
  1726. function TDataProxy.GetRecordUpdateBatch(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList : Boolean = True): TRecordUpdateBatch;
  1727. begin
  1728. Result:=GetUpdateBatchClass.Create(aBatchID,AList,AOwnsList);
  1729. end;
  1730. { EUpdateError }
  1731. constructor EUpdateError.Create(NativeError, Context : String;
  1732. ErrCode, PrevError : integer; E: Exception);
  1733. begin
  1734. Inherited CreateFmt(NativeError,[Context]);
  1735. FContext := Context;
  1736. FErrorCode := ErrCode;
  1737. FPreviousError := PrevError;
  1738. FOriginalException := E;
  1739. end;
  1740. Destructor EUpdateError.Destroy;
  1741. begin
  1742. FOriginalException.Free;
  1743. Inherited;
  1744. end;
  1745. { TNamedItem }
  1746. function TNamedItem.GetDisplayName: string;
  1747. begin
  1748. Result := FName;
  1749. end;
  1750. procedure TNamedItem.SetDisplayName(const Value: string);
  1751. Var TmpInd : Integer;
  1752. begin
  1753. if FName=Value then exit;
  1754. if (Value <> '') and (Collection is TFieldDefs ) then
  1755. begin
  1756. TmpInd := (TDefCollection(Collection).IndexOf(Value));
  1757. if (TmpInd >= 0) and (TmpInd <> Index) then
  1758. DatabaseErrorFmt(SDuplicateName, [Value, Collection.ClassName]);
  1759. end;
  1760. FName:=Value;
  1761. inherited SetDisplayName(Value);
  1762. end;
  1763. { TDefCollection }
  1764. procedure TDefCollection.SetItemName(Item: TCollectionItem);
  1765. Var
  1766. N : TNamedItem;
  1767. TN : String;
  1768. begin
  1769. N:=Item as TNamedItem;
  1770. if N.Name = '' then
  1771. begin
  1772. TN:=Copy(ClassName, 2, 5) + IntToStr(N.ID+1);
  1773. if assigned(Dataset) then
  1774. TN:=Dataset.Name+TN;
  1775. N.Name:=TN;
  1776. end
  1777. else
  1778. inherited SetItemName(Item);
  1779. end;
  1780. constructor TDefCollection.create(ADataset: TDataset; AOwner: TPersistent;
  1781. AClass: TCollectionItemClass);
  1782. begin
  1783. inherited Create(AOwner,AClass);
  1784. FDataset := ADataset;
  1785. end;
  1786. function TDefCollection.Find(const AName: string): TNamedItem;
  1787. var i: integer;
  1788. begin
  1789. Result := Nil;
  1790. for i := 0 to Count - 1 do
  1791. if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
  1792. begin
  1793. Result := TNamedItem(Items[i]);
  1794. Break;
  1795. end;
  1796. end;
  1797. procedure TDefCollection.GetItemNames(List: TStrings);
  1798. var i: LongInt;
  1799. begin
  1800. for i := 0 to Count - 1 do
  1801. List.Add(TNamedItem(Items[i]).Name);
  1802. end;
  1803. function TDefCollection.IndexOf(const AName: string): Longint;
  1804. var i: LongInt;
  1805. begin
  1806. Result := -1;
  1807. for i := 0 to Count - 1 do
  1808. if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
  1809. begin
  1810. Result := i;
  1811. Break;
  1812. end;
  1813. end;
  1814. { TIndexDef }
  1815. procedure TIndexDef.SetDescFields(const AValue: string);
  1816. begin
  1817. if FDescFields=AValue then exit;
  1818. if AValue <> '' then FOptions:=FOptions + [ixDescending];
  1819. FDescFields:=AValue;
  1820. end;
  1821. procedure TIndexDef.Assign(Source: TPersistent);
  1822. var idef : TIndexDef;
  1823. begin
  1824. idef := nil;
  1825. if Source is TIndexDef then
  1826. idef := Source as TIndexDef;
  1827. if Assigned(idef) then
  1828. begin
  1829. FName := idef.Name;
  1830. FFields := idef.Fields;
  1831. FOptions := idef.Options;
  1832. FCaseinsFields := idef.CaseInsFields;
  1833. FDescFields := idef.DescFields;
  1834. FSource := idef.Source;
  1835. FExpression := idef.Expression;
  1836. end
  1837. else
  1838. inherited Assign(Source);
  1839. end;
  1840. function TIndexDef.GetExpression: string;
  1841. begin
  1842. Result := FExpression;
  1843. end;
  1844. procedure TIndexDef.SetExpression(const AValue: string);
  1845. begin
  1846. FExpression := AValue;
  1847. end;
  1848. procedure TIndexDef.SetCaseInsFields(const AValue: string);
  1849. begin
  1850. if FCaseinsFields=AValue then exit;
  1851. if AValue <> '' then FOptions:=FOptions + [ixCaseInsensitive];
  1852. FCaseinsFields:=AValue;
  1853. end;
  1854. constructor TIndexDef.Create(Owner: TIndexDefs; const AName, TheFields: string;
  1855. TheOptions: TIndexOptions);
  1856. begin
  1857. FName := aname;
  1858. inherited create(Owner);
  1859. FFields := TheFields;
  1860. FOptions := TheOptions;
  1861. end;
  1862. { TIndexDefs }
  1863. Function TIndexDefs.GetItem (Index : integer) : TIndexDef;
  1864. begin
  1865. Result:=(Inherited GetItem(Index)) as TIndexDef;
  1866. end;
  1867. Procedure TIndexDefs.SetItem(Index: Integer; Value: TIndexDef);
  1868. begin
  1869. Inherited SetItem(Index,Value);
  1870. end;
  1871. constructor TIndexDefs.Create(ADataSet: TDataSet);
  1872. begin
  1873. inherited create(ADataset, Owner, TIndexDef);
  1874. end;
  1875. Function TIndexDefs.AddIndexDef: TIndexDef;
  1876. begin
  1877. // Result := inherited add as TIndexDef;
  1878. Result:=TIndexDef.Create(Self,'','',[]);
  1879. end;
  1880. procedure TIndexDefs.Add(const Name, Fields: string; Options: TIndexOptions);
  1881. begin
  1882. TIndexDef.Create(Self,Name,Fields,Options);
  1883. end;
  1884. function TIndexDefs.Find(const IndexName: string): TIndexDef;
  1885. begin
  1886. Result := (inherited Find(IndexName)) as TIndexDef;
  1887. if (Result=Nil) Then
  1888. DatabaseErrorFmt(SIndexNotFound, [IndexName], FDataSet);
  1889. end;
  1890. function TIndexDefs.FindIndexForFields(const Fields: string): TIndexDef;
  1891. begin
  1892. //!! To be implemented
  1893. Result:=nil;
  1894. end;
  1895. function TIndexDefs.GetIndexForFields(const Fields: string;
  1896. CaseInsensitive: Boolean): TIndexDef;
  1897. var
  1898. i, FieldsLen: integer;
  1899. Last: TIndexDef;
  1900. begin
  1901. Last := nil;
  1902. FieldsLen := Length(Fields);
  1903. for i := 0 to Count - 1 do
  1904. begin
  1905. Result := Items[I];
  1906. if (Result.Options * [ixDescending, ixExpression] = []) and
  1907. (not CaseInsensitive or (ixCaseInsensitive in Result.Options)) and
  1908. AnsiSameText(Fields, Result.Fields) then
  1909. begin
  1910. Exit;
  1911. end else
  1912. if AnsiSameText(Fields, Copy(Result.Fields, 1, FieldsLen)) and
  1913. ((Length(Result.Fields) = FieldsLen) or
  1914. (Result.Fields[FieldsLen + 1] = ';')) then
  1915. begin
  1916. if (Last = nil) or
  1917. ((Last <> nil) And (Length(Last.Fields) > Length(Result.Fields))) then
  1918. Last := Result;
  1919. end;
  1920. end;
  1921. Result := Last;
  1922. end;
  1923. procedure TIndexDefs.Update;
  1924. begin
  1925. if (not updated) and assigned(Dataset) then
  1926. begin
  1927. Dataset.UpdateIndexDefs;
  1928. updated := True;
  1929. end;
  1930. end;
  1931. { TCheckConstraint }
  1932. procedure TCheckConstraint.Assign(Source: TPersistent);
  1933. begin
  1934. //!! To be implemented
  1935. end;
  1936. { TCheckConstraints }
  1937. Function TCheckConstraints.GetItem(Index : Longint) : TCheckConstraint;
  1938. begin
  1939. //!! To be implemented
  1940. Result := nil;
  1941. end;
  1942. Procedure TCheckConstraints.SetItem(index : Longint; Value : TCheckConstraint);
  1943. begin
  1944. //!! To be implemented
  1945. end;
  1946. function TCheckConstraints.GetOwner: TPersistent;
  1947. begin
  1948. //!! To be implemented
  1949. Result := nil;
  1950. end;
  1951. constructor TCheckConstraints.Create(AOwner: TPersistent);
  1952. begin
  1953. //!! To be implemented
  1954. inherited Create(TCheckConstraint);
  1955. end;
  1956. function TCheckConstraints.Add: TCheckConstraint;
  1957. begin
  1958. //!! To be implemented
  1959. Result := nil;
  1960. end;
  1961. { TLookupList }
  1962. constructor TLookupList.Create;
  1963. begin
  1964. FList := TFPList.Create;
  1965. end;
  1966. destructor TLookupList.Destroy;
  1967. begin
  1968. Clear;
  1969. FList.Destroy;
  1970. inherited Destroy;
  1971. end;
  1972. procedure TLookupList.Add(const AKey, AValue: JSValue);
  1973. var LookupRec: TJSObject;
  1974. begin
  1975. LookupRec:=New(['Key',AKey,'Value',AValue]);
  1976. FList.Add(LookupRec);
  1977. end;
  1978. procedure TLookupList.Clear;
  1979. begin
  1980. FList.Clear;
  1981. end;
  1982. function TLookupList.FirstKeyByValue(const AValue: JSValue): JSValue;
  1983. var
  1984. i: Integer;
  1985. begin
  1986. for i := 0 to FList.Count - 1 do
  1987. with TJSObject(FList[i]) do
  1988. if Properties['Value'] = AValue then
  1989. begin
  1990. Result := Properties['Key'];
  1991. exit;
  1992. end;
  1993. Result := Null;
  1994. end;
  1995. function TLookupList.ValueOfKey(const AKey: JSValue): JSValue;
  1996. Function VarArraySameValues(VarArray1,VarArray2 : TJSValueDynArray) : Boolean;
  1997. // This only works for one-dimensional vararrays with a lower bound of 0
  1998. // and equal higher bounds wich only contains JSValues.
  1999. // The vararrays returned by GetFieldValues do apply.
  2000. var i : integer;
  2001. begin
  2002. Result := True;
  2003. if (Length(VarArray1)<>Length(VarArray2)) then
  2004. exit;
  2005. for i := 0 to Length(VarArray1) do
  2006. begin
  2007. if VarArray1[i]<>VarArray2[i] then
  2008. begin
  2009. Result := false;
  2010. Exit;
  2011. end;
  2012. end;
  2013. end;
  2014. var I: Integer;
  2015. begin
  2016. Result := Null;
  2017. if IsNull(AKey) then Exit;
  2018. i := FList.Count - 1;
  2019. if IsArray(AKey) then
  2020. while (i >= 0) And not VarArraySameValues(TJSValueDynArray(TJSOBject(FList.Items[I]).Properties['Key']),TJSValueDynArray(AKey)) do Dec(i)
  2021. else
  2022. while (i >= 0) And (TJSObject(FList[I]).Properties['Key'] <> AKey) do Dec(i);
  2023. if i >= 0 then Result := TJSObject(FList[I]).Properties['Value'];
  2024. end;
  2025. procedure TLookupList.ValuesToStrings(AStrings: TStrings);
  2026. var
  2027. i: Integer;
  2028. p: TJSObject;
  2029. begin
  2030. AStrings.Clear;
  2031. for i := 0 to FList.Count - 1 do
  2032. begin
  2033. p := TJSObject(FList[i]);
  2034. AStrings.AddObject(String(p.properties['Value']), TObject(p));
  2035. end;
  2036. end;
  2037. { ---------------------------------------------------------------------
  2038. TDataSet
  2039. ---------------------------------------------------------------------}
  2040. Const
  2041. DefaultBufferCount = 10;
  2042. constructor TDataSet.Create(AOwner: TComponent);
  2043. begin
  2044. Inherited Create(AOwner);
  2045. FFieldDefs:=FieldDefsClass.Create(Self);
  2046. FFieldList:=FieldsClass.Create(Self);
  2047. FDataSources:=TFPList.Create;
  2048. FConstraints:=TCheckConstraints.Create(Self);
  2049. SetLength(FBuffers,1);
  2050. FActiveRecord := 0;
  2051. FEOF := True;
  2052. FBOF := True;
  2053. FIsUniDirectional := False;
  2054. FAutoCalcFields := True;
  2055. FDataRequestID:=0;
  2056. end;
  2057. destructor TDataSet.Destroy;
  2058. var
  2059. i: Integer;
  2060. begin
  2061. Active:=False;
  2062. FFieldDefs.Free;
  2063. FFieldList.Free;
  2064. With FDataSources do
  2065. begin
  2066. While Count>0 do
  2067. TDataSource(Items[Count - 1]).DataSet:=Nil;
  2068. Destroy;
  2069. end;
  2070. for i := 0 to FBufferCount do
  2071. FreeRecordBuffer(FBuffers[i]);
  2072. FConstraints.Free;
  2073. SetLength(FBuffers,1);
  2074. Inherited Destroy;
  2075. end;
  2076. // This procedure must be called when the first record is made/read
  2077. procedure TDataSet.ActivateBuffers;
  2078. begin
  2079. FBOF:=False;
  2080. FEOF:=False;
  2081. FActiveRecord:=0;
  2082. end;
  2083. procedure TDataSet.BindFields(Binding: Boolean);
  2084. var i, FieldIndex: Integer;
  2085. FieldDef: TFieldDef;
  2086. Field: TField;
  2087. begin
  2088. { FieldNo is set to -1 for calculated/lookup fields, to 0 for unbound field
  2089. and for bound fields it is set to FieldDef.FieldNo }
  2090. FCalcFieldsCount := 0;
  2091. FBlobFieldCount := 0;
  2092. for i := 0 to Fields.Count - 1 do
  2093. begin
  2094. Field := Fields[i];
  2095. Field.FFieldDef := Nil;
  2096. if not Binding then
  2097. Field.FFieldNo := 0
  2098. else if Field.FieldKind in [fkCalculated, fkLookup] then
  2099. begin
  2100. Field.FFieldNo := -1;
  2101. Inc(FCalcFieldsCount);
  2102. end
  2103. else
  2104. begin
  2105. FieldIndex := FieldDefs.IndexOf(Field.FieldName);
  2106. if FieldIndex = -1 then
  2107. DatabaseErrorFmt(SFieldNotFound,[Field.FieldName],Self)
  2108. else
  2109. begin
  2110. FieldDef := FieldDefs[FieldIndex];
  2111. Field.FFieldDef := FieldDef;
  2112. Field.FFieldNo := FieldDef.FieldNo;
  2113. if FieldDef.InternalCalcField then
  2114. FInternalCalcFields := True;
  2115. if Field.IsBlob then
  2116. begin
  2117. Field.FSize := FieldDef.Size;
  2118. Inc(FBlobFieldCount);
  2119. end;
  2120. // synchronize CodePage between TFieldDef and TField
  2121. // character data in record buffer and field buffer should have same CodePage
  2122. end;
  2123. end;
  2124. Field.Bind(Binding);
  2125. end;
  2126. end;
  2127. function TDataSet.BookmarkAvailable: Boolean;
  2128. Const BookmarkStates = [dsBrowse,dsEdit,dsInsert];
  2129. begin
  2130. Result:=(Not IsEmpty) and not FIsUniDirectional and (State in BookmarkStates)
  2131. and (getBookMarkFlag(ActiveBuffer)=bfCurrent);
  2132. end;
  2133. procedure TDataSet.CalculateFields(var Buffer: TDataRecord);
  2134. var
  2135. i: Integer;
  2136. OldState: TDatasetState;
  2137. begin
  2138. FCalcBuffer := Buffer;
  2139. if FState <> dsInternalCalc then
  2140. begin
  2141. OldState := FState;
  2142. FState := dsCalcFields;
  2143. try
  2144. ClearCalcFields(FCalcBuffer);
  2145. if not IsUniDirectional then
  2146. for i := 0 to FFieldList.Count - 1 do
  2147. if FFieldList[i].FieldKind = fkLookup then
  2148. FFieldList[i].CalcLookupValue;
  2149. finally
  2150. DoOnCalcFields;
  2151. FState := OldState;
  2152. end;
  2153. end;
  2154. end;
  2155. procedure TDataSet.CheckActive;
  2156. begin
  2157. If Not Active then
  2158. DataBaseError(SInactiveDataset,Self);
  2159. end;
  2160. procedure TDataSet.CheckInactive;
  2161. begin
  2162. If Active then
  2163. DataBaseError(SActiveDataset,Self);
  2164. end;
  2165. procedure TDataSet.ClearBuffers;
  2166. begin
  2167. FRecordCount:=0;
  2168. FActiveRecord:=0;
  2169. FCurrentRecord:=-1;
  2170. FBOF:=True;
  2171. FEOF:=True;
  2172. end;
  2173. procedure TDataSet.ClearCalcFields(var Buffer: TDataRecord);
  2174. begin
  2175. // Empty
  2176. end;
  2177. procedure TDataSet.CloseBlob(Field: TField);
  2178. begin
  2179. //!! To be implemented
  2180. end;
  2181. procedure TDataSet.CloseCursor;
  2182. begin
  2183. ClearBuffers;
  2184. SetBufListSize(0);
  2185. Fields.ClearFieldDefs;
  2186. InternalClose;
  2187. FInternalOpenComplete := False;
  2188. end;
  2189. procedure TDataSet.CreateFields;
  2190. Var I : longint;
  2191. begin
  2192. {$ifdef DSDebug}
  2193. Writeln ('Creating fields');
  2194. Writeln ('Count : ',fielddefs.Count);
  2195. For I:=0 to FieldDefs.Count-1 do
  2196. Writeln('Def ',I,' : ',Fielddefs.items[i].Name,'(',Fielddefs.items[i].FieldNo,')');
  2197. {$endif}
  2198. For I:=0 to FieldDefs.Count-1 do
  2199. With FieldDefs.Items[I] do
  2200. If DataType<>ftUnknown then
  2201. begin
  2202. {$ifdef DSDebug}
  2203. Writeln('About to create field ',FieldDefs.Items[i].Name);
  2204. {$endif}
  2205. CreateField(self);
  2206. end;
  2207. end;
  2208. procedure TDataSet.DataEvent(Event: TDataEvent; Info: JSValue);
  2209. procedure HandleFieldChange(aField: TField);
  2210. begin
  2211. if aField.FieldKind in [fkData, fkInternalCalc] then
  2212. SetModified(True);
  2213. if State <> dsSetKey then begin
  2214. if aField.FieldKind = fkData then begin
  2215. if FInternalCalcFields then
  2216. RefreshInternalCalcFields(FBuffers[FActiveRecord])
  2217. else if FAutoCalcFields and (FCalcFieldsCount <> 0) then
  2218. CalculateFields(FBuffers[FActiveRecord]);
  2219. end;
  2220. aField.Change;
  2221. end;
  2222. end;
  2223. procedure HandleScrollOrChange;
  2224. begin
  2225. if State <> dsInsert then
  2226. UpdateCursorPos;
  2227. end;
  2228. var
  2229. i: Integer;
  2230. begin
  2231. case Event of
  2232. deFieldChange : HandleFieldChange(TField(Info));
  2233. deDataSetChange,
  2234. deDataSetScroll : HandleScrollOrChange;
  2235. deLayoutChange : FEnableControlsEvent:=deLayoutChange;
  2236. end;
  2237. if not ControlsDisabled and (FState <> dsBlockRead) then begin
  2238. for i := 0 to FDataSources.Count - 1 do
  2239. TDataSource(FDataSources[i]).ProcessEvent(Event, Info);
  2240. end;
  2241. end;
  2242. procedure TDataSet.DestroyFields;
  2243. begin
  2244. FFieldList.Clear;
  2245. end;
  2246. procedure TDataSet.DoAfterCancel;
  2247. begin
  2248. If assigned(FAfterCancel) then
  2249. FAfterCancel(Self);
  2250. end;
  2251. procedure TDataSet.DoAfterClose;
  2252. begin
  2253. If assigned(FAfterClose) and not (csDestroying in ComponentState) then
  2254. FAfterClose(Self);
  2255. end;
  2256. procedure TDataSet.DoAfterDelete;
  2257. begin
  2258. If assigned(FAfterDelete) then
  2259. FAfterDelete(Self);
  2260. end;
  2261. procedure TDataSet.DoAfterEdit;
  2262. begin
  2263. If assigned(FAfterEdit) then
  2264. FAfterEdit(Self);
  2265. end;
  2266. procedure TDataSet.DoAfterInsert;
  2267. begin
  2268. If assigned(FAfterInsert) then
  2269. FAfterInsert(Self);
  2270. end;
  2271. procedure TDataSet.DoAfterOpen;
  2272. begin
  2273. If assigned(FAfterOpen) then
  2274. FAfterOpen(Self);
  2275. end;
  2276. procedure TDataSet.DoAfterPost;
  2277. begin
  2278. If assigned(FAfterPost) then
  2279. FAfterPost(Self);
  2280. end;
  2281. procedure TDataSet.DoAfterScroll;
  2282. begin
  2283. If assigned(FAfterScroll) then
  2284. FAfterScroll(Self);
  2285. end;
  2286. procedure TDataSet.DoAfterRefresh;
  2287. begin
  2288. If assigned(FAfterRefresh) then
  2289. FAfterRefresh(Self);
  2290. end;
  2291. procedure TDataSet.DoBeforeCancel;
  2292. begin
  2293. If assigned(FBeforeCancel) then
  2294. FBeforeCancel(Self);
  2295. end;
  2296. procedure TDataSet.DoBeforeClose;
  2297. begin
  2298. If assigned(FBeforeClose) and not (csDestroying in ComponentState) then
  2299. FBeforeClose(Self);
  2300. end;
  2301. procedure TDataSet.DoBeforeDelete;
  2302. begin
  2303. If assigned(FBeforeDelete) then
  2304. FBeforeDelete(Self);
  2305. end;
  2306. procedure TDataSet.DoBeforeEdit;
  2307. begin
  2308. If assigned(FBeforeEdit) then
  2309. FBeforeEdit(Self);
  2310. end;
  2311. procedure TDataSet.DoBeforeInsert;
  2312. begin
  2313. If assigned(FBeforeInsert) then
  2314. FBeforeInsert(Self);
  2315. end;
  2316. procedure TDataSet.DoBeforeOpen;
  2317. begin
  2318. If assigned(FBeforeOpen) then
  2319. FBeforeOpen(Self);
  2320. end;
  2321. procedure TDataSet.DoBeforePost;
  2322. begin
  2323. If assigned(FBeforePost) then
  2324. FBeforePost(Self);
  2325. end;
  2326. procedure TDataSet.DoBeforeScroll;
  2327. begin
  2328. If assigned(FBeforeScroll) then
  2329. FBeforeScroll(Self);
  2330. end;
  2331. procedure TDataSet.DoBeforeRefresh;
  2332. begin
  2333. If assigned(FBeforeRefresh) then
  2334. FBeforeRefresh(Self);
  2335. end;
  2336. procedure TDataSet.DoInternalOpen;
  2337. begin
  2338. InternalOpen;
  2339. FInternalOpenComplete := True;
  2340. {$ifdef dsdebug}
  2341. Writeln ('Calling internal open');
  2342. {$endif}
  2343. {$ifdef dsdebug}
  2344. Writeln ('Calling RecalcBufListSize');
  2345. {$endif}
  2346. FRecordCount := 0;
  2347. RecalcBufListSize;
  2348. FBOF := True;
  2349. FEOF := (FRecordCount = 0);
  2350. if Assigned(DataProxy) then
  2351. InitChangeList;
  2352. end;
  2353. procedure TDataSet.DoOnCalcFields;
  2354. begin
  2355. If Assigned(FOnCalcfields) then
  2356. FOnCalcFields(Self);
  2357. end;
  2358. procedure TDataSet.DoOnNewRecord;
  2359. begin
  2360. If assigned(FOnNewRecord) then
  2361. FOnNewRecord(Self);
  2362. end;
  2363. procedure TDataSet.DoBeforeLoad;
  2364. begin
  2365. If Assigned(FBeforeLoad) then
  2366. FBeforeLoad(Self);
  2367. end;
  2368. procedure TDataSet.DoAfterLoad;
  2369. begin
  2370. if Assigned(FAfterLoad) then
  2371. FAfterLoad(Self);
  2372. end;
  2373. procedure TDataSet.DoBeforeApplyUpdates;
  2374. begin
  2375. If Assigned(FBeforeApplyUpdates) then
  2376. FBeforeApplyUpdates(Self);
  2377. end;
  2378. procedure TDataSet.DoAfterApplyUpdates(Const ResolveInfo : TResolveResults);
  2379. begin
  2380. If Assigned(FAfterApplyUpdates) then
  2381. FAfterApplyUpdates(Self,ResolveInfo);
  2382. end;
  2383. function TDataSet.FieldByNumber(FieldNo: Longint): TField;
  2384. begin
  2385. Result:=FFieldList.FieldByNumber(FieldNo);
  2386. end;
  2387. function TDataSet.FindRecord(Restart, GoForward: Boolean): Boolean;
  2388. begin
  2389. //!! To be implemented
  2390. Result:=false;
  2391. end;
  2392. function TDataSet.GetBookmarkStr: TBookmarkStr;
  2393. Var
  2394. B : TBookMark;
  2395. begin
  2396. Result:='';
  2397. If BookMarkAvailable then
  2398. begin
  2399. GetBookMarkData(ActiveBuffer,B);
  2400. Result:=TJSJSON.stringify(B);
  2401. end
  2402. end;
  2403. function TDataSet.GetBuffer(Index: longint): TDataRecord;
  2404. begin
  2405. Result:=FBuffers[Index];
  2406. end;
  2407. function TDataSet.GetBufferCount: Longint;
  2408. begin
  2409. Result:=Length(FBuffers);
  2410. end;
  2411. function TDataSet.DoGetDataProxy: TDataProxy;
  2412. begin
  2413. Result:=nil;
  2414. end;
  2415. procedure TDataSet.InitChangeList;
  2416. begin
  2417. DoneChangeList;
  2418. FChangeList:=TFPList.Create;
  2419. end;
  2420. procedure TDataSet.ClearChangeList;
  2421. Var
  2422. I : integer;
  2423. begin
  2424. If not Assigned(FChangeList) then
  2425. exit;
  2426. For I:=0 to FChangeList.Count-1 do
  2427. begin
  2428. TObject(FChangeList[i]).Destroy;
  2429. FChangeList[i]:=Nil;
  2430. end;
  2431. end;
  2432. Function TDataSet.IndexInChangeList(aBookmark : TBookmark) : Integer;
  2433. begin
  2434. Result:=-1;
  2435. if Not assigned(FChangeList) then
  2436. exit;
  2437. Result:=FChangeList.Count-1;
  2438. While (Result>=0) and (CompareBookmarks(aBookMark,TRecordUpdateDescriptor(FChangeList[Result]).Bookmark)<>0) do
  2439. Dec(Result);
  2440. end;
  2441. Function TDataSet.AddToChangeList(aChange: TUpdateStatus) : TRecordUpdateDescriptor;
  2442. Var
  2443. B : TBookmark;
  2444. I : Integer;
  2445. begin
  2446. Result:=Nil;
  2447. if Not Assigned(FChangeList) then
  2448. Exit;
  2449. B:=GetBookmark;
  2450. I:=IndexInChangeList(B);
  2451. if (I=-1) then
  2452. begin
  2453. if Assigned(DataProxy) then
  2454. Result:=DataProxy.GetUpdateDescriptor(Self,B,ActiveBuffer.data,aChange)
  2455. else
  2456. Result:=TRecordUpdateDescriptor.Create(Nil,Self,B,ActiveBuffer.data,aChange);
  2457. FChangeList.Add(Result);
  2458. end
  2459. else
  2460. begin
  2461. Result:=TRecordUpdateDescriptor(FChangeList[i]);
  2462. Case aChange of
  2463. usDeleted : Result.FStatus:=usDeleted;
  2464. usInserted : DatabaseError(SErrInsertingSameRecordtwice,Self);
  2465. usModified : Result.FData:=ActiveBuffer.Data;
  2466. end
  2467. end;
  2468. end;
  2469. procedure TDataSet.RemoveFromChangeList(R: TRecordUpdateDescriptor);
  2470. begin
  2471. if Not (Assigned(R) and Assigned(FChangeList)) then
  2472. Exit;
  2473. end;
  2474. Function TDataSet.GetRecordUpdates(AList: TRecordUpdateDescriptorList) : Integer;
  2475. Var
  2476. I,MinIndex : integer;
  2477. begin
  2478. MinIndex:=0; // Check batch list for minimal index ?
  2479. For I:=MinIndex to FChangeList.Count-1 do
  2480. Alist.Add(FChangeList[i]);
  2481. Result:=FChangeList.Count;
  2482. end;
  2483. Function TDataSet.ResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor) : Boolean;
  2484. // This must return true if the record may be removed from the list of 'modified' records.
  2485. // If it returns false, the record is kept in the list of modified records.
  2486. begin
  2487. try
  2488. Result:=DoResolveRecordUpdate(anUpdate);
  2489. If not Result then
  2490. anUpdate.FStatus:=usResolveFailed;
  2491. except
  2492. On E : Exception do
  2493. begin
  2494. anUpdate.ResolveFailed(E.Classname+': '+E.Message);
  2495. Result:=False;
  2496. end;
  2497. end;
  2498. DoOnRecordResolved(anUpdate);
  2499. end;
  2500. Function TDataSet.RecordUpdateDescriptorToResolveInfo(anUpdate: TRecordUpdateDescriptor) : TResolveInfo;
  2501. begin
  2502. Result.BookMark:=anUpdate.Bookmark;
  2503. Result.Data:=anUpdate.Data;
  2504. Result.Status:=anUpdate.Status;
  2505. Result.Error:=anUpdate.ResolveError;
  2506. end;
  2507. procedure TDataSet.DoOnRecordResolved(anUpdate: TRecordUpdateDescriptor) ;
  2508. Var
  2509. Info : TResolveInfo;
  2510. begin
  2511. if Not Assigned(OnRecordResolved) then exit;
  2512. Info:=RecordUpdateDescriptorToResolveInfo(anUpdate);
  2513. OnRecordResolved(Self,Info);
  2514. end;
  2515. procedure TDataSet.ResolveUpdateBatch(Sender: TObject; aBatch : TRecordUpdateBatch);
  2516. Var
  2517. BI,RI,Idx: integer;
  2518. RUD : TRecordUpdateDescriptor;
  2519. doRemove : Boolean;
  2520. Results : TResolveResults;
  2521. begin
  2522. if Assigned(FBatchList) and (aBatch.Dataset=Self) then
  2523. BI:=FBatchList.IndexOf(aBatch)
  2524. else
  2525. BI:=-1;
  2526. if (BI=-1) then
  2527. Exit;
  2528. FBatchList.Delete(Bi);
  2529. SetLength(Results.Records, aBatch.List.Count);
  2530. For RI:=0 to aBatch.List.Count-1 do
  2531. begin
  2532. RUD:=aBatch.List[RI];
  2533. Results.Records[RI]:=RecordUpdateDescriptorToResolveInfo(RUD);
  2534. aBatch.List.Items[RI]:=Nil;
  2535. Idx:=IndexInChangeList(RUD.Bookmark);
  2536. if (Idx<>-1) then
  2537. begin
  2538. doRemove:=False;
  2539. if (RUD.Status=usResolved) then
  2540. DoRemove:=ResolveRecordUpdate(RUD)
  2541. else
  2542. // What if not resolvable.. ?
  2543. DoRemove:=(RUD.Status in [usUnmodified]);
  2544. If DoRemove then
  2545. begin
  2546. RUD.Free;
  2547. FChangeList.Delete(Idx);
  2548. end
  2549. else
  2550. RUD.Reset; // So we try it again in next applyupdates.
  2551. end;
  2552. end;
  2553. if (FBatchList.Count=0) then
  2554. FreeAndNil(FBatchList);
  2555. DoAfterApplyUpdates(Results);
  2556. end;
  2557. procedure TDataSet.DoApplyUpdates;
  2558. Var
  2559. B : TRecordUpdateBatch;
  2560. l : TRecordUpdateDescriptorList;
  2561. I : integer;
  2562. begin
  2563. if Not Assigned(DataProxy) then
  2564. DatabaseError(SErrDoApplyUpdatesNeedsProxy,Self);
  2565. if Not (Assigned(FChangeList) and (FChangeList.Count>0)) then
  2566. Exit;
  2567. L:=TRecordUpdateDescriptorList.Create;
  2568. try
  2569. I:=GetRecordUpdates(L);
  2570. except
  2571. L.Free;
  2572. Raise;
  2573. end;
  2574. Inc(FUpdateBatchID);
  2575. B:=DataProxy.GetRecordUpdateBatch(FUpdateBatchID,L,True);
  2576. B.FDataset:=Self;
  2577. B.FLastChangeIndex:=I;
  2578. B.OnResolve:=@ResolveUpdateBatch;
  2579. If not Assigned(FBatchlist) then
  2580. FBatchlist:=TFPList.Create;
  2581. FBatchList.Add(B);
  2582. DataProxy.ProcessUpdateBatch(B);
  2583. end;
  2584. procedure TDataSet.DoneChangeList;
  2585. begin
  2586. ClearChangeList;
  2587. FreeAndNil(FChangeList);
  2588. end;
  2589. function TDataSet.GetDataProxy: TDataProxy;
  2590. begin
  2591. If (FDataProxy=Nil) then
  2592. DataProxy:=DoGetDataProxy;
  2593. Result:=FDataProxy;
  2594. end;
  2595. function TDataSet.DataPacketReceived(ARequest: TDataRequest): Boolean;
  2596. begin
  2597. Result:=False;
  2598. end;
  2599. procedure TDataSet.HandleRequestresponse(ARequest: TDataRequest);
  2600. Var
  2601. DataAdded : Boolean;
  2602. begin
  2603. if Not Assigned(ARequest) then
  2604. exit;
  2605. Case ARequest.Success of
  2606. rrFail:
  2607. begin
  2608. if Assigned(FOnLoadFail) then
  2609. FOnLoadFail(Self,aRequest.RequestID,aRequest.ErrorMsg);
  2610. end;
  2611. rrEOF,
  2612. rrOK :
  2613. begin
  2614. DataAdded:=False;
  2615. // Notify caller
  2616. if Assigned(ARequest.Event) then
  2617. ARequest.Event(Self,aRequest.Data);
  2618. // allow descendent to integrate data.
  2619. // Must be done before user is notified or dataset is opened...
  2620. if (ARequest.Success<>rrEOF) then
  2621. DataAdded:=DataPacketReceived(aRequest);
  2622. // Open if needed.
  2623. if Not (Active or (loNoOpen in aRequest.LoadOptions)) then
  2624. begin
  2625. // Notify user
  2626. if not (loNoEvents in aRequest.LoadOptions) then
  2627. DoAfterLoad;
  2628. Open
  2629. end
  2630. else
  2631. begin
  2632. if (loAtEOF in aRequest.LoadOptions) and DataAdded then
  2633. FEOF:=False;
  2634. if not (loNoEvents in aRequest.LoadOptions) then
  2635. DoAfterLoad;
  2636. end;
  2637. end;
  2638. end;
  2639. aRequest.Destroy;
  2640. end;
  2641. function TDataSet.DoResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
  2642. begin
  2643. Result:=True;
  2644. end;
  2645. procedure TDataSet.GetCalcFields(var Buffer: TDataRecord);
  2646. begin
  2647. if (FCalcFieldsCount > 0) or FInternalCalcFields then
  2648. CalculateFields(Buffer);
  2649. end;
  2650. function TDataSet.GetCanModify: Boolean;
  2651. begin
  2652. Result:= not FIsUnidirectional;
  2653. end;
  2654. procedure TDataSet.GetChildren(Proc: TGetChildProc; Root: TComponent);
  2655. var
  2656. I: Integer;
  2657. Field: TField;
  2658. begin
  2659. for I := 0 to Fields.Count - 1 do begin
  2660. Field := Fields[I];
  2661. if (Field.Owner = Root) then
  2662. Proc(Field);
  2663. end;
  2664. end;
  2665. function TDataSet.GetDataSource: TDataSource;
  2666. begin
  2667. Result:=nil;
  2668. end;
  2669. function TDataSet.GetRecordSize: Word;
  2670. begin
  2671. Result := 0;
  2672. end;
  2673. procedure TDataSet.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
  2674. begin
  2675. // empty stub
  2676. end;
  2677. procedure TDataSet.InternalDelete;
  2678. begin
  2679. // empty stub
  2680. end;
  2681. procedure TDataSet.InternalFirst;
  2682. begin
  2683. // empty stub
  2684. end;
  2685. procedure TDataSet.InternalGotoBookmark(ABookmark: TBookMark);
  2686. begin
  2687. // empty stub
  2688. end;
  2689. function TDataset.GetFieldData(Field: TField; Buffer: TDatarecord): JSValue;
  2690. begin
  2691. Result:=TJSObject(buffer.data).Properties[Field.FieldName];
  2692. end;
  2693. procedure TDataSet.SetFieldData(Field: TField; var Buffer: TDataRecord; AValue : JSValue);
  2694. begin
  2695. TJSObject(buffer.data).Properties[Field.FieldName]:=AValue;
  2696. end;
  2697. function TDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
  2698. begin
  2699. Result := DefaultFieldClasses[FieldType];
  2700. end;
  2701. function TDataSet.GetIsIndexField(Field: TField): Boolean;
  2702. begin
  2703. Result:=False;
  2704. end;
  2705. function TDataSet.GetIndexDefs(IndexDefs: TIndexDefs; IndexTypes: TIndexOptions
  2706. ): TIndexDefs;
  2707. var i,f : integer;
  2708. IndexFields : TStrings;
  2709. begin
  2710. IndexDefs.Update;
  2711. Result := TIndexDefs.Create(Self);
  2712. Result.Assign(IndexDefs);
  2713. i := 0;
  2714. IndexFields := TStringList.Create;
  2715. while i < result.Count do
  2716. begin
  2717. if (not ((IndexTypes = []) and (result[i].Options = []))) and
  2718. ((IndexTypes * result[i].Options) = []) then
  2719. begin
  2720. result.Delete(i);
  2721. dec(i);
  2722. end
  2723. else
  2724. begin
  2725. // ExtractStrings([';'],[' '],result[i].Fields,Indexfields);
  2726. for f := 0 to IndexFields.Count-1 do
  2727. if FindField(Indexfields[f]) = nil then
  2728. begin
  2729. result.Delete(i);
  2730. dec(i);
  2731. break;
  2732. end;
  2733. end;
  2734. inc(i);
  2735. end;
  2736. IndexFields.Free;
  2737. end;
  2738. function TDataSet.GetNextRecord: Boolean;
  2739. Var
  2740. T : TDataRecord;
  2741. begin
  2742. {$ifdef dsdebug}
  2743. Writeln ('Getting next record. Internal RecordCount : ',FRecordCount);
  2744. Writeln ('Getting next record. Internal buffercount : ',FBufferCount);
  2745. {$endif}
  2746. If FRecordCount>0 Then
  2747. SetCurrentRecord(FRecordCount-1);
  2748. Result:=GetRecord(FBuffers[FBufferCount],gmNext,True)=grOK;
  2749. if Result then
  2750. begin
  2751. If FRecordCount=0 then ActivateBuffers;
  2752. if FRecordCount=FBufferCount then
  2753. ShiftBuffersBackward
  2754. else
  2755. begin
  2756. Inc(FRecordCount);
  2757. FCurrentRecord:=FRecordCount - 1;
  2758. T:=FBuffers[FCurrentRecord];
  2759. FBuffers[FCurrentRecord]:=FBuffers[FBufferCount];
  2760. FBuffers[FBufferCount]:=T;
  2761. end;
  2762. end
  2763. else
  2764. CursorPosChanged;
  2765. {$ifdef dsdebug}
  2766. Writeln ('Result getting next record : ',Result);
  2767. {$endif}
  2768. end;
  2769. function TDataSet.GetNextRecords: Longint;
  2770. begin
  2771. Result:=0;
  2772. {$ifdef dsdebug}
  2773. Writeln ('Getting next record(s), need :',FBufferCount);
  2774. {$endif}
  2775. While (FRecordCount<FBufferCount) and GetNextRecord do
  2776. Inc(Result);
  2777. {$ifdef dsdebug}
  2778. Writeln ('Result Getting next record(S), GOT :',RESULT);
  2779. {$endif}
  2780. end;
  2781. function TDataSet.GetPriorRecord: Boolean;
  2782. begin
  2783. {$ifdef dsdebug}
  2784. Writeln ('GetPriorRecord: Getting previous record');
  2785. {$endif}
  2786. CheckBiDirectional;
  2787. If FRecordCount>0 Then SetCurrentRecord(0);
  2788. Result:=GetRecord(FBuffers[FBufferCount],gmPrior,True)=grOK;
  2789. if Result then
  2790. begin
  2791. If FRecordCount=0 then ActivateBuffers;
  2792. ShiftBuffersForward;
  2793. if FRecordCount<FBufferCount then
  2794. Inc(FRecordCount);
  2795. end
  2796. else
  2797. CursorPosChanged;
  2798. {$ifdef dsdebug}
  2799. Writeln ('Result getting prior record : ',Result);
  2800. {$endif}
  2801. end;
  2802. function TDataSet.GetPriorRecords: Longint;
  2803. begin
  2804. Result:=0;
  2805. {$ifdef dsdebug}
  2806. Writeln ('Getting previous record(s), need :',FBufferCount);
  2807. {$endif}
  2808. While (FRecordCount<FBufferCount) and GetPriorRecord do
  2809. Inc(Result);
  2810. end;
  2811. function TDataSet.GetRecNo: Longint;
  2812. begin
  2813. Result := -1;
  2814. end;
  2815. function TDataSet.GetRecordCount: Longint;
  2816. begin
  2817. Result := -1;
  2818. end;
  2819. procedure TDataSet.InitFieldDefs;
  2820. begin
  2821. if IsCursorOpen then
  2822. InternalInitFieldDefs
  2823. else
  2824. begin
  2825. try
  2826. OpenCursor(True);
  2827. finally
  2828. CloseCursor;
  2829. end;
  2830. end;
  2831. end;
  2832. procedure TDataSet.SetBlockReadSize(AValue: Integer);
  2833. begin
  2834. // the state is changed even when setting the same BlockReadSize (follows Delphi behavior)
  2835. // e.g., state is dsBrowse and BlockReadSize is 1. Setting BlockReadSize to 1 will change state to dsBlockRead
  2836. FBlockReadSize := AValue;
  2837. if AValue > 0 then
  2838. begin
  2839. CheckActive;
  2840. SetState(dsBlockRead);
  2841. end
  2842. else
  2843. begin
  2844. //update state only when in dsBlockRead
  2845. if FState = dsBlockRead then
  2846. SetState(dsBrowse);
  2847. end;
  2848. end;
  2849. procedure TDataSet.SetFieldDefs(AFieldDefs: TFieldDefs);
  2850. begin
  2851. Fields.ClearFieldDefs;
  2852. FFieldDefs.Assign(AFieldDefs);
  2853. end;
  2854. procedure TDataSet.DoInsertAppendRecord(const Values: array of JSValue; DoAppend : boolean);
  2855. var i : integer;
  2856. ValuesSize : integer;
  2857. begin
  2858. ValuesSize:=Length(Values);
  2859. if ValuesSize>FieldCount then DatabaseError(STooManyFields,self);
  2860. if DoAppend then
  2861. Append
  2862. else
  2863. Insert;
  2864. for i := 0 to ValuesSize-1 do
  2865. Fields[i].AssignValue(Values[i]);
  2866. Post;
  2867. end;
  2868. procedure TDataSet.InitFieldDefsFromFields;
  2869. var i : integer;
  2870. begin
  2871. if FieldDefs.Count = 0 then
  2872. begin
  2873. FieldDefs.BeginUpdate;
  2874. try
  2875. for i := 0 to Fields.Count-1 do with Fields[i] do
  2876. if not (FieldKind in [fkCalculated,fkLookup]) then // Do not add fielddefs for calculated/lookup fields.
  2877. begin
  2878. FFieldDef:=FieldDefs.FieldDefClass.Create(FieldDefs,FieldName,DataType,Size,Required,FieldDefs.Count+1);
  2879. with FFieldDef do
  2880. begin
  2881. if Required then Attributes := Attributes + [faRequired];
  2882. if ReadOnly then Attributes := Attributes + [faReadOnly];
  2883. end;
  2884. end;
  2885. finally
  2886. FieldDefs.EndUpdate;
  2887. end;
  2888. end;
  2889. end;
  2890. procedure TDataSet.InitRecord(var Buffer: TDataRecord);
  2891. begin
  2892. InternalInitRecord(Buffer);
  2893. ClearCalcFields(Buffer);
  2894. end;
  2895. procedure TDataSet.InternalCancel;
  2896. begin
  2897. //!! To be implemented
  2898. end;
  2899. procedure TDataSet.InternalEdit;
  2900. begin
  2901. //!! To be implemented
  2902. end;
  2903. procedure TDataSet.InternalRefresh;
  2904. begin
  2905. //!! To be implemented
  2906. end;
  2907. procedure TDataSet.OpenCursor(InfoQuery: Boolean);
  2908. begin
  2909. if InfoQuery then
  2910. InternalInitFieldDefs
  2911. else if State <> dsOpening then
  2912. DoInternalOpen;
  2913. end;
  2914. procedure TDataSet.OpenCursorcomplete;
  2915. begin
  2916. try
  2917. if FState = dsOpening then DoInternalOpen
  2918. finally
  2919. if FInternalOpenComplete then
  2920. begin
  2921. SetState(dsBrowse);
  2922. DoAfterOpen;
  2923. if not IsEmpty then
  2924. DoAfterScroll;
  2925. end
  2926. else
  2927. begin
  2928. SetState(dsInactive);
  2929. CloseCursor;
  2930. end;
  2931. end;
  2932. end;
  2933. procedure TDataSet.RefreshInternalCalcFields(Var Buffer: TDataRecord);
  2934. begin
  2935. //!! To be implemented
  2936. end;
  2937. function TDataSet.SetTempState(const Value: TDataSetState): TDataSetState;
  2938. begin
  2939. result := FState;
  2940. FState := value;
  2941. inc(FDisableControlsCount);
  2942. end;
  2943. procedure TDataSet.RestoreState(const Value: TDataSetState);
  2944. begin
  2945. FState := value;
  2946. dec(FDisableControlsCount);
  2947. end;
  2948. function TDataSet.GetActive: boolean;
  2949. begin
  2950. result := (FState <> dsInactive) and (FState <> dsOpening);
  2951. end;
  2952. procedure TDataSet.InternalHandleException(E :Exception);
  2953. begin
  2954. ShowException(E,Nil);
  2955. end;
  2956. procedure TDataSet.InternalInitRecord(var Buffer: TDataRecord);
  2957. begin
  2958. // empty stub
  2959. end;
  2960. procedure TDataSet.InternalLast;
  2961. begin
  2962. // empty stub
  2963. end;
  2964. procedure TDataSet.InternalPost;
  2965. Procedure CheckRequiredFields;
  2966. Var I : longint;
  2967. begin
  2968. For I:=0 to FFieldList.Count-1 do
  2969. With FFieldList[i] do
  2970. // Required fields that are NOT autoinc !! Autoinc cannot be set !!
  2971. if Required and not ReadOnly and
  2972. (FieldKind=fkData) and Not (DataType=ftAutoInc) and IsNull then
  2973. DatabaseErrorFmt(SNeedField,[DisplayName],Self);
  2974. end;
  2975. begin
  2976. CheckRequiredFields;
  2977. end;
  2978. procedure TDataSet.InternalSetToRecord(Buffer: TDataRecord);
  2979. begin
  2980. // empty stub
  2981. end;
  2982. procedure TDataSet.SetBookmarkFlag(Var Buffer: TDataRecord; Value: TBookmarkFlag);
  2983. begin
  2984. // empty stub
  2985. end;
  2986. procedure TDataSet.SetBookmarkData(Var Buffer: TDataRecord; Data: TBookmark);
  2987. begin
  2988. // empty stub
  2989. end;
  2990. procedure TDataSet.SetUniDirectional(const Value: Boolean);
  2991. begin
  2992. FIsUniDirectional := Value;
  2993. end;
  2994. procedure TDataSet.Notification(AComponent: TComponent; Operation: TOperation);
  2995. begin
  2996. inherited Notification(AComponent, Operation);
  2997. if (Operation=opRemove) and (AComponent=FDataProxy) then
  2998. FDataProxy:=Nil;
  2999. end;
  3000. class function TDataSet.FieldDefsClass: TFieldDefsClass;
  3001. begin
  3002. Result:=TFieldDefs;
  3003. end;
  3004. class function TDataSet.FieldsClass: TFieldsClass;
  3005. begin
  3006. Result:=TFields;
  3007. end;
  3008. procedure TDataSet.SetActive(Value: Boolean);
  3009. begin
  3010. if value and (Fstate = dsInactive) then
  3011. begin
  3012. if csLoading in ComponentState then
  3013. begin
  3014. FOpenAfterRead := true;
  3015. exit;
  3016. end
  3017. else
  3018. begin
  3019. DoBeforeOpen;
  3020. FEnableControlsEvent:=deLayoutChange;
  3021. FInternalCalcFields:=False;
  3022. try
  3023. FDefaultFields:=FieldCount=0;
  3024. OpenCursor(False);
  3025. finally
  3026. if FState <> dsOpening then OpenCursorComplete;
  3027. end;
  3028. end;
  3029. FModified:=False;
  3030. end
  3031. else if not value and (Fstate <> dsinactive) then
  3032. begin
  3033. DoBeforeClose;
  3034. SetState(dsInactive);
  3035. FDataRequestID:=0;
  3036. DoneChangeList;
  3037. CloseCursor;
  3038. DoAfterClose;
  3039. FModified:=False;
  3040. end
  3041. end;
  3042. procedure TDataSet.Loaded;
  3043. begin
  3044. inherited;
  3045. try
  3046. if FOpenAfterRead then SetActive(true);
  3047. except
  3048. on E : Exception do
  3049. if csDesigning in Componentstate then
  3050. InternalHandleException(E);
  3051. else
  3052. raise;
  3053. end;
  3054. end;
  3055. procedure TDataSet.RecalcBufListSize;
  3056. var
  3057. i, j, ABufferCount: Integer;
  3058. DataLink: TDataLink;
  3059. begin
  3060. {$ifdef dsdebug}
  3061. Writeln('Recalculating buffer list size - check cursor');
  3062. {$endif}
  3063. If Not IsCursorOpen Then
  3064. Exit;
  3065. {$ifdef dsdebug}
  3066. Writeln('Recalculating buffer list size');
  3067. {$endif}
  3068. if IsUniDirectional then
  3069. ABufferCount := 1
  3070. else
  3071. ABufferCount := DefaultBufferCount;
  3072. {$ifdef dsdebug}
  3073. Writeln('Recalculating buffer list size, start count: ',ABufferCount);
  3074. {$endif}
  3075. for i := 0 to FDataSources.Count - 1 do
  3076. for j := 0 to TDataSource(FDataSources[i]).DataLinks.Count - 1 do
  3077. begin
  3078. DataLink:=TDataLink(TDataSource(FDataSources[i]).DataLinks[j]);
  3079. if ABufferCount<DataLink.BufferCount then
  3080. ABufferCount:=DataLink.BufferCount;
  3081. end;
  3082. {$ifdef dsdebug}
  3083. Writeln('Recalculating buffer list size, end count: ',ABufferCount);
  3084. {$endif}
  3085. If (FBufferCount=ABufferCount) Then
  3086. exit;
  3087. {$ifdef dsdebug}
  3088. Writeln('Setting buffer list size');
  3089. {$endif}
  3090. SetBufListSize(ABufferCount);
  3091. {$ifdef dsdebug}
  3092. Writeln('Getting next buffers');
  3093. {$endif}
  3094. GetNextRecords;
  3095. if (FRecordCount < FBufferCount) and not IsUniDirectional then
  3096. begin
  3097. FActiveRecord := FActiveRecord + GetPriorRecords;
  3098. CursorPosChanged;
  3099. end;
  3100. {$Ifdef dsDebug}
  3101. WriteLn(
  3102. 'SetBufferCount: FActiveRecord=',FActiveRecord,
  3103. ' FCurrentRecord=',FCurrentRecord,
  3104. ' FBufferCount= ',FBufferCount,
  3105. ' FRecordCount=',FRecordCount);
  3106. {$Endif}
  3107. end;
  3108. procedure TDataSet.SetBookmarkStr(const Value: TBookmarkStr);
  3109. Var
  3110. O: TJSObject;
  3111. B : TBookmark;
  3112. begin
  3113. O:=TJSJSON.parseObject(Value);
  3114. B.Flag:=TBookmarkFlag(O.Properties['flag']);
  3115. B.Data:=O.Properties['Index'];
  3116. GotoBookMark(B)
  3117. end;
  3118. procedure TDataSet.SetBufListSize(Value: Longint);
  3119. Var
  3120. I : Integer;
  3121. begin
  3122. if Value < 0 then Value := 0;
  3123. If Value=FBufferCount Then
  3124. exit;
  3125. // Less buffers, shift buffers.
  3126. if value>BufferCount then
  3127. begin
  3128. For I:=FBufferCount to Value do
  3129. FBuffers[i]:=AllocRecordBuffer;
  3130. end
  3131. else if value<BufferCount then
  3132. if (value>=0) and (FActiveRecord>Value-1) then
  3133. begin
  3134. for i := 0 to (FActiveRecord-Value) do
  3135. ShiftBuffersBackward;
  3136. FActiveRecord := Value -1;
  3137. end;
  3138. SetLength(FBuffers,Value+1); // FBuffers[FBufferCount] is used as a temp buffer
  3139. FBufferCount:=Value;
  3140. if FRecordCount > FBufferCount then
  3141. FRecordCount := FBufferCount;
  3142. end;
  3143. procedure TDataSet.SetChildOrder(Child: TComponent; Order: Longint);
  3144. var
  3145. Field: TField;
  3146. begin
  3147. Field := Child as TField;
  3148. if Fields.IndexOf(Field) >= 0 then
  3149. Field.Index := Order;
  3150. end;
  3151. procedure TDataSet.SetCurrentRecord(Index: Longint);
  3152. begin
  3153. If FCurrentRecord<>Index then
  3154. begin
  3155. {$ifdef DSdebug}
  3156. Writeln ('Setting current record to: ',index);
  3157. {$endif}
  3158. if not FIsUniDirectional then Case GetBookMarkFlag(FBuffers[Index]) of
  3159. bfCurrent : InternalSetToRecord(FBuffers[Index]);
  3160. bfBOF : InternalFirst;
  3161. bfEOF : InternalLast;
  3162. end;
  3163. FCurrentRecord:=Index;
  3164. end;
  3165. end;
  3166. procedure TDataSet.SetDefaultFields(const Value: Boolean);
  3167. begin
  3168. FDefaultFields := Value;
  3169. end;
  3170. procedure TDataSet.CheckBiDirectional;
  3171. begin
  3172. if FIsUniDirectional then DataBaseError(SUniDirectional,Self);
  3173. end;
  3174. procedure TDataSet.SetFilterOptions(Value: TFilterOptions);
  3175. begin
  3176. CheckBiDirectional;
  3177. FFilterOptions := Value;
  3178. end;
  3179. procedure TDataSet.SetFilterText(const Value: string);
  3180. begin
  3181. FFilterText := value;
  3182. end;
  3183. procedure TDataSet.SetFiltered(Value: Boolean);
  3184. begin
  3185. if Value then CheckBiDirectional;
  3186. FFiltered := value;
  3187. end;
  3188. procedure TDataSet.SetFound(const Value: Boolean);
  3189. begin
  3190. FFound := Value;
  3191. end;
  3192. procedure TDataSet.SetModified(Value: Boolean);
  3193. begin
  3194. FModified := value;
  3195. end;
  3196. procedure TDataSet.SetName(const NewName: TComponentName);
  3197. function CheckName(const FieldName: string): string;
  3198. var i,j: integer;
  3199. begin
  3200. Result := FieldName;
  3201. i := 0;
  3202. j := 0;
  3203. while (i < Fields.Count) do begin
  3204. if Result = Fields[i].FieldName then begin
  3205. inc(j);
  3206. Result := FieldName + IntToStr(j);
  3207. end else Inc(i);
  3208. end;
  3209. end;
  3210. var
  3211. i: integer;
  3212. nm: string;
  3213. old: string;
  3214. begin
  3215. if Self.Name = NewName then Exit;
  3216. old := Self.Name;
  3217. inherited SetName(NewName);
  3218. if (csDesigning in ComponentState) then
  3219. for i := 0 to Fields.Count - 1 do begin
  3220. nm := old + Fields[i].FieldName;
  3221. if Copy(Fields[i].Name, 1, Length(nm)) = nm then
  3222. Fields[i].Name := CheckName(NewName + Fields[i].FieldName);
  3223. end;
  3224. end;
  3225. procedure TDataSet.SetOnFilterRecord(const Value: TFilterRecordEvent);
  3226. begin
  3227. CheckBiDirectional;
  3228. FOnFilterRecord := Value;
  3229. end;
  3230. procedure TDataSet.SetRecNo(Value: Longint);
  3231. begin
  3232. //!! To be implemented
  3233. end;
  3234. procedure TDataSet.SetState(Value: TDataSetState);
  3235. begin
  3236. If Value<>FState then
  3237. begin
  3238. FState:=Value;
  3239. if Value=dsBrowse then
  3240. FModified:=false;
  3241. DataEvent(deUpdateState,0);
  3242. end;
  3243. end;
  3244. function TDataSet.TempBuffer: TDataRecord;
  3245. begin
  3246. Result := FBuffers[FRecordCount];
  3247. end;
  3248. procedure TDataSet.UpdateIndexDefs;
  3249. begin
  3250. // Empty Abstract
  3251. end;
  3252. function TDataSet.AllocRecordBuffer: TDataRecord;
  3253. begin
  3254. Result.data:=Null;
  3255. Result.state:=rsNew;
  3256. // Result := nil;
  3257. end;
  3258. procedure TDataSet.FreeRecordBuffer(var Buffer: TDataRecord);
  3259. begin
  3260. // empty stub
  3261. end;
  3262. procedure TDataSet.GetBookmarkData(Buffer: TDataRecord; var Data: TBookmark);
  3263. begin
  3264. end;
  3265. function TDataSet.GetBookmarkFlag(Buffer: TDataRecord): TBookmarkFlag;
  3266. begin
  3267. Result := bfCurrent;
  3268. end;
  3269. function TDataSet.ControlsDisabled: Boolean;
  3270. begin
  3271. Result := (FDisableControlsCount > 0);
  3272. end;
  3273. function TDataSet.ActiveBuffer: TDataRecord;
  3274. begin
  3275. {$ifdef dsdebug}
  3276. Writeln ('Active buffer requested. Returning record number: ',ActiveRecord);
  3277. {$endif}
  3278. Result:=FBuffers[FActiveRecord];
  3279. end;
  3280. function TDataSet.GetFieldData(Field: TField): JSValue;
  3281. begin
  3282. Result:=GetFieldData(Field,ActiveBuffer);
  3283. end;
  3284. procedure TDataSet.SetFieldData(Field: TField; AValue: JSValue);
  3285. begin
  3286. SetFieldData(Field,FBuffers[FActiveRecord],AValue);
  3287. end;
  3288. procedure TDataSet.Append;
  3289. begin
  3290. DoInsertAppend(True);
  3291. end;
  3292. procedure TDataSet.InternalInsert;
  3293. begin
  3294. //!! To be implemented
  3295. end;
  3296. procedure TDataSet.AppendRecord(const Values: array of JSValue);
  3297. begin
  3298. DoInsertAppendRecord(Values,True);
  3299. end;
  3300. function TDataSet.BookmarkValid(ABookmark: TBookmark): Boolean;
  3301. {
  3302. Should be overridden by descendant objects.
  3303. }
  3304. begin
  3305. Result:=False
  3306. end;
  3307. function TDataSet.ConvertToDateTime(aValue: JSValue; ARaiseException: Boolean): TDateTime;
  3308. begin
  3309. Result:=DefaultConvertToDateTime(aValue,ARaiseException);
  3310. end;
  3311. class function TDataSet.DefaultConvertToDateTime(aValue: JSValue; ARaiseException: Boolean): TDateTime;
  3312. begin
  3313. Result:=0;
  3314. if IsString(aValue) then
  3315. begin
  3316. if not TryRFC3339ToDateTime(String(AValue),Result) then
  3317. Raise EConvertError.CreateFmt(SErrInvalidDateTime,[String(aValue)])
  3318. end
  3319. else if IsNumber(aValue) then
  3320. Result:=TDateTime(AValue)
  3321. end;
  3322. function TDataSet.ConvertDateTimeToNative(aValue : TDateTime) : JSValue;
  3323. begin
  3324. Result:=DefaultConvertDateTimeToNative(aValue);
  3325. end;
  3326. Class function TDataSet.DefaultConvertDateTimeToNative(aValue : TDateTime) : JSValue;
  3327. begin
  3328. Result:=DateTimeToRFC3339(aValue);
  3329. end;
  3330. function TDataSet.BlobDataToBytes(aValue: JSValue): TBytes;
  3331. begin
  3332. Result:=DefaultBlobDataToBytes(aValue);
  3333. end;
  3334. class function TDataSet.DefaultBlobDataToBytes(aValue: JSValue): TBytes;
  3335. Var
  3336. S : String;
  3337. I,J,L : Integer;
  3338. begin
  3339. SetLength(Result,0);
  3340. // We assume a string, hex-encoded.
  3341. if isString(AValue) then
  3342. begin
  3343. S:=String(Avalue);
  3344. L:=Length(S);
  3345. SetLength(Result,(L+1) div 2);
  3346. I:=1;
  3347. J:=0;
  3348. While (I<L) do
  3349. begin
  3350. Result[J]:=StrToInt('$'+Copy(S,I,2));
  3351. Inc(I,2);
  3352. Inc(J,1);
  3353. end;
  3354. end;
  3355. end;
  3356. Function TDataSet.BytesToBlobData(aValue : TBytes) : JSValue ;
  3357. begin
  3358. Result:=DefaultBytesToBlobData(aValue);
  3359. end;
  3360. Class Function TDataSet.DefaultBytesToBlobData(aValue : TBytes) : JSValue;
  3361. Var
  3362. S : String;
  3363. I : Integer;
  3364. begin
  3365. if Length(AValue)=0 then
  3366. Result:=Null
  3367. else
  3368. begin
  3369. S:='';
  3370. For I:=0 to Length(AValue) do
  3371. TJSString(S).Concat(IntToHex(aValue[i],2));
  3372. end;
  3373. end;
  3374. procedure TDataSet.Cancel;
  3375. begin
  3376. If State in [dsEdit,dsInsert] then
  3377. begin
  3378. DataEvent(deCheckBrowseMode,0);
  3379. DoBeforeCancel;
  3380. UpdateCursorPos;
  3381. InternalCancel;
  3382. if (State = dsInsert) and (FRecordCount = 1) then
  3383. begin
  3384. FEOF := true;
  3385. FBOF := true;
  3386. FRecordCount := 0;
  3387. InitRecord(FBuffers[FActiveRecord]);
  3388. SetState(dsBrowse);
  3389. DataEvent(deDatasetChange,0);
  3390. end
  3391. else
  3392. begin
  3393. SetState(dsBrowse);
  3394. SetCurrentRecord(FActiveRecord);
  3395. resync([]);
  3396. end;
  3397. DoAfterCancel;
  3398. end;
  3399. end;
  3400. procedure TDataSet.CheckBrowseMode;
  3401. begin
  3402. CheckActive;
  3403. DataEvent(deCheckBrowseMode,0);
  3404. Case State of
  3405. dsEdit,dsInsert:
  3406. begin
  3407. UpdateRecord;
  3408. If Modified then
  3409. Post
  3410. else
  3411. Cancel;
  3412. end;
  3413. dsSetKey: Post;
  3414. end;
  3415. end;
  3416. procedure TDataSet.ClearFields;
  3417. begin
  3418. DataEvent(deCheckBrowseMode, 0);
  3419. InternalInitRecord(FBuffers[FActiveRecord]);
  3420. if State <> dsSetKey then
  3421. GetCalcFields(FBuffers[FActiveRecord]);
  3422. DataEvent(deRecordChange, 0);
  3423. end;
  3424. procedure TDataSet.Close;
  3425. begin
  3426. Active:=False;
  3427. end;
  3428. procedure TDataSet.ApplyUpdates;
  3429. begin
  3430. DoBeforeApplyUpdates;
  3431. DoApplyUpdates;
  3432. end;
  3433. function TDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
  3434. begin
  3435. Result:=0;
  3436. end;
  3437. procedure TDataSet.CursorPosChanged;
  3438. begin
  3439. FCurrentRecord:=-1;
  3440. end;
  3441. procedure TDataSet.Delete;
  3442. Var
  3443. R : TRecordUpdateDescriptor;
  3444. begin
  3445. If Not CanModify then
  3446. DatabaseError(SDatasetReadOnly,Self);
  3447. If IsEmpty then
  3448. DatabaseError(SDatasetEmpty,Self);
  3449. if State in [dsInsert] then
  3450. begin
  3451. Cancel;
  3452. end else begin
  3453. DataEvent(deCheckBrowseMode,0);
  3454. {$ifdef dsdebug}
  3455. writeln ('Delete: checking required fields');
  3456. {$endif}
  3457. DoBeforeDelete;
  3458. DoBeforeScroll;
  3459. R:=AddToChangeList(usDeleted);
  3460. If Not TryDoing(@InternalDelete,OnDeleteError) then
  3461. begin
  3462. if Assigned(R) then
  3463. RemoveFromChangeList(R);
  3464. exit;
  3465. end;
  3466. {$ifdef dsdebug}
  3467. writeln ('Delete: Internaldelete succeeded');
  3468. {$endif}
  3469. SetState(dsBrowse);
  3470. {$ifdef dsdebug}
  3471. writeln ('Delete: Browse mode set');
  3472. {$endif}
  3473. SetCurrentRecord(FActiveRecord);
  3474. Resync([]);
  3475. DoAfterDelete;
  3476. DoAfterScroll;
  3477. end;
  3478. end;
  3479. procedure TDataSet.DisableControls;
  3480. begin
  3481. If FDisableControlsCount=0 then
  3482. begin
  3483. { Save current state,
  3484. needed to detect change of state when enabling controls.
  3485. }
  3486. FDisableControlsState:=FState;
  3487. FEnableControlsEvent:=deDatasetChange;
  3488. end;
  3489. Inc(FDisableControlsCount);
  3490. end;
  3491. procedure TDataSet.DoInsertAppend(DoAppend: Boolean);
  3492. procedure DoInsert(DoAppend : Boolean);
  3493. Var
  3494. BookBeforeInsert : TBookmark;
  3495. TempBuf : TDataRecord;
  3496. I : integer;
  3497. begin
  3498. // need to scroll up al buffers after current one,
  3499. // but copy current bookmark to insert buffer.
  3500. If FRecordCount > 0 then
  3501. BookBeforeInsert:=Bookmark;
  3502. if not DoAppend then
  3503. begin
  3504. if FRecordCount > 0 then
  3505. begin
  3506. TempBuf := FBuffers[FBufferCount];
  3507. for I:=FBufferCount downto FActiveRecord+1 do
  3508. FBuffers[I]:=FBuffers[I-1];
  3509. FBuffers[FActiveRecord]:=TempBuf;
  3510. end;
  3511. end
  3512. else if FRecordCount=FBufferCount then
  3513. ShiftBuffersBackward
  3514. else
  3515. begin
  3516. if FRecordCount>0 then
  3517. inc(FActiveRecord);
  3518. end;
  3519. // Active buffer is now edit buffer. Initialize.
  3520. InitRecord(FBuffers[FActiveRecord]);
  3521. CursorPosChanged;
  3522. // Put bookmark in edit buffer.
  3523. if FRecordCount=0 then
  3524. SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF)
  3525. else
  3526. begin
  3527. fBOF := false;
  3528. // 29:01:05, JvdS: Why is this here?!? It can result in records with the same bookmark-data?
  3529. // I would say that the 'internalinsert' should do this. But I don't know how Tdbf handles it
  3530. // 1-apr-06, JvdS: It just sets the bookmark of the newly inserted record to the place
  3531. // where the record should be inserted. So it is ok.
  3532. if FRecordCount > 0 then
  3533. begin
  3534. SetBookMarkData(FBuffers[FActiveRecord],BookBeforeInsert);
  3535. FreeBookmark(BookBeforeInsert);
  3536. end;
  3537. end;
  3538. InternalInsert;
  3539. // update buffer count.
  3540. If FRecordCount<FBufferCount then
  3541. Inc(FRecordCount);
  3542. end;
  3543. begin
  3544. CheckBrowseMode;
  3545. If Not CanModify then
  3546. DatabaseError(SDatasetReadOnly,Self);
  3547. DoBeforeInsert;
  3548. DoBeforeScroll;
  3549. If Not DoAppend then
  3550. begin
  3551. {$ifdef dsdebug}
  3552. Writeln ('going to insert mode');
  3553. {$endif}
  3554. DoInsert(false);
  3555. end
  3556. else
  3557. begin
  3558. {$ifdef dsdebug}
  3559. Writeln ('going to append mode');
  3560. {$endif}
  3561. ClearBuffers;
  3562. InternalLast;
  3563. GetPriorRecords;
  3564. if FRecordCount>0 then
  3565. FActiveRecord:=FRecordCount-1;
  3566. DoInsert(True);
  3567. SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF);
  3568. FBOF :=False;
  3569. FEOF := true;
  3570. end;
  3571. SetState(dsInsert);
  3572. try
  3573. DoOnNewRecord;
  3574. except
  3575. SetCurrentRecord(FActiveRecord);
  3576. resync([]);
  3577. raise;
  3578. end;
  3579. // mark as not modified.
  3580. FModified:=False;
  3581. // Final events.
  3582. DataEvent(deDatasetChange,0);
  3583. DoAfterInsert;
  3584. DoAfterScroll;
  3585. {$ifdef dsdebug}
  3586. Writeln ('Done with append');
  3587. {$endif}
  3588. end;
  3589. procedure TDataSet.Edit;
  3590. begin
  3591. If State in [dsEdit,dsInsert] then exit;
  3592. CheckBrowseMode;
  3593. If Not CanModify then
  3594. DatabaseError(SDatasetReadOnly,Self);
  3595. If FRecordCount = 0 then
  3596. begin
  3597. Append;
  3598. Exit;
  3599. end;
  3600. DoBeforeEdit;
  3601. If Not TryDoing(@InternalEdit,OnEditError) then exit;
  3602. GetCalcFields(FBuffers[FActiveRecord]);
  3603. SetState(dsEdit);
  3604. DataEvent(deRecordChange,0);
  3605. DoAfterEdit;
  3606. end;
  3607. procedure TDataSet.EnableControls;
  3608. begin
  3609. if FDisableControlsCount > 0 then
  3610. Dec(FDisableControlsCount);
  3611. if FDisableControlsCount = 0 then begin
  3612. if FState <> FDisableControlsState then
  3613. DataEvent(deUpdateState, 0);
  3614. if (FState <> dsInactive) and (FDisableControlsState <> dsInactive) then
  3615. DataEvent(FEnableControlsEvent, 0);
  3616. end;
  3617. end;
  3618. function TDataSet.FieldByName(const FieldName: string): TField;
  3619. begin
  3620. Result:=FindField(FieldName);
  3621. If Result=Nil then
  3622. DatabaseErrorFmt(SFieldNotFound,[FieldName],Self);
  3623. end;
  3624. function TDataSet.FindField(const FieldName: string): TField;
  3625. begin
  3626. Result:=FFieldList.FindField(FieldName);
  3627. end;
  3628. function TDataSet.FindFirst: Boolean;
  3629. begin
  3630. Result:=False;
  3631. end;
  3632. function TDataSet.FindLast: Boolean;
  3633. begin
  3634. Result:=False;
  3635. end;
  3636. function TDataSet.FindNext: Boolean;
  3637. begin
  3638. Result:=False;
  3639. end;
  3640. function TDataSet.FindPrior: Boolean;
  3641. begin
  3642. Result:=False;
  3643. end;
  3644. procedure TDataSet.First;
  3645. begin
  3646. CheckBrowseMode;
  3647. DoBeforeScroll;
  3648. if not FIsUniDirectional then
  3649. ClearBuffers
  3650. else if not FBof then
  3651. begin
  3652. Active := False;
  3653. Active := True;
  3654. end;
  3655. try
  3656. InternalFirst;
  3657. if not FIsUniDirectional then GetNextRecords;
  3658. finally
  3659. FBOF:=True;
  3660. DataEvent(deDatasetChange,0);
  3661. DoAfterScroll;
  3662. end;
  3663. end;
  3664. procedure TDataSet.FreeBookmark(ABookmark: TBookmark);
  3665. begin
  3666. {$ifdef noautomatedbookmark}
  3667. FreeMem(ABookMark,FBookMarkSize);
  3668. {$endif}
  3669. end;
  3670. function TDataSet.GetBookmark: TBookmark;
  3671. begin
  3672. if BookmarkAvailable then
  3673. GetBookMarkdata(ActiveBuffer,Result)
  3674. else
  3675. Result.Data:=Null;
  3676. end;
  3677. function TDataSet.GetCurrentRecord(Buffer: TDataRecord): Boolean;
  3678. begin
  3679. Result:=False;
  3680. end;
  3681. procedure TDataSet.GetFieldList(List: TList; const FieldNames: string);
  3682. var
  3683. F: TField;
  3684. N: String;
  3685. StrPos: Integer;
  3686. begin
  3687. if (FieldNames = '') or (List = nil) then
  3688. Exit;
  3689. StrPos := 1;
  3690. repeat
  3691. N := ExtractFieldName(FieldNames, StrPos);
  3692. F := FieldByName(N);
  3693. List.Add(F);
  3694. until StrPos > Length(FieldNames);
  3695. end;
  3696. procedure TDataSet.GetFieldNames(List: TStrings);
  3697. begin
  3698. FFieldList.GetFieldNames(List);
  3699. end;
  3700. procedure TDataSet.GotoBookmark(const ABookmark: TBookmark);
  3701. begin
  3702. If Assigned(ABookMark) then
  3703. begin
  3704. CheckBrowseMode;
  3705. DoBeforeScroll;
  3706. {$ifdef dsdebug}
  3707. Writeln('Gotobookmark: ',ABookMark.Data);
  3708. {$endif}
  3709. InternalGotoBookMark(ABookMark);
  3710. Resync([rmExact,rmCenter]);
  3711. DoAfterScroll;
  3712. end;
  3713. end;
  3714. procedure TDataSet.Insert;
  3715. begin
  3716. DoInsertAppend(False);
  3717. end;
  3718. procedure TDataSet.InsertRecord(const Values: array of JSValue);
  3719. begin
  3720. DoInsertAppendRecord(Values,False);
  3721. end;
  3722. function TDataSet.IsEmpty: Boolean;
  3723. begin
  3724. Result:=(fBof and fEof) and
  3725. (not (State = dsInsert)); // After an insert on an empty dataset, both fBof and fEof are true
  3726. end;
  3727. function TDataSet.IsLinkedTo(ADataSource: TDataSource): Boolean;
  3728. begin
  3729. //!! Not tested, I never used nested DS
  3730. if (ADataSource = nil) or (ADataSource.Dataset = nil) then begin
  3731. Result := False
  3732. end else if ADataSource.Dataset = Self then begin
  3733. Result := True;
  3734. end else begin
  3735. Result := ADataSource.Dataset.IsLinkedTo(ADataSource.Dataset.DataSource);
  3736. end;
  3737. //!! DataSetField not implemented
  3738. end;
  3739. function TDataSet.IsSequenced: Boolean;
  3740. begin
  3741. Result := True;
  3742. end;
  3743. procedure TDataSet.Last;
  3744. begin
  3745. CheckBiDirectional;
  3746. CheckBrowseMode;
  3747. DoBeforeScroll;
  3748. ClearBuffers;
  3749. try
  3750. // Writeln('FActiveRecord before last',FActiveRecord);
  3751. InternalLast;
  3752. // Writeln('FActiveRecord after last',FActiveRecord);
  3753. GetPriorRecords;
  3754. // Writeln('FRecordCount: ',FRecordCount);
  3755. if FRecordCount>0 then
  3756. FActiveRecord:=FRecordCount-1;
  3757. // Writeln('FActiveRecord ',FActiveRecord);
  3758. finally
  3759. FEOF:=true;
  3760. DataEvent(deDataSetChange, 0);
  3761. DoAfterScroll;
  3762. end;
  3763. end;
  3764. function TDataSet.DoLoad(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean;
  3765. Var
  3766. Request : TDataRequest;
  3767. begin
  3768. if not (loNoEvents in aOptions) then
  3769. DoBeforeLoad;
  3770. Result:=DataProxy<>Nil;
  3771. if Not Result then
  3772. Exit;
  3773. Request:=DataProxy.GetDataRequest(aOptions,@HandleRequestResponse,aAfterLoad);
  3774. Request.FDataset:=Self;
  3775. If Active then
  3776. Request.FBookmark:=GetBookmark;
  3777. Inc(FDataRequestID);
  3778. Request.FRequestID:=FDataRequestID;
  3779. DataProxy.DoGetData(Request);
  3780. end;
  3781. function TDataSet.Load(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean;
  3782. begin
  3783. if loAtEOF in aOptions then
  3784. DatabaseError(SatEOFInternalOnly,Self);
  3785. Result:=DoLoad(aOptions,aAfterLoad);
  3786. end;
  3787. function TDataSet.MoveBy(Distance: Longint): Longint;
  3788. Var
  3789. TheResult: Integer;
  3790. Function ScrollForward : Integer;
  3791. begin
  3792. Result:=0;
  3793. {$ifdef dsdebug}
  3794. Writeln('Scrolling forward : ',Distance);
  3795. Writeln('Active buffer : ',FActiveRecord);
  3796. Writeln('RecordCount : ',FRecordCount);
  3797. WriteLn('BufferCount : ',FBufferCount);
  3798. {$endif}
  3799. FBOF:=False;
  3800. While (Distance>0) and not FEOF do
  3801. begin
  3802. If FActiveRecord<FRecordCount-1 then
  3803. begin
  3804. Inc(FActiveRecord);
  3805. Dec(Distance);
  3806. Inc(TheResult); //Inc(Result);
  3807. end
  3808. else
  3809. begin
  3810. {$ifdef dsdebug}
  3811. Writeln('Moveby : need next record');
  3812. {$endif}
  3813. If GetNextRecord then
  3814. begin
  3815. Dec(Distance);
  3816. Dec(Result);
  3817. Inc(TheResult); //Inc(Result);
  3818. end
  3819. else
  3820. begin
  3821. FEOF:=true;
  3822. // Allow to load more records.
  3823. DoLoad([loNoOpen,loAtEOF],Nil);
  3824. end;
  3825. end;
  3826. end
  3827. end;
  3828. Function ScrollBackward : Integer;
  3829. begin
  3830. CheckBiDirectional;
  3831. Result:=0;
  3832. {$ifdef dsdebug}
  3833. Writeln('Scrolling backward : ',Abs(Distance));
  3834. Writeln('Active buffer : ',FActiveRecord);
  3835. Writeln('RecordCunt : ',FRecordCount);
  3836. WriteLn('BufferCount : ',FBufferCount);
  3837. {$endif}
  3838. FEOF:=False;
  3839. While (Distance<0) and not FBOF do
  3840. begin
  3841. If FActiveRecord>0 then
  3842. begin
  3843. Dec(FActiveRecord);
  3844. Inc(Distance);
  3845. Dec(TheResult); //Dec(Result);
  3846. end
  3847. else
  3848. begin
  3849. {$ifdef dsdebug}
  3850. Writeln('Moveby : need next record');
  3851. {$endif}
  3852. If GetPriorRecord then
  3853. begin
  3854. Inc(Distance);
  3855. Inc(Result);
  3856. Dec(TheResult); //Dec(Result);
  3857. end
  3858. else
  3859. FBOF:=true;
  3860. end;
  3861. end
  3862. end;
  3863. Var
  3864. Scrolled : Integer;
  3865. begin
  3866. CheckBrowseMode;
  3867. Result:=0; TheResult:=0;
  3868. DoBeforeScroll;
  3869. If (Distance = 0) or
  3870. ((Distance>0) and FEOF) or
  3871. ((Distance<0) and FBOF) then
  3872. exit;
  3873. Try
  3874. Scrolled := 0;
  3875. If Distance>0 then
  3876. Scrolled:=ScrollForward
  3877. else
  3878. Scrolled:=ScrollBackward;
  3879. finally
  3880. {$ifdef dsdebug}
  3881. WriteLn('ActiveRecord=', FActiveRecord,' FEOF=',FEOF,' FBOF=',FBOF);
  3882. {$Endif}
  3883. DataEvent(deDatasetScroll,Scrolled);
  3884. DoAfterScroll;
  3885. Result:=TheResult;
  3886. end;
  3887. end;
  3888. procedure TDataSet.Next;
  3889. begin
  3890. if BlockReadSize>0 then
  3891. BlockReadNext
  3892. else
  3893. MoveBy(1);
  3894. end;
  3895. procedure TDataSet.BlockReadNext;
  3896. begin
  3897. MoveBy(1);
  3898. end;
  3899. procedure TDataSet.Open;
  3900. begin
  3901. Active:=True;
  3902. end;
  3903. procedure TDataSet.Post;
  3904. Const
  3905. UpdateStates : Array[Boolean] of TUpdateStatus = (usModified,usInserted);
  3906. Var
  3907. R : TRecordUpdateDescriptor;
  3908. WasInsert : Boolean;
  3909. begin
  3910. UpdateRecord;
  3911. if State in [dsEdit,dsInsert] then
  3912. begin
  3913. DataEvent(deCheckBrowseMode,0);
  3914. {$ifdef dsdebug}
  3915. writeln ('Post: checking required fields');
  3916. {$endif}
  3917. DoBeforePost;
  3918. WasInsert:=State=dsInsert;
  3919. If Not TryDoing(@InternalPost,OnPostError) then exit;
  3920. CursorPosChanged;
  3921. {$ifdef dsdebug}
  3922. writeln ('Post: Internalpost succeeded');
  3923. {$endif}
  3924. // First set the state to dsBrowse, then the Resync, to prevent the calling of
  3925. // the deDatasetChange event, while the state is still 'editable', while the db isn't
  3926. SetState(dsBrowse);
  3927. Resync([]);
  3928. // We get the new values here, since the bookmark should now be correct to find the record later on when doing applyupdates.
  3929. R:=AddToChangeList(UpdateStates[wasInsert]);
  3930. if Assigned(R) then
  3931. R.FBookmark:=BookMark;
  3932. {$ifdef dsdebug}
  3933. writeln ('Post: Browse mode set');
  3934. {$endif}
  3935. DoAfterPost;
  3936. end
  3937. else if State<>dsSetKey then
  3938. DatabaseErrorFmt(SNotEditing, [Name], Self);
  3939. end;
  3940. procedure TDataSet.Prior;
  3941. begin
  3942. MoveBy(-1);
  3943. end;
  3944. procedure TDataSet.Refresh;
  3945. begin
  3946. CheckbrowseMode;
  3947. DoBeforeRefresh;
  3948. UpdateCursorPos;
  3949. InternalRefresh;
  3950. { SetCurrentRecord is called by UpdateCursorPos already, so as long as
  3951. InternalRefresh doesn't do strange things this should be ok. }
  3952. // SetCurrentRecord(FActiveRecord);
  3953. Resync([]);
  3954. DoAfterRefresh;
  3955. end;
  3956. procedure TDataSet.RegisterDataSource(ADataSource: TDataSource);
  3957. begin
  3958. FDataSources.Add(ADataSource);
  3959. RecalcBufListSize;
  3960. end;
  3961. procedure TDataSet.Resync(Mode: TResyncMode);
  3962. var i,count : integer;
  3963. begin
  3964. // See if we can find the requested record.
  3965. {$ifdef dsdebug}
  3966. Writeln ('Resync called');
  3967. {$endif}
  3968. if FIsUnidirectional then Exit;
  3969. // place the cursor of the underlying dataset to the active record
  3970. // SetCurrentRecord(FActiveRecord);
  3971. // Now look if the data on the current cursor of the underlying dataset is still available
  3972. If GetRecord(FBuffers[0],gmCurrent,False)<>grOk Then
  3973. // If that fails and rmExact is set, then raise an exception
  3974. If rmExact in Mode then
  3975. DatabaseError(SNoSuchRecord,Self)
  3976. // else, if rmexact is not set, try to fetch the next or prior record in the underlying dataset
  3977. else if (GetRecord(FBuffers[0],gmNext,True)<>grOk) and
  3978. (GetRecord(FBuffers[0],gmPrior,True)<>grOk) then
  3979. begin
  3980. {$ifdef dsdebug}
  3981. Writeln ('Resync: fuzzy resync');
  3982. {$endif}
  3983. // nothing found, invalidate buffer and bail out.
  3984. ClearBuffers;
  3985. // Make sure that the active record is 'empty', ie: that all fields are null
  3986. InternalInitRecord(FBuffers[FActiveRecord]);
  3987. DataEvent(deDatasetChange,0);
  3988. exit;
  3989. end;
  3990. FCurrentRecord := 0;
  3991. FEOF := false;
  3992. FBOF := false;
  3993. // If we've arrived here, FBuffer[0] is the current record
  3994. If (rmCenter in Mode) then
  3995. count := (FRecordCount div 2)
  3996. else
  3997. count := FActiveRecord;
  3998. i := 0;
  3999. FRecordCount := 1;
  4000. FActiveRecord := 0;
  4001. // Fill the buffers before the active record
  4002. while (i < count) and GetPriorRecord do
  4003. inc(i);
  4004. FActiveRecord := i;
  4005. // Fill the rest of the buffer
  4006. GetNextRecords;
  4007. // If the buffer is not full yet, try to fetch some more prior records
  4008. if FRecordCount < FBufferCount then FActiveRecord:=FActiveRecord+getpriorrecords;
  4009. // That's all folks!
  4010. DataEvent(deDatasetChange,0);
  4011. end;
  4012. procedure TDataSet.SetFields(const Values: array of JSValue);
  4013. Var I : longint;
  4014. begin
  4015. For I:=0 to high(Values) do
  4016. Fields[I].AssignValue(Values[I]);
  4017. end;
  4018. function TDataSet.TryDoing(P: TDataOperation; Ev: TDatasetErrorEvent): Boolean;
  4019. Var Retry : TDataAction;
  4020. begin
  4021. {$ifdef dsdebug}
  4022. Writeln ('Trying to do');
  4023. If P=Nil then writeln ('Procedure to call is nil !!!');
  4024. {$endif dsdebug}
  4025. Result:=True;
  4026. Retry:=daRetry;
  4027. while Retry=daRetry do
  4028. Try
  4029. {$ifdef dsdebug}
  4030. Writeln ('Trying : updatecursorpos');
  4031. {$endif dsdebug}
  4032. UpdateCursorPos;
  4033. {$ifdef dsdebug}
  4034. Writeln ('Trying to do it');
  4035. {$endif dsdebug}
  4036. P();
  4037. exit;
  4038. except
  4039. On E : EDatabaseError do
  4040. begin
  4041. retry:=daFail;
  4042. If Assigned(Ev) then
  4043. Ev(Self,E,Retry);
  4044. Case Retry of
  4045. daFail : Raise;
  4046. daAbort : Abort;
  4047. end;
  4048. end;
  4049. else
  4050. Raise;
  4051. end;
  4052. {$ifdef dsdebug}
  4053. Writeln ('Exit Trying to do');
  4054. {$endif dsdebug}
  4055. end;
  4056. procedure TDataSet.UpdateCursorPos;
  4057. begin
  4058. If FRecordCount>0 then
  4059. SetCurrentRecord(FActiveRecord);
  4060. end;
  4061. procedure TDataSet.UpdateRecord;
  4062. begin
  4063. if not (State in dsEditModes) then
  4064. DatabaseErrorFmt(SNotEditing, [Name], Self);
  4065. DataEvent(deUpdateRecord, 0);
  4066. end;
  4067. function TDataSet.GetPendingUpdates: TResolveInfoArray;
  4068. Var
  4069. L : TRecordUpdateDescriptorList;
  4070. I : integer;
  4071. begin
  4072. L:=TRecordUpdateDescriptorList.Create;
  4073. try
  4074. SetLength(Result,GetRecordUpdates(L));
  4075. For I:=0 to L.Count-1 do
  4076. Result[i]:=RecordUpdateDescriptorToResolveInfo(L[i]);
  4077. finally
  4078. L.Free;
  4079. end;
  4080. end;
  4081. function TDataSet.UpdateStatus: TUpdateStatus;
  4082. begin
  4083. Result:=usUnmodified;
  4084. end;
  4085. procedure TDataSet.SetConstraints(Value: TCheckConstraints);
  4086. begin
  4087. FConstraints.Assign(Value);
  4088. end;
  4089. procedure TDataSet.SetDataProxy(AValue: TDataProxy);
  4090. begin
  4091. If AValue=FDataProxy then
  4092. exit;
  4093. if Assigned(FDataProxy) then
  4094. FDataProxy.RemoveFreeNotification(Self);
  4095. FDataProxy:=AValue;
  4096. if Assigned(FDataProxy) then
  4097. FDataProxy.FreeNotification(Self)
  4098. end;
  4099. function TDataSet.GetfieldCount: Integer;
  4100. begin
  4101. Result:=FFieldList.Count;
  4102. end;
  4103. procedure TDataSet.ShiftBuffersBackward;
  4104. var
  4105. TempBuf : TDataRecord;
  4106. I : Integer;
  4107. begin
  4108. TempBuf := FBuffers[0];
  4109. For I:=1 to FBufferCount do
  4110. FBuffers[I-1]:=FBuffers[i];
  4111. FBuffers[BufferCount]:=TempBuf;
  4112. end;
  4113. procedure TDataSet.ShiftBuffersForward;
  4114. var
  4115. TempBuf : TDataRecord;
  4116. I : Integer;
  4117. begin
  4118. TempBuf := FBuffers[FBufferCount];
  4119. For I:=FBufferCount downto 1 do
  4120. FBuffers[I]:=FBuffers[i-1];
  4121. FBuffers[0]:=TempBuf;
  4122. end;
  4123. function TDataSet.GetFieldValues(const FieldName: string): JSValue;
  4124. var
  4125. i: Integer;
  4126. FieldList: TList;
  4127. A : TJSValueDynArray;
  4128. begin
  4129. FieldList := TList.Create;
  4130. try
  4131. GetFieldList(FieldList, FieldName);
  4132. if FieldList.Count>1 then
  4133. begin
  4134. SetLength(A,FieldList.Count);
  4135. for i := 0 to FieldList.Count - 1 do
  4136. A[i] := TField(FieldList[i]).Value;
  4137. Result:=A;
  4138. end
  4139. else
  4140. Result := FieldByName(FieldName).Value;
  4141. finally
  4142. FieldList.Free;
  4143. end;
  4144. end;
  4145. procedure TDataSet.SetFieldValues(const FieldName: string; Value: JSValue);
  4146. var
  4147. i : Integer;
  4148. FieldList: TList;
  4149. A : TJSValueDynArray;
  4150. begin
  4151. if IsArray(Value) then
  4152. begin
  4153. FieldList := TList.Create;
  4154. try
  4155. GetFieldList(FieldList, FieldName);
  4156. A:=TJSValueDynArray(Value);
  4157. if (FieldList.Count = 1) and (Length(A)>0) then
  4158. // Allow for a field type that can deal with an array
  4159. FieldByName(FieldName).Value := Value
  4160. else
  4161. for i := 0 to FieldList.Count - 1 do
  4162. TField(FieldList[i]).Value := A[i];
  4163. finally
  4164. FieldList.Free;
  4165. end;
  4166. end
  4167. else
  4168. FieldByName(FieldName).Value := Value;
  4169. end;
  4170. function TDataSet.Locate(const KeyFields: string; const KeyValues: JSValue;
  4171. Options: TLocateOptions): boolean;
  4172. begin
  4173. CheckBiDirectional;
  4174. Result := False;
  4175. end;
  4176. function TDataSet.Lookup(const KeyFields: string; const KeyValues: JSValue;
  4177. const ResultFields: string): JSValue;
  4178. begin
  4179. CheckBiDirectional;
  4180. Result := Null;
  4181. end;
  4182. procedure TDataSet.UnRegisterDataSource(ADataSource: TDataSource);
  4183. begin
  4184. FDataSources.Remove(ADataSource);
  4185. end;
  4186. { ---------------------------------------------------------------------
  4187. TFieldDef
  4188. ---------------------------------------------------------------------}
  4189. constructor TFieldDef.Create(ACollection: TCollection);
  4190. begin
  4191. Inherited Create(ACollection);
  4192. FFieldNo:=Index+1;
  4193. end;
  4194. constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType; ASize: Integer; ARequired: Boolean;
  4195. AFieldNo: Longint);
  4196. begin
  4197. {$ifdef dsdebug }
  4198. Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
  4199. {$endif}
  4200. Inherited Create(AOwner);
  4201. Name:=Aname;
  4202. FDatatype:=ADatatype;
  4203. FSize:=ASize;
  4204. FRequired:=ARequired;
  4205. FPrecision:=-1;
  4206. FFieldNo:=AFieldNo;
  4207. end;
  4208. destructor TFieldDef.Destroy;
  4209. begin
  4210. Inherited destroy;
  4211. end;
  4212. procedure TFieldDef.Assign(Source: TPersistent);
  4213. var fd: TFieldDef;
  4214. begin
  4215. fd := nil;
  4216. if Source is TFieldDef then
  4217. fd := Source as TFieldDef;
  4218. if Assigned(fd) then begin
  4219. Collection.BeginUpdate;
  4220. try
  4221. Name := fd.Name;
  4222. DataType := fd.DataType;
  4223. Size := fd.Size;
  4224. Precision := fd.Precision;
  4225. FRequired := fd.Required;
  4226. finally
  4227. Collection.EndUpdate;
  4228. end;
  4229. end
  4230. else
  4231. inherited Assign(Source);
  4232. end;
  4233. function TFieldDef.CreateField(AOwner: TComponent): TField;
  4234. var TheField : TFieldClass;
  4235. begin
  4236. {$ifdef dsdebug}
  4237. Writeln ('Creating field '+FNAME);
  4238. {$endif dsdebug}
  4239. TheField:=GetFieldClass;
  4240. if TheField=Nil then
  4241. DatabaseErrorFmt(SUnknownFieldType,[FName]);
  4242. Result:=TheField.Create(AOwner);
  4243. Try
  4244. Result.FFieldDef:=Self;
  4245. Result.Size:=FSize;
  4246. Result.Required:=FRequired;
  4247. Result.FFieldName:=FName;
  4248. Result.FDisplayLabel:=DisplayName;
  4249. Result.FFieldNo:=Self.FieldNo;
  4250. Result.SetFieldType(DataType);
  4251. Result.FReadOnly:=(faReadOnly in Attributes);
  4252. {$ifdef dsdebug}
  4253. Writeln ('TFieldDef.CreateField : Result Fieldno : ',Result.FieldNo,'; Self : ',FieldNo);
  4254. Writeln ('TFieldDef.CreateField : Trying to set dataset');
  4255. {$endif dsdebug}
  4256. Result.Dataset:=TFieldDefs(Collection).Dataset;
  4257. if (Result is TFloatField) then
  4258. TFloatField(Result).Precision := FPrecision;
  4259. except
  4260. Result.Free;
  4261. Raise;
  4262. end;
  4263. end;
  4264. procedure TFieldDef.SetAttributes(AValue: TFieldAttributes);
  4265. begin
  4266. FAttributes := AValue;
  4267. Changed(False);
  4268. end;
  4269. procedure TFieldDef.SetDataType(AValue: TFieldType);
  4270. begin
  4271. FDataType := AValue;
  4272. Changed(False);
  4273. end;
  4274. procedure TFieldDef.SetPrecision(const AValue: Longint);
  4275. begin
  4276. FPrecision := AValue;
  4277. Changed(False);
  4278. end;
  4279. procedure TFieldDef.SetSize(const AValue: Integer);
  4280. begin
  4281. FSize := AValue;
  4282. Changed(False);
  4283. end;
  4284. procedure TFieldDef.SetRequired(const AValue: Boolean);
  4285. begin
  4286. FRequired := AValue;
  4287. Changed(False);
  4288. end;
  4289. function TFieldDef.GetFieldClass: TFieldClass;
  4290. begin
  4291. //!! Should be owner as tdataset but that doesn't work ??
  4292. If Assigned(Collection) And
  4293. (Collection is TFieldDefs) And
  4294. Assigned(TFieldDefs(Collection).Dataset) then
  4295. Result:=TFieldDefs(Collection).Dataset.GetFieldClass(FDataType)
  4296. else
  4297. Result:=Nil;
  4298. end;
  4299. { ---------------------------------------------------------------------
  4300. TFieldDefs
  4301. ---------------------------------------------------------------------}
  4302. {
  4303. destructor TFieldDefs.Destroy;
  4304. begin
  4305. FItems.Free;
  4306. // This will destroy all fielddefs since we own them...
  4307. Inherited Destroy;
  4308. end;
  4309. }
  4310. procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType);
  4311. begin
  4312. Add(AName,ADatatype,0,False);
  4313. end;
  4314. procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize : Word);
  4315. begin
  4316. Add(AName,ADatatype,ASize,False);
  4317. end;
  4318. procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word;
  4319. ARequired: Boolean);
  4320. begin
  4321. If Length(AName)=0 Then
  4322. DatabaseError(SNeedFieldName,Dataset);
  4323. // the fielddef will register itself here as an owned component.
  4324. // fieldno is 1 based !
  4325. BeginUpdate;
  4326. try
  4327. Add(AName,ADataType,ASize,ARequired,Count+1);
  4328. finally
  4329. EndUpdate;
  4330. end;
  4331. end;
  4332. function TFieldDefs.GetItem(Index: Longint): TFieldDef;
  4333. begin
  4334. Result := TFieldDef(inherited Items[Index]);
  4335. end;
  4336. procedure TFieldDefs.SetItem(Index: Longint; const AValue: TFieldDef);
  4337. begin
  4338. inherited Items[Index] := AValue;
  4339. end;
  4340. class function TFieldDefs.FieldDefClass: TFieldDefClass;
  4341. begin
  4342. Result:=TFieldDef;
  4343. end;
  4344. constructor TFieldDefs.Create(ADataSet: TDataSet);
  4345. begin
  4346. Inherited Create(ADataset, Owner, FieldDefClass);
  4347. end;
  4348. function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize, APrecision: Integer;
  4349. ARequired, AReadOnly: Boolean; AFieldNo: Integer): TFieldDef;
  4350. begin
  4351. Result:=FieldDefClass.Create(Self, MakeNameUnique(AName), ADataType, ASize, ARequired, AFieldNo);
  4352. if AReadOnly then
  4353. Result.Attributes := Result.Attributes + [faReadOnly];
  4354. end;
  4355. function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Integer): TFieldDef;
  4356. begin
  4357. Result:=FieldDefClass.Create(Self,AName,ADataType,ASize,ARequired,AFieldNo);
  4358. end;
  4359. procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
  4360. var I : longint;
  4361. begin
  4362. Clear;
  4363. For i:=0 to FieldDefs.Count-1 do
  4364. With FieldDefs[i] do
  4365. Add(Name,DataType,Size,Required);
  4366. end;
  4367. function TFieldDefs.Find(const AName: string): TFieldDef;
  4368. begin
  4369. Result := (Inherited Find(AName)) as TFieldDef;
  4370. if Result=nil then DatabaseErrorFmt(SFieldNotFound,[AName],FDataset);
  4371. end;
  4372. {
  4373. procedure TFieldDefs.Clear;
  4374. var I : longint;
  4375. begin
  4376. For I:=FItems.Count-1 downto 0 do
  4377. TFieldDef(Fitems[i]).Free;
  4378. FItems.Clear;
  4379. end;
  4380. }
  4381. procedure TFieldDefs.Update;
  4382. begin
  4383. if not Updated then
  4384. begin
  4385. If Assigned(Dataset) then
  4386. DataSet.InitFieldDefs;
  4387. Updated := True;
  4388. end;
  4389. end;
  4390. function TFieldDefs.MakeNameUnique(const AName: String): string;
  4391. var DblFieldCount : integer;
  4392. begin
  4393. DblFieldCount := 0;
  4394. Result := AName;
  4395. while assigned(inherited Find(Result)) do
  4396. begin
  4397. inc(DblFieldCount);
  4398. Result := AName + '_' + IntToStr(DblFieldCount);
  4399. end;
  4400. end;
  4401. function TFieldDefs.AddFieldDef: TFieldDef;
  4402. begin
  4403. Result:=FieldDefClass.Create(Self,'',ftUnknown,0,False,Count+1);
  4404. end;
  4405. { ---------------------------------------------------------------------
  4406. TField
  4407. ---------------------------------------------------------------------}
  4408. Const
  4409. // SBCD = 'BCD';
  4410. SBoolean = 'Boolean';
  4411. SDateTime = 'TDateTime';
  4412. SFloat = 'Float';
  4413. SInteger = 'Integer';
  4414. SLargeInt = 'NativeInt';
  4415. SJSValue = 'JSValue';
  4416. SString = 'String';
  4417. SBytes = 'Bytes';
  4418. constructor TField.Create(AOwner: TComponent);
  4419. //Var
  4420. // I : Integer;
  4421. begin
  4422. Inherited Create(AOwner);
  4423. FVisible:=True;
  4424. SetLength(FValidChars,255);
  4425. // For I:=0 to 255 do
  4426. // FValidChars[i]:=Char(i);
  4427. FProviderFlags := [pfInUpdate,pfInWhere];
  4428. end;
  4429. destructor TField.Destroy;
  4430. begin
  4431. IF Assigned(FDataSet) then
  4432. begin
  4433. FDataSet.Active:=False;
  4434. if Assigned(FFields) then
  4435. FFields.Remove(Self);
  4436. end;
  4437. FLookupList.Free;
  4438. Inherited Destroy;
  4439. end;
  4440. Procedure TField.RaiseAccessError(const TypeName: string);
  4441. Var
  4442. E : EDatabaseError;
  4443. begin
  4444. E:=AccessError(TypeName);
  4445. Raise E;
  4446. end;
  4447. function TField.AccessError(const TypeName: string): EDatabaseError;
  4448. begin
  4449. Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
  4450. end;
  4451. procedure TField.Assign(Source: TPersistent);
  4452. begin
  4453. if Source = nil then Clear
  4454. else if Source is TField then begin
  4455. Value := TField(Source).Value;
  4456. end else
  4457. inherited Assign(Source);
  4458. end;
  4459. procedure TField.AssignValue(const AValue: JSValue);
  4460. procedure Error;
  4461. begin
  4462. DatabaseErrorFmt(SFieldValueError, [DisplayName]);
  4463. end;
  4464. begin
  4465. Case GetValueType(AValue) of
  4466. jvtNull : Clear;
  4467. jvtBoolean : AsBoolean:=Boolean(AValue);
  4468. jvtInteger : AsLargeInt:=NativeInt(AValue);
  4469. jvtFloat : AsFloat:=Double(AValue);
  4470. jvtString : AsString:=String(AValue);
  4471. jvtArray : SetAsBytes(TBytes(AValue));
  4472. else
  4473. Error;
  4474. end;
  4475. end;
  4476. procedure TField.Bind(Binding: Boolean);
  4477. begin
  4478. if Binding and (FieldKind=fkLookup) then
  4479. begin
  4480. if ((FLookupDataSet = nil) or (FLookupKeyFields = '') or
  4481. (FLookupResultField = '') or (FKeyFields = '')) then
  4482. DatabaseErrorFmt(SLookupInfoError, [DisplayName]);
  4483. FFields.CheckFieldNames(FKeyFields);
  4484. FLookupDataSet.Open;
  4485. FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
  4486. FLookupDataSet.FieldByName(FLookupResultField);
  4487. if FLookupCache then
  4488. RefreshLookupList;
  4489. end;
  4490. end;
  4491. procedure TField.Change;
  4492. begin
  4493. If Assigned(FOnChange) Then
  4494. FOnChange(Self);
  4495. end;
  4496. procedure TField.CheckInactive;
  4497. begin
  4498. If Assigned(FDataSet) then
  4499. FDataset.CheckInactive;
  4500. end;
  4501. procedure TField.Clear;
  4502. begin
  4503. SetData(Nil);
  4504. end;
  4505. procedure TField.DataChanged;
  4506. begin
  4507. FDataset.DataEvent(deFieldChange,self);
  4508. end;
  4509. procedure TField.FocusControl;
  4510. var
  4511. Field1: TField;
  4512. begin
  4513. Field1 := Self;
  4514. FDataSet.DataEvent(deFocusControl,Field1);
  4515. end;
  4516. function TField.GetAsBoolean: Boolean;
  4517. begin
  4518. raiseAccessError(SBoolean);
  4519. Result:=false;
  4520. end;
  4521. function TField.GetAsBytes: TBytes;
  4522. begin
  4523. raiseAccessError(SBytes);
  4524. Result:=nil;
  4525. end;
  4526. function TField.GetAsDateTime: TDateTime;
  4527. begin
  4528. raiseAccessError(SdateTime);
  4529. Result:=0.0;
  4530. end;
  4531. function TField.GetAsFloat: Double;
  4532. begin
  4533. raiseAccessError(SDateTime);
  4534. Result:=0.0;
  4535. end;
  4536. function TField.GetAsLargeInt: NativeInt;
  4537. begin
  4538. RaiseAccessError(SLargeInt);
  4539. Result:=0;
  4540. end;
  4541. function TField.GetAsLongint: Longint;
  4542. begin
  4543. Result:=GetAsInteger;
  4544. end;
  4545. function TField.GetAsInteger: Longint;
  4546. begin
  4547. RaiseAccessError(SInteger);
  4548. Result:=0;
  4549. end;
  4550. function TField.GetAsJSValue: JSValue;
  4551. begin
  4552. Result:=GetData
  4553. end;
  4554. function TField.GetAsString: string;
  4555. begin
  4556. Result := GetClassDesc
  4557. end;
  4558. function TField.GetOldValue: JSValue;
  4559. var SaveState : TDatasetState;
  4560. begin
  4561. SaveState := FDataset.State;
  4562. try
  4563. FDataset.SetTempState(dsOldValue);
  4564. Result := GetAsJSValue;
  4565. finally
  4566. FDataset.RestoreState(SaveState);
  4567. end;
  4568. end;
  4569. function TField.GetNewValue: JSValue;
  4570. var SaveState : TDatasetState;
  4571. begin
  4572. SaveState := FDataset.State;
  4573. try
  4574. FDataset.SetTempState(dsNewValue);
  4575. Result := GetAsJSValue;
  4576. finally
  4577. FDataset.RestoreState(SaveState);
  4578. end;
  4579. end;
  4580. procedure TField.SetNewValue(const AValue: JSValue);
  4581. var SaveState : TDatasetState;
  4582. begin
  4583. SaveState := FDataset.State;
  4584. try
  4585. FDataset.SetTempState(dsNewValue);
  4586. SetAsJSValue(AValue);
  4587. finally
  4588. FDataset.RestoreState(SaveState);
  4589. end;
  4590. end;
  4591. function TField.GetCurValue: JSValue;
  4592. var SaveState : TDatasetState;
  4593. begin
  4594. SaveState := FDataset.State;
  4595. try
  4596. FDataset.SetTempState(dsCurValue);
  4597. Result := GetAsJSValue;
  4598. finally
  4599. FDataset.RestoreState(SaveState);
  4600. end;
  4601. end;
  4602. function TField.GetCanModify: Boolean;
  4603. begin
  4604. Result:=Not ReadOnly;
  4605. If Result then
  4606. begin
  4607. Result := FieldKind in [fkData, fkInternalCalc];
  4608. if Result then
  4609. begin
  4610. Result:=Assigned(DataSet) and Dataset.Active;
  4611. If Result then
  4612. Result:= DataSet.CanModify;
  4613. end;
  4614. end;
  4615. end;
  4616. function TField.GetClassDesc: String;
  4617. var ClassN : string;
  4618. begin
  4619. ClassN := copy(ClassName,2,pos('Field',ClassName)-2);
  4620. if isNull then
  4621. result := '(' + LowerCase(ClassN) + ')'
  4622. else
  4623. result := '(' + UpperCase(ClassN) + ')';
  4624. end;
  4625. function TField.GetData : JSValue;
  4626. begin
  4627. IF FDataset=Nil then
  4628. DatabaseErrorFmt(SNoDataset,[FieldName]);
  4629. If FValidating then
  4630. result:=FValueBuffer
  4631. else
  4632. Result:=FDataset.GetFieldData(Self);
  4633. end;
  4634. function TField.GetDataSize: Integer;
  4635. begin
  4636. Result:=0;
  4637. end;
  4638. function TField.GetDefaultWidth: Longint;
  4639. begin
  4640. Result:=10;
  4641. end;
  4642. function TField.GetDisplayName : String;
  4643. begin
  4644. If FDisplayLabel<>'' then
  4645. result:=FDisplayLabel
  4646. else
  4647. Result:=FFieldName;
  4648. end;
  4649. function TField.IsDisplayLabelStored: Boolean;
  4650. begin
  4651. Result:=(DisplayLabel<>FieldName);
  4652. end;
  4653. function TField.IsDisplayWidthStored: Boolean;
  4654. begin
  4655. Result:=(FDisplayWidth<>0);
  4656. end;
  4657. function TField.GetLookupList: TLookupList;
  4658. begin
  4659. if not Assigned(FLookupList) then
  4660. FLookupList := TLookupList.Create;
  4661. Result := FLookupList;
  4662. end;
  4663. procedure TField.CalcLookupValue;
  4664. begin
  4665. { MVC: TODO
  4666. if FLookupCache then
  4667. Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
  4668. else if Assigned(FLookupDataSet) and FDataSet.Active then
  4669. Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField);
  4670. }
  4671. end;
  4672. function TField.GetIndex: longint;
  4673. begin
  4674. If Assigned(FDataset) then
  4675. Result:=FDataset.FFieldList.IndexOf(Self)
  4676. else
  4677. Result:=-1;
  4678. end;
  4679. function TField.GetLookup: Boolean;
  4680. begin
  4681. Result := FieldKind = fkLookup;
  4682. end;
  4683. procedure TField.SetAlignment(const AValue: TAlignMent);
  4684. begin
  4685. if FAlignment <> AValue then
  4686. begin
  4687. FAlignment := AValue;
  4688. PropertyChanged(false);
  4689. end;
  4690. end;
  4691. procedure TField.SetIndex(const AValue: Longint);
  4692. begin
  4693. if FFields <> nil then FFields.SetFieldIndex(Self, AValue)
  4694. end;
  4695. function TField.GetIsNull: Boolean;
  4696. begin
  4697. Result:=js.IsNull(GetData);
  4698. end;
  4699. function TField.GetParentComponent: TComponent;
  4700. begin
  4701. Result := DataSet;
  4702. end;
  4703. procedure TField.GetText(var AText: string; ADisplayText: Boolean);
  4704. begin
  4705. AText:=GetAsString;
  4706. end;
  4707. function TField.HasParent: Boolean;
  4708. begin
  4709. HasParent:=True;
  4710. end;
  4711. function TField.IsValidChar(InputChar: Char): Boolean;
  4712. begin
  4713. // FValidChars must be set in Create.
  4714. Result:=CharInset(InputChar,FValidChars);
  4715. end;
  4716. procedure TField.RefreshLookupList;
  4717. var
  4718. tmpActive: Boolean;
  4719. begin
  4720. if not Assigned(FLookupDataSet) or (Length(FLookupKeyfields) = 0)
  4721. or (Length(FLookupresultField) = 0) or (Length(FKeyFields) = 0) then
  4722. Exit;
  4723. tmpActive := FLookupDataSet.Active;
  4724. try
  4725. FLookupDataSet.Active := True;
  4726. FFields.CheckFieldNames(FKeyFields);
  4727. FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
  4728. FLookupDataset.FieldByName(FLookupResultField); // I presume that if it doesn't exist it throws exception, and that a field with null value is still valid
  4729. LookupList.Clear; // have to be F-less because we might be creating it here with getter!
  4730. FLookupDataSet.DisableControls;
  4731. try
  4732. FLookupDataSet.First;
  4733. while not FLookupDataSet.Eof do
  4734. begin
  4735. // FLookupList.Add(FLookupDataSet.FieldValues[FLookupKeyfields], FLookupDataSet.FieldValues[FLookupResultField]);
  4736. FLookupDataSet.Next;
  4737. end;
  4738. finally
  4739. FLookupDataSet.EnableControls;
  4740. end;
  4741. finally
  4742. FLookupDataSet.Active := tmpActive;
  4743. end;
  4744. end;
  4745. procedure TField.Notification(AComponent: TComponent; Operation: TOperation);
  4746. begin
  4747. Inherited Notification(AComponent,Operation);
  4748. if (Operation = opRemove) and (AComponent = FLookupDataSet) then
  4749. FLookupDataSet := nil;
  4750. end;
  4751. procedure TField.PropertyChanged(LayoutAffected: Boolean);
  4752. begin
  4753. If (FDataset<>Nil) and (FDataset.Active) then
  4754. If LayoutAffected then
  4755. FDataset.DataEvent(deLayoutChange,0)
  4756. else
  4757. FDataset.DataEvent(deDatasetchange,0);
  4758. end;
  4759. procedure TField.SetAsBytes(const AValue: TBytes);
  4760. begin
  4761. RaiseAccessError(SBytes);
  4762. end;
  4763. procedure TField.SetAsBoolean(AValue: Boolean);
  4764. begin
  4765. RaiseAccessError(SBoolean);
  4766. end;
  4767. procedure TField.SetAsDateTime(AValue: TDateTime);
  4768. begin
  4769. RaiseAccessError(SDateTime);
  4770. end;
  4771. procedure TField.SetAsFloat(AValue: Double);
  4772. begin
  4773. RaiseAccessError(SFloat);
  4774. end;
  4775. procedure TField.SetAsJSValue(const AValue: JSValue);
  4776. begin
  4777. if js.IsNull(AValue) then
  4778. Clear
  4779. else
  4780. try
  4781. SetVarValue(AValue);
  4782. except
  4783. on EVariantError do
  4784. DatabaseErrorFmt(SFieldValueError, [DisplayName]);
  4785. end;
  4786. end;
  4787. procedure TField.SetAsLongint(AValue: Longint);
  4788. begin
  4789. SetAsInteger(AValue);
  4790. end;
  4791. procedure TField.SetAsInteger(AValue: Longint);
  4792. begin
  4793. RaiseAccessError(SInteger);
  4794. end;
  4795. procedure TField.SetAsLargeInt(AValue: NativeInt);
  4796. begin
  4797. RaiseAccessError(SLargeInt);
  4798. end;
  4799. procedure TField.SetAsString(const AValue: string);
  4800. begin
  4801. RaiseAccessError(SString);
  4802. end;
  4803. procedure TField.SetData(Buffer: JSValue);
  4804. begin
  4805. If Not Assigned(FDataset) then
  4806. DatabaseErrorFmt(SNoDataset,[FieldName]);
  4807. FDataSet.SetFieldData(Self,Buffer);
  4808. end;
  4809. procedure TField.SetDataset(AValue: TDataset);
  4810. begin
  4811. {$ifdef dsdebug}
  4812. Writeln ('Setting dataset');
  4813. {$endif}
  4814. If AValue=FDataset then exit;
  4815. If Assigned(FDataset) Then
  4816. begin
  4817. FDataset.CheckInactive;
  4818. FDataset.FFieldList.Remove(Self);
  4819. end;
  4820. If Assigned(AValue) then
  4821. begin
  4822. AValue.CheckInactive;
  4823. AValue.FFieldList.Add(Self);
  4824. end;
  4825. FDataset:=AValue;
  4826. end;
  4827. procedure TField.SetDataType(AValue: TFieldType);
  4828. begin
  4829. FDataType := AValue;
  4830. end;
  4831. procedure TField.SetFieldType(AValue: TFieldType);
  4832. begin
  4833. { empty }
  4834. end;
  4835. procedure TField.SetParentComponent(Value: TComponent);
  4836. begin
  4837. if not (csLoading in ComponentState) then
  4838. DataSet := Value as TDataSet;
  4839. end;
  4840. procedure TField.SetSize(AValue: Integer);
  4841. begin
  4842. CheckInactive;
  4843. CheckTypeSize(AValue);
  4844. FSize:=AValue;
  4845. end;
  4846. procedure TField.SetText(const AValue: string);
  4847. begin
  4848. SetAsString(AValue);
  4849. end;
  4850. procedure TField.SetVarValue(const AValue: JSValue);
  4851. begin
  4852. RaiseAccessError(SJSValue);
  4853. end;
  4854. procedure TField.Validate(Buffer: Pointer);
  4855. begin
  4856. If assigned(OnValidate) Then
  4857. begin
  4858. FValueBuffer:=Buffer;
  4859. FValidating:=True;
  4860. Try
  4861. OnValidate(Self);
  4862. finally
  4863. FValidating:=False;
  4864. end;
  4865. end;
  4866. end;
  4867. class function TField.IsBlob: Boolean;
  4868. begin
  4869. Result:=False;
  4870. end;
  4871. class procedure TField.CheckTypeSize(AValue: Longint);
  4872. begin
  4873. If (AValue<>0) and Not IsBlob Then
  4874. DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
  4875. end;
  4876. // TField private methods
  4877. procedure TField.SetEditText(const AValue: string);
  4878. begin
  4879. if Assigned(OnSetText) then
  4880. OnSetText(Self, AValue)
  4881. else
  4882. SetText(AValue);
  4883. end;
  4884. function TField.GetEditText: String;
  4885. begin
  4886. SetLength(Result, 0);
  4887. if Assigned(OnGetText) then
  4888. OnGetText(Self, Result, False)
  4889. else
  4890. GetText(Result, False);
  4891. end;
  4892. function TField.GetDisplayText: String;
  4893. begin
  4894. SetLength(Result, 0);
  4895. if Assigned(OnGetText) then
  4896. OnGetText(Self, Result, True)
  4897. else
  4898. GetText(Result, True);
  4899. end;
  4900. procedure TField.SetDisplayLabel(const AValue: string);
  4901. begin
  4902. if FDisplayLabel<>AValue then
  4903. begin
  4904. FDisplayLabel:=AValue;
  4905. PropertyChanged(true);
  4906. end;
  4907. end;
  4908. procedure TField.SetDisplayWidth(const AValue: Longint);
  4909. begin
  4910. if FDisplayWidth<>AValue then
  4911. begin
  4912. FDisplayWidth:=AValue;
  4913. PropertyChanged(True);
  4914. end;
  4915. end;
  4916. function TField.GetDisplayWidth: integer;
  4917. begin
  4918. if FDisplayWidth=0 then
  4919. result:=GetDefaultWidth
  4920. else
  4921. result:=FDisplayWidth;
  4922. end;
  4923. procedure TField.SetLookup(const AValue: Boolean);
  4924. const
  4925. ValueToLookupMap: array[Boolean] of TFieldKind = (fkData, fkLookup);
  4926. begin
  4927. FieldKind := ValueToLookupMap[AValue];
  4928. end;
  4929. procedure TField.SetReadOnly(const AValue: Boolean);
  4930. begin
  4931. if (FReadOnly<>AValue) then
  4932. begin
  4933. FReadOnly:=AValue;
  4934. PropertyChanged(True);
  4935. end;
  4936. end;
  4937. procedure TField.SetVisible(const AValue: Boolean);
  4938. begin
  4939. if FVisible<>AValue then
  4940. begin
  4941. FVisible:=AValue;
  4942. PropertyChanged(True);
  4943. end;
  4944. end;
  4945. { ---------------------------------------------------------------------
  4946. TStringField
  4947. ---------------------------------------------------------------------}
  4948. constructor TStringField.Create(AOwner: TComponent);
  4949. begin
  4950. Inherited Create(AOwner);
  4951. SetDataType(ftString);
  4952. FFixedChar := False;
  4953. FTransliterate := False;
  4954. FSize := 20;
  4955. end;
  4956. procedure TStringField.SetFieldType(AValue: TFieldType);
  4957. begin
  4958. if AValue in [ftString, ftFixedChar] then
  4959. SetDataType(AValue);
  4960. end;
  4961. class procedure TStringField.CheckTypeSize(AValue: Longint);
  4962. begin
  4963. // A size of 0 is allowed, since for example Firebird allows
  4964. // a query like: 'select '' as fieldname from table' which
  4965. // results in a string with size 0.
  4966. If (AValue<0) Then
  4967. DatabaseErrorFmt(SInvalidFieldSize,[AValue])
  4968. end;
  4969. function TStringField.GetAsBoolean: Boolean;
  4970. var S : String;
  4971. begin
  4972. S:=GetAsString;
  4973. result := (Length(S)>0) and (Upcase(S[1]) in ['T',YesNoChars[True]]);
  4974. end;
  4975. function TStringField.GetAsDateTime: TDateTime;
  4976. begin
  4977. Result:=StrToDateTime(GetAsString);
  4978. end;
  4979. function TStringField.GetAsFloat: Double;
  4980. begin
  4981. Result:=StrToFloat(GetAsString);
  4982. end;
  4983. function TStringField.GetAsInteger: Longint;
  4984. begin
  4985. Result:=StrToInt(GetAsString);
  4986. end;
  4987. function TStringField.GetAsLargeInt: NativeInt;
  4988. begin
  4989. Result:=StrToInt64(GetAsString);
  4990. end;
  4991. function TStringField.GetAsString: String;
  4992. Var
  4993. V : JSValue;
  4994. begin
  4995. V:=GetData;
  4996. if isString(V) then
  4997. Result := String(V)
  4998. else
  4999. Result:='';
  5000. end;
  5001. function TStringField.GetAsJSValue: JSValue;
  5002. begin
  5003. Result:=GetData
  5004. end;
  5005. function TStringField.GetDefaultWidth: Longint;
  5006. begin
  5007. result:=Size;
  5008. end;
  5009. procedure TStringField.GetText(var AText: string; ADisplayText: Boolean);
  5010. begin
  5011. AText:=GetAsString;
  5012. end;
  5013. procedure TStringField.SetAsBoolean(AValue: Boolean);
  5014. begin
  5015. If AValue Then
  5016. SetAsString('T')
  5017. else
  5018. SetAsString('F');
  5019. end;
  5020. procedure TStringField.SetAsDateTime(AValue: TDateTime);
  5021. begin
  5022. SetAsString(DateTimeToStr(AValue));
  5023. end;
  5024. procedure TStringField.SetAsFloat(AValue: Double);
  5025. begin
  5026. SetAsString(FloatToStr(AValue));
  5027. end;
  5028. procedure TStringField.SetAsInteger(AValue: Longint);
  5029. begin
  5030. SetAsString(IntToStr(AValue));
  5031. end;
  5032. procedure TStringField.SetAsLargeInt(AValue: NativeInt);
  5033. begin
  5034. SetAsString(IntToStr(AValue));
  5035. end;
  5036. procedure TStringField.SetAsString(const AValue: String);
  5037. begin
  5038. SetData(AValue);
  5039. end;
  5040. procedure TStringField.SetVarValue(const AValue: JSValue);
  5041. begin
  5042. if isString(AVAlue) then
  5043. SetAsString(String(AValue))
  5044. else
  5045. RaiseAccessError(SFieldValueError);
  5046. end;
  5047. { ---------------------------------------------------------------------
  5048. TNumericField
  5049. ---------------------------------------------------------------------}
  5050. constructor TNumericField.Create(AOwner: TComponent);
  5051. begin
  5052. Inherited Create(AOwner);
  5053. AlignMent:=taRightJustify;
  5054. end;
  5055. class procedure TNumericField.CheckTypeSize(AValue: Longint);
  5056. begin
  5057. // This procedure is only added because some TDataset descendents have the
  5058. // but that they set the Size property as if it is the DataSize property.
  5059. // To avoid problems with those descendents, allow values <= 16.
  5060. If (AValue>16) Then
  5061. DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
  5062. end;
  5063. procedure TNumericField.RangeError(AValue, Min, Max: Double);
  5064. begin
  5065. DatabaseErrorFmt(SRangeError,[AValue,Min,Max,FieldName]);
  5066. end;
  5067. procedure TNumericField.SetDisplayFormat(const AValue: string);
  5068. begin
  5069. If FDisplayFormat<>AValue then
  5070. begin
  5071. FDisplayFormat:=AValue;
  5072. PropertyChanged(True);
  5073. end;
  5074. end;
  5075. procedure TNumericField.SetEditFormat(const AValue: string);
  5076. begin
  5077. If FEditFormat<>AValue then
  5078. begin
  5079. FEditFormat:=AValue;
  5080. PropertyChanged(True);
  5081. end;
  5082. end;
  5083. function TNumericField.GetAsBoolean: Boolean;
  5084. begin
  5085. Result:=GetAsInteger<>0;
  5086. end;
  5087. procedure TNumericField.SetAsBoolean(AValue: Boolean);
  5088. begin
  5089. SetAsInteger(ord(AValue));
  5090. end;
  5091. { ---------------------------------------------------------------------
  5092. TIntegerField
  5093. ---------------------------------------------------------------------}
  5094. constructor TIntegerField.Create(AOwner: TComponent);
  5095. begin
  5096. Inherited Create(AOwner);
  5097. SetDataType(ftInteger);
  5098. FMinRange:=Low(LongInt);
  5099. FMaxRange:=High(LongInt);
  5100. // MVC : Todo
  5101. // FValidchars:=['+','-','0'..'9'];
  5102. end;
  5103. function TIntegerField.GetAsFloat: Double;
  5104. begin
  5105. Result:=GetAsInteger;
  5106. end;
  5107. function TIntegerField.GetAsLargeInt: NativeInt;
  5108. begin
  5109. Result:=GetAsInteger;
  5110. end;
  5111. function TIntegerField.GetAsInteger: Longint;
  5112. begin
  5113. If Not GetValue(Result) then
  5114. Result:=0;
  5115. end;
  5116. function TIntegerField.GetAsJSValue: JSValue;
  5117. var L : Longint;
  5118. begin
  5119. If GetValue(L) then
  5120. Result:=L
  5121. else
  5122. Result:=Null;
  5123. end;
  5124. function TIntegerField.GetAsString: string;
  5125. var L : Longint;
  5126. begin
  5127. If GetValue(L) then
  5128. Result:=IntTostr(L)
  5129. else
  5130. Result:='';
  5131. end;
  5132. procedure TIntegerField.GetText(var AText: string; ADisplayText: Boolean);
  5133. var l : longint;
  5134. fmt : string;
  5135. begin
  5136. Atext:='';
  5137. If Not GetValue(l) then exit;
  5138. If ADisplayText or (FEditFormat='') then
  5139. fmt:=FDisplayFormat
  5140. else
  5141. fmt:=FEditFormat;
  5142. If length(fmt)<>0 then
  5143. AText:=FormatFloat(fmt,L)
  5144. else
  5145. Str(L,AText);
  5146. end;
  5147. function TIntegerField.GetValue(var AValue: Longint): Boolean;
  5148. var
  5149. V : JSValue;
  5150. begin
  5151. V:=GetData;
  5152. Result:=isInteger(V);
  5153. if Result then
  5154. AValue:=Longint(V);
  5155. end;
  5156. procedure TIntegerField.SetAsLargeInt(AValue: NativeInt);
  5157. begin
  5158. if (AValue>=FMinRange) and (AValue<=FMaxRange) then
  5159. SetAsInteger(AValue)
  5160. else
  5161. RangeError(AValue,FMinRange,FMaxRange);
  5162. end;
  5163. procedure TIntegerField.SetAsFloat(AValue: Double);
  5164. begin
  5165. SetAsInteger(Round(AValue));
  5166. end;
  5167. procedure TIntegerField.SetAsInteger(AValue: Longint);
  5168. begin
  5169. If CheckRange(AValue) then
  5170. SetData(AValue)
  5171. else
  5172. if (FMinValue<>0) or (FMaxValue<>0) then
  5173. RangeError(AValue,FMinValue,FMaxValue)
  5174. else
  5175. RangeError(AValue,FMinRange,FMaxRange);
  5176. end;
  5177. procedure TIntegerField.SetVarValue(const AValue: JSValue);
  5178. begin
  5179. if IsInteger(aValue) then
  5180. SetAsInteger(Integer(AValue))
  5181. else
  5182. RaiseAccessError(SInteger);
  5183. end;
  5184. procedure TIntegerField.SetAsString(const AValue: string);
  5185. var L,Code : longint;
  5186. begin
  5187. If length(AValue)=0 then
  5188. Clear
  5189. else
  5190. begin
  5191. Val(AValue,L,Code);
  5192. If Code=0 then
  5193. SetAsInteger(L)
  5194. else
  5195. DatabaseErrorFmt(SNotAnInteger,[AValue]);
  5196. end;
  5197. end;
  5198. Function TIntegerField.CheckRange(AValue : longint) : Boolean;
  5199. begin
  5200. if (FMinValue<>0) or (FMaxValue<>0) then
  5201. Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
  5202. else
  5203. Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
  5204. end;
  5205. Procedure TIntegerField.SetMaxValue (AValue : longint);
  5206. begin
  5207. If (AValue>=FMinRange) and (AValue<=FMaxRange) then
  5208. FMaxValue:=AValue
  5209. else
  5210. RangeError(AValue,FMinRange,FMaxRange);
  5211. end;
  5212. Procedure TIntegerField.SetMinValue (AValue : longint);
  5213. begin
  5214. If (AValue>=FMinRange) and (AValue<=FMaxRange) then
  5215. FMinValue:=AValue
  5216. else
  5217. RangeError(AValue,FMinRange,FMaxRange);
  5218. end;
  5219. { ---------------------------------------------------------------------
  5220. TLargeintField
  5221. ---------------------------------------------------------------------}
  5222. constructor TLargeintField.Create(AOwner: TComponent);
  5223. begin
  5224. Inherited Create(AOwner);
  5225. SetDataType(ftLargeint);
  5226. FMinRange:=Low(NativeInt);
  5227. FMaxRange:=High(NativeInt);
  5228. // MVC : Todo
  5229. // FValidchars:=['+','-','0'..'9'];
  5230. end;
  5231. function TLargeintField.GetAsFloat: Double;
  5232. begin
  5233. Result:=GetAsLargeInt;
  5234. end;
  5235. function TLargeintField.GetAsLargeInt: NativeInt;
  5236. begin
  5237. If Not GetValue(Result) then
  5238. Result:=0;
  5239. end;
  5240. function TLargeIntField.GetAsJSValue: JSValue;
  5241. var L : NativeInt;
  5242. begin
  5243. If GetValue(L) then
  5244. Result:=L
  5245. else
  5246. Result:=Null;
  5247. end;
  5248. function TLargeintField.GetAsInteger: Longint;
  5249. begin
  5250. Result:=GetAsLargeInt;
  5251. end;
  5252. function TLargeintField.GetAsString: string;
  5253. var L : NativeInt;
  5254. begin
  5255. If GetValue(L) then
  5256. Result:=IntTostr(L)
  5257. else
  5258. Result:='';
  5259. end;
  5260. procedure TLargeintField.GetText(var AText: string; ADisplayText: Boolean);
  5261. var l : NativeInt;
  5262. fmt : string;
  5263. begin
  5264. Atext:='';
  5265. If Not GetValue(l) then exit;
  5266. If ADisplayText or (FEditFormat='') then
  5267. fmt:=FDisplayFormat
  5268. else
  5269. fmt:=FEditFormat;
  5270. If length(fmt)<>0 then
  5271. AText:=FormatFloat(fmt,L)
  5272. else
  5273. Str(L,AText);
  5274. end;
  5275. function TLargeintField.GetValue(var AValue: NativeInt): Boolean;
  5276. var
  5277. P : JSValue;
  5278. begin
  5279. P:=GetData;
  5280. Result:=isInteger(P);
  5281. if Result then
  5282. AValue:=NativeInt(P);
  5283. end;
  5284. procedure TLargeintField.SetAsFloat(AValue: Double);
  5285. begin
  5286. SetAsLargeInt(Round(AValue));
  5287. end;
  5288. procedure TLargeintField.SetAsLargeInt(AValue: NativeInt);
  5289. begin
  5290. If CheckRange(AValue) then
  5291. SetData(AValue)
  5292. else
  5293. RangeError(AValue,FMinValue,FMaxValue);
  5294. end;
  5295. procedure TLargeintField.SetAsInteger(AValue: Longint);
  5296. begin
  5297. SetAsLargeInt(AValue);
  5298. end;
  5299. procedure TLargeintField.SetAsString(const AValue: string);
  5300. var L : NativeInt;
  5301. code : Longint;
  5302. begin
  5303. If length(AValue)=0 then
  5304. Clear
  5305. else
  5306. begin
  5307. Val(AValue,L,Code);
  5308. If Code=0 then
  5309. SetAsLargeInt(L)
  5310. else
  5311. DatabaseErrorFmt(SNotAnInteger,[AValue]);
  5312. end;
  5313. end;
  5314. procedure TLargeintField.SetVarValue(const AValue: JSValue);
  5315. begin
  5316. if IsInteger(Avalue) then
  5317. SetAsLargeInt(NativeInt(AValue))
  5318. else
  5319. RaiseAccessError(SLargeInt);
  5320. end;
  5321. Function TLargeintField.CheckRange(AValue : NativeInt) : Boolean;
  5322. begin
  5323. if (FMinValue<>0) or (FMaxValue<>0) then
  5324. Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
  5325. else
  5326. Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
  5327. end;
  5328. Procedure TLargeintField.SetMaxValue (AValue : NativeInt);
  5329. begin
  5330. If (AValue>=FMinRange) and (AValue<=FMaxRange) then
  5331. FMaxValue:=AValue
  5332. else
  5333. RangeError(AValue,FMinRange,FMaxRange);
  5334. end;
  5335. Procedure TLargeintField.SetMinValue (AValue : NativeInt);
  5336. begin
  5337. If (AValue>=FMinRange) and (AValue<=FMaxRange) then
  5338. FMinValue:=AValue
  5339. else
  5340. RangeError(AValue,FMinRange,FMaxRange);
  5341. end;
  5342. { TAutoIncField }
  5343. constructor TAutoIncField.Create(AOwner: TComponent);
  5344. begin
  5345. Inherited Create(AOWner);
  5346. SetDataType(ftAutoInc);
  5347. end;
  5348. Procedure TAutoIncField.SetAsInteger(AValue: Longint);
  5349. begin
  5350. // Some databases allows insertion of explicit values into identity columns
  5351. // (some of them also allows (some not) updating identity columns)
  5352. // So allow it at client side and leave check for server side
  5353. //if not(FDataSet.State in [dsFilter,dsSetKey,dsInsert]) then
  5354. // DataBaseError(SCantSetAutoIncFields);
  5355. inherited;
  5356. end;
  5357. { TFloatField }
  5358. procedure TFloatField.SetCurrency(const AValue: Boolean);
  5359. begin
  5360. if FCurrency=AValue then exit;
  5361. FCurrency:=AValue;
  5362. end;
  5363. procedure TFloatField.SetPrecision(const AValue: Longint);
  5364. begin
  5365. if (AValue = -1) or (AValue > 1) then
  5366. FPrecision := AValue
  5367. else
  5368. FPrecision := 2;
  5369. end;
  5370. function TFloatField.GetAsFloat: Double;
  5371. Var
  5372. P : JSValue;
  5373. begin
  5374. P:=GetData;
  5375. If IsNumber(P) then
  5376. Result:=Double(P)
  5377. else
  5378. Result:=0.0;
  5379. end;
  5380. function TFloatField.GetAsJSValue: JSValue;
  5381. var
  5382. P : JSValue;
  5383. begin
  5384. P:=GetData;
  5385. if IsNumber(P) then
  5386. Result:=P
  5387. else
  5388. Result:=Null;
  5389. end;
  5390. function TFloatField.GetAsLargeInt: NativeInt;
  5391. begin
  5392. Result:=Round(GetAsFloat);
  5393. end;
  5394. function TFloatField.GetAsInteger: Longint;
  5395. begin
  5396. Result:=Round(GetAsFloat);
  5397. end;
  5398. function TFloatField.GetAsString: string;
  5399. var
  5400. P : JSValue;
  5401. begin
  5402. P:=GetData;
  5403. if IsNumber(P) then
  5404. Result:=FloatToStr(Double(P))
  5405. else
  5406. Result:='';
  5407. end;
  5408. procedure TFloatField.GetText(var AText: string; ADisplayText: Boolean);
  5409. Var
  5410. fmt : string;
  5411. E : Double;
  5412. Digits : integer;
  5413. ff: TFloatFormat;
  5414. P : JSValue;
  5415. begin
  5416. AText:='';
  5417. P:=GetData;
  5418. if Not IsNumber(P) then
  5419. exit;
  5420. E:=Double(P);
  5421. If ADisplayText or (Length(FEditFormat) = 0) Then
  5422. Fmt:=FDisplayFormat
  5423. else
  5424. Fmt:=FEditFormat;
  5425. Digits := 0;
  5426. if not FCurrency then
  5427. ff := ffGeneral
  5428. else
  5429. begin
  5430. Digits := 2;
  5431. ff := ffFixed;
  5432. end;
  5433. If fmt<>'' then
  5434. AText:=FormatFloat(fmt,E)
  5435. else
  5436. AText:=FloatToStrF(E,ff,FPrecision,Digits);
  5437. end;
  5438. procedure TFloatField.SetAsFloat(AValue: Double);
  5439. begin
  5440. If CheckRange(AValue) then
  5441. SetData(AValue)
  5442. else
  5443. RangeError(AValue,FMinValue,FMaxValue);
  5444. end;
  5445. procedure TFloatField.SetAsLargeInt(AValue: NativeInt);
  5446. begin
  5447. SetAsFloat(AValue);
  5448. end;
  5449. procedure TFloatField.SetAsInteger(AValue: Longint);
  5450. begin
  5451. SetAsFloat(AValue);
  5452. end;
  5453. procedure TFloatField.SetAsString(const AValue: string);
  5454. var f : Double;
  5455. begin
  5456. If (AValue='') then
  5457. Clear
  5458. else
  5459. begin
  5460. If not TryStrToFloat(AValue,F) then
  5461. DatabaseErrorFmt(SNotAFloat, [AValue]);
  5462. SetAsFloat(f);
  5463. end;
  5464. end;
  5465. procedure TFloatField.SetVarValue(const AValue: JSValue);
  5466. begin
  5467. if IsNumber(aValue) then
  5468. SetAsFloat(Double(AValue))
  5469. else
  5470. RaiseAccessError('Float');
  5471. end;
  5472. constructor TFloatField.Create(AOwner: TComponent);
  5473. begin
  5474. Inherited Create(AOwner);
  5475. SetDataType(ftFloat);
  5476. FPrecision:=15;
  5477. // MVC
  5478. // FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
  5479. end;
  5480. Function TFloatField.CheckRange(AValue : Double) : Boolean;
  5481. begin
  5482. If (FMinValue<>0) or (FMaxValue<>0) then
  5483. Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
  5484. else
  5485. Result:=True;
  5486. end;
  5487. { TBooleanField }
  5488. function TBooleanField.GetAsBoolean: Boolean;
  5489. var
  5490. P : JSValue;
  5491. begin
  5492. P:=GetData;
  5493. if isBoolean(P) then
  5494. Result:=Boolean(P)
  5495. else
  5496. Result:=False;
  5497. end;
  5498. function TBooleanField.GetAsJSValue: JSValue;
  5499. var
  5500. P : JSValue;
  5501. begin
  5502. P:=GetData;
  5503. if isBoolean(P) then
  5504. Result:=Boolean(P)
  5505. else
  5506. Result:=Null;
  5507. end;
  5508. function TBooleanField.GetAsString: string;
  5509. var
  5510. P : JSValue;
  5511. begin
  5512. P:=GetData;
  5513. if isBoolean(P) then
  5514. Result:=FDisplays[False,Boolean(P)]
  5515. else
  5516. result:='';
  5517. end;
  5518. function TBooleanField.GetDefaultWidth: Longint;
  5519. begin
  5520. Result:=Length(FDisplays[false,false]);
  5521. If Result<Length(FDisplays[false,True]) then
  5522. Result:=Length(FDisplays[false,True]);
  5523. end;
  5524. function TBooleanField.GetAsInteger: Longint;
  5525. begin
  5526. Result := ord(GetAsBoolean);
  5527. end;
  5528. procedure TBooleanField.SetAsInteger(AValue: Longint);
  5529. begin
  5530. SetAsBoolean(AValue<>0);
  5531. end;
  5532. procedure TBooleanField.SetAsBoolean(AValue: Boolean);
  5533. begin
  5534. SetData(AValue);
  5535. end;
  5536. procedure TBooleanField.SetAsString(const AValue: string);
  5537. var Temp : string;
  5538. begin
  5539. Temp:=UpperCase(AValue);
  5540. if Temp='' then
  5541. Clear
  5542. else if pos(Temp, FDisplays[True,True])=1 then
  5543. SetAsBoolean(True)
  5544. else if pos(Temp, FDisplays[True,False])=1 then
  5545. SetAsBoolean(False)
  5546. else
  5547. DatabaseErrorFmt(SNotABoolean,[AValue]);
  5548. end;
  5549. procedure TBooleanField.SetVarValue(const AValue: JSValue);
  5550. begin
  5551. if isBoolean(aValue) then
  5552. SetAsBoolean(Boolean(AValue))
  5553. else if isNumber(aValue) then
  5554. SetAsBoolean(Double(AValue)<>0)
  5555. end;
  5556. constructor TBooleanField.Create(AOwner: TComponent);
  5557. begin
  5558. Inherited Create(AOwner);
  5559. SetDataType(ftBoolean);
  5560. DisplayValues:='True;False';
  5561. end;
  5562. Procedure TBooleanField.SetDisplayValues(const AValue : String);
  5563. var I : longint;
  5564. begin
  5565. If FDisplayValues<>AValue then
  5566. begin
  5567. I:=Pos(';',AValue);
  5568. If (I<2) or (I=Length(AValue)) then
  5569. DatabaseErrorFmt(SInvalidDisplayValues,[AValue]);
  5570. FdisplayValues:=AValue;
  5571. // Store display values and their uppercase equivalents;
  5572. FDisplays[False,True]:=Copy(AValue,1,I-1);
  5573. FDisplays[True,True]:=UpperCase(FDisplays[False,True]);
  5574. FDisplays[False,False]:=Copy(AValue,I+1,Length(AValue)-i);
  5575. FDisplays[True,False]:=UpperCase(FDisplays[False,False]);
  5576. PropertyChanged(True);
  5577. end;
  5578. end;
  5579. { TDateTimeField }
  5580. procedure TDateTimeField.SetDisplayFormat(const AValue: string);
  5581. begin
  5582. if FDisplayFormat<>AValue then begin
  5583. FDisplayFormat:=AValue;
  5584. PropertyChanged(True);
  5585. end;
  5586. end;
  5587. function TDateTimeField.ConvertToDateTime(aValue: JSValue; aRaiseError: Boolean): TDateTime;
  5588. begin
  5589. if Assigned(Dataset) then
  5590. Result:=Dataset.ConvertToDateTime(aValue,aRaiseError)
  5591. else
  5592. Result:=TDataset.DefaultConvertToDateTime(aValue,aRaiseError);
  5593. end;
  5594. function TDateTimeField.DateTimeToNativeDateTime(aValue: TDateTime): JSValue;
  5595. begin
  5596. if Assigned(Dataset) then
  5597. Result:=Dataset.ConvertDateTimeToNative(aValue)
  5598. else
  5599. Result:=TDataset.DefaultConvertDateTimeToNative(aValue);
  5600. end;
  5601. function TDateTimeField.GetAsDateTime: TDateTime;
  5602. begin
  5603. Result:=ConvertToDateTime(GetData,False);
  5604. end;
  5605. procedure TDateTimeField.SetVarValue(const AValue: JSValue);
  5606. begin
  5607. SetAsDateTime(ConvertToDateTime(aValue,True));
  5608. end;
  5609. function TDateTimeField.GetAsJSValue: JSValue;
  5610. begin
  5611. Result:=GetData;
  5612. if Not isString(Result) then
  5613. Result:=Null;
  5614. end;
  5615. function TDateTimeField.GetDataSize: Integer;
  5616. begin
  5617. Result:=inherited GetDataSize;
  5618. end;
  5619. function TDateTimeField.GetAsFloat: Double;
  5620. begin
  5621. Result:=GetAsdateTime;
  5622. end;
  5623. function TDateTimeField.GetAsString: string;
  5624. begin
  5625. GetText(Result,False);
  5626. end;
  5627. Procedure TDateTimeField.GetText(var AText: string; ADisplayText: Boolean);
  5628. var
  5629. R : TDateTime;
  5630. F : String;
  5631. begin
  5632. R:=ConvertToDateTime(GetData,false);
  5633. If (R=0) then
  5634. AText:=''
  5635. else
  5636. begin
  5637. If (ADisplayText) and (Length(FDisplayFormat)<>0) then
  5638. F:=FDisplayFormat
  5639. else
  5640. Case DataType of
  5641. ftTime : F:=LongTimeFormat;
  5642. ftDate : F:=ShortDateFormat;
  5643. else
  5644. F:='c'
  5645. end;
  5646. AText:=FormatDateTime(F,R);
  5647. end;
  5648. end;
  5649. procedure TDateTimeField.SetAsDateTime(AValue: TDateTime);
  5650. begin
  5651. SetData(DateTimeToNativeDateTime(aValue));
  5652. end;
  5653. procedure TDateTimeField.SetAsFloat(AValue: Double);
  5654. begin
  5655. SetAsDateTime(AValue);
  5656. end;
  5657. procedure TDateTimeField.SetAsString(const AValue: string);
  5658. var R : TDateTime;
  5659. begin
  5660. if AValue<>'' then
  5661. begin
  5662. R:=StrToDateTime(AValue);
  5663. SetData(DateTimeToNativeDateTime(R));
  5664. end
  5665. else
  5666. SetData(Null);
  5667. end;
  5668. constructor TDateTimeField.Create(AOwner: TComponent);
  5669. begin
  5670. Inherited Create(AOwner);
  5671. SetDataType(ftDateTime);
  5672. end;
  5673. { TDateField }
  5674. constructor TDateField.Create(AOwner: TComponent);
  5675. begin
  5676. Inherited Create(AOwner);
  5677. SetDataType(ftDate);
  5678. end;
  5679. { TTimeField }
  5680. constructor TTimeField.Create(AOwner: TComponent);
  5681. begin
  5682. Inherited Create(AOwner);
  5683. SetDataType(ftTime);
  5684. end;
  5685. procedure TTimeField.SetAsString(const AValue: string);
  5686. var
  5687. R : TDateTime;
  5688. begin
  5689. if AValue<>'' then
  5690. begin
  5691. R:=StrToTime(AValue);
  5692. SetData(DateTimeToNativeDateTime(R));
  5693. end
  5694. else
  5695. SetData(Null);
  5696. end;
  5697. { TBinaryField }
  5698. class procedure TBinaryField.CheckTypeSize(AValue: Longint);
  5699. begin
  5700. // Just check for really invalid stuff; actual size is
  5701. // dependent on the record...
  5702. If AValue<1 then
  5703. DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
  5704. end;
  5705. Function TBinaryField.BlobToBytes(aValue : JSValue) : TBytes;
  5706. begin
  5707. if Assigned(Dataset) then
  5708. Result:=DataSet.BlobDataToBytes(aValue)
  5709. else
  5710. Result:=TDataSet.DefaultBlobDataToBytes(aValue)
  5711. end;
  5712. Function TBinaryField.BytesToBlob(aValue : TBytes) : JSValue;
  5713. begin
  5714. if Assigned(Dataset) then
  5715. Result:=DataSet.BytesToBlobData(aValue)
  5716. else
  5717. Result:=TDataSet.DefaultBytesToBlobData(aValue)
  5718. end;
  5719. function TBinaryField.GetAsString: string;
  5720. var
  5721. V : JSValue;
  5722. S : TBytes;
  5723. I : Integer;
  5724. begin
  5725. Result := '';
  5726. V:=GetData;
  5727. if V<>Null then
  5728. begin
  5729. S:=BlobToBytes(V);
  5730. For I:=0 to Length(S) do
  5731. TJSString(Result).Concat(TJSString.fromCharCode(S[I]));
  5732. end;
  5733. end;
  5734. function TBinaryField.GetAsJSValue: JSValue;
  5735. begin
  5736. Result:=GetData;
  5737. end;
  5738. function TBinaryField.GetValue(var AValue: TBytes): Boolean;
  5739. var
  5740. V : JSValue;
  5741. begin
  5742. V:=GetData;
  5743. Result:=(V<>Null);
  5744. if Result then
  5745. AValue:=BlobToBytes(V)
  5746. else
  5747. SetLength(AValue,0);
  5748. end;
  5749. procedure TBinaryField.SetAsString(const AValue: string);
  5750. var
  5751. B : TBytes;
  5752. i : Integer;
  5753. begin
  5754. SetLength(B, Length(aValue));
  5755. For I:=1 to Length(aValue) do
  5756. B[i-1]:=Ord(aValue[i]);
  5757. SetAsBytes(B);
  5758. end;
  5759. procedure TBinaryField.SetVarValue(const AValue: JSValue);
  5760. var
  5761. B: TBytes;
  5762. I,Len: integer;
  5763. begin
  5764. if IsArray(AValue) then
  5765. begin
  5766. Len:=Length(TJSValueDynArray(AValue));
  5767. SetLength(B, Len);
  5768. For I:=1 to Len-1 do
  5769. B[i]:=TBytes(AValue)[i];
  5770. SetAsBytes(B);
  5771. end
  5772. else if IsString(AValue) then
  5773. SetAsString(String(AValue))
  5774. else
  5775. RaiseAccessError('Blob');
  5776. end;
  5777. constructor TBinaryField.Create(AOwner: TComponent);
  5778. begin
  5779. Inherited Create(AOwner);
  5780. end;
  5781. { TBlobField }
  5782. constructor TBlobField.Create(AOwner: TComponent);
  5783. begin
  5784. Inherited Create(AOwner);
  5785. SetDataType(ftBlob);
  5786. end;
  5787. procedure TBlobField.Clear;
  5788. begin
  5789. SetData(Null);
  5790. end;
  5791. (*
  5792. function TBlobField.GetBlobType: TBlobType;
  5793. begin
  5794. Result:=ftBlob;
  5795. end;
  5796. procedure TBlobField.SetBlobType(AValue: TBlobType);
  5797. begin
  5798. SetFieldType(TFieldType(AValue));
  5799. end;
  5800. *)
  5801. function TBlobField.GetBlobSize: Longint;
  5802. var
  5803. B : TBytes;
  5804. begin
  5805. B:=GetAsBytes;
  5806. Result:=Length(B);
  5807. end;
  5808. function TBlobField.GetIsNull: Boolean;
  5809. begin
  5810. if Not Modified then
  5811. Result:= inherited GetIsNull
  5812. else
  5813. Result:=GetBlobSize=0;
  5814. end;
  5815. procedure TBlobField.GetText(var AText: string; ADisplayText: Boolean);
  5816. begin
  5817. AText := inherited GetAsString;
  5818. end;
  5819. class function TBlobField.IsBlob: Boolean;
  5820. begin
  5821. Result:=True;
  5822. end;
  5823. procedure TBlobField.SetFieldType(AValue: TFieldType);
  5824. begin
  5825. if AValue in ftBlobTypes then
  5826. SetDataType(AValue);
  5827. end;
  5828. { TMemoField }
  5829. constructor TMemoField.Create(AOwner: TComponent);
  5830. begin
  5831. inherited Create(AOwner);
  5832. SetDataType(ftMemo);
  5833. end;
  5834. { TVariantField }
  5835. constructor TVariantField.Create(AOwner: TComponent);
  5836. begin
  5837. inherited Create(AOwner);
  5838. SetDataType(ftVariant);
  5839. end;
  5840. class procedure TVariantField.CheckTypeSize(aValue: Integer);
  5841. begin
  5842. { empty }
  5843. end;
  5844. function TVariantField.GetAsBoolean: Boolean;
  5845. begin
  5846. Result :=GetAsJSValue=True;
  5847. end;
  5848. function TVariantField.GetAsDateTime: TDateTime;
  5849. Var
  5850. V : JSValue;
  5851. begin
  5852. V:=GetData;
  5853. if Assigned(Dataset) then
  5854. Result:=Dataset.ConvertToDateTime(V,True)
  5855. else
  5856. Result:=TDataset.DefaultConvertToDateTime(V,True)
  5857. end;
  5858. function TVariantField.GetAsFloat: Double;
  5859. Var
  5860. V : JSValue;
  5861. begin
  5862. V:=GetData;
  5863. if isNumber(V) then
  5864. Result:=Double(V)
  5865. else if isString(V) then
  5866. Result:=parsefloat(String(V))
  5867. else
  5868. RaiseAccessError('Variant');
  5869. end;
  5870. function TVariantField.GetAsInteger: Longint;
  5871. Var
  5872. V : JSValue;
  5873. begin
  5874. V:=GetData;
  5875. if isInteger(V) then
  5876. Result:=Integer(V)
  5877. else if isString(V) then
  5878. Result:=parseInt(String(V))
  5879. else
  5880. RaiseAccessError('Variant');
  5881. end;
  5882. function TVariantField.GetAsString: string;
  5883. Var
  5884. V : JSValue;
  5885. begin
  5886. V:=GetData;
  5887. if isInteger(V) then
  5888. Result:=IntToStr(Integer(V))
  5889. else if isNumber(V) then
  5890. Result:=FloatToStr(Double(V))
  5891. else if isString(V) then
  5892. Result:=String(V)
  5893. else
  5894. RaiseAccessError('Variant');
  5895. end;
  5896. function TVariantField.GetAsJSValue: JSValue;
  5897. begin
  5898. Result:=GetData;
  5899. end;
  5900. procedure TVariantField.SetAsBoolean(aValue: Boolean);
  5901. begin
  5902. SetVarValue(aValue);
  5903. end;
  5904. procedure TVariantField.SetAsDateTime(aValue: TDateTime);
  5905. begin
  5906. SetVarValue(aValue);
  5907. end;
  5908. procedure TVariantField.SetAsFloat(aValue: Double);
  5909. begin
  5910. SetVarValue(aValue);
  5911. end;
  5912. procedure TVariantField.SetAsInteger(AValue: Longint);
  5913. begin
  5914. SetVarValue(aValue);
  5915. end;
  5916. procedure TVariantField.SetAsString(const aValue: string);
  5917. begin
  5918. SetVarValue(aValue);
  5919. end;
  5920. procedure TVariantField.SetVarValue(const aValue: JSValue);
  5921. begin
  5922. SetData(aValue);
  5923. end;
  5924. { TFieldsEnumerator }
  5925. function TFieldsEnumerator.GetCurrent: TField;
  5926. begin
  5927. Result := FFields[FPosition];
  5928. end;
  5929. constructor TFieldsEnumerator.Create(AFields: TFields);
  5930. begin
  5931. inherited Create;
  5932. FFields := AFields;
  5933. FPosition := -1;
  5934. end;
  5935. function TFieldsEnumerator.MoveNext: Boolean;
  5936. begin
  5937. inc(FPosition);
  5938. Result := FPosition < FFields.Count;
  5939. end;
  5940. { TFields }
  5941. constructor TFields.Create(ADataset: TDataset);
  5942. begin
  5943. FDataSet:=ADataset;
  5944. FFieldList:=TFpList.Create;
  5945. FValidFieldKinds:=[fkData..fkInternalcalc];
  5946. end;
  5947. destructor TFields.Destroy;
  5948. begin
  5949. if Assigned(FFieldList) then
  5950. Clear;
  5951. FreeAndNil(FFieldList);
  5952. inherited Destroy;
  5953. end;
  5954. procedure TFields.ClearFieldDefs;
  5955. Var
  5956. i : Integer;
  5957. begin
  5958. For I:=0 to Count-1 do
  5959. Fields[i].FFieldDef:=Nil;
  5960. end;
  5961. procedure TFields.Changed;
  5962. begin
  5963. // Removed FDataSet.Active check, needed for Persistent fields (see bug ID 30954)
  5964. if (FDataSet <> nil) and not (csDestroying in FDataSet.ComponentState) then
  5965. FDataSet.DataEvent(deFieldListChange, 0);
  5966. If Assigned(FOnChange) then
  5967. FOnChange(Self);
  5968. end;
  5969. procedure TFields.CheckfieldKind(Fieldkind: TFieldKind; Field: TField);
  5970. begin
  5971. If Not (FieldKind in ValidFieldKinds) Then
  5972. DatabaseErrorFmt(SInvalidFieldKind,[Field.FieldName]);
  5973. end;
  5974. function TFields.GetCount: Longint;
  5975. begin
  5976. Result:=FFieldList.Count;
  5977. end;
  5978. function TFields.GetField(Index: Integer): TField;
  5979. begin
  5980. Result:=Tfield(FFieldList[Index]);
  5981. end;
  5982. procedure TFields.SetField(Index: Integer; Value: TField);
  5983. begin
  5984. Fields[Index].Assign(Value);
  5985. end;
  5986. procedure TFields.SetFieldIndex(Field: TField; Value: Integer);
  5987. var Old : Longint;
  5988. begin
  5989. Old := FFieldList.indexOf(Field);
  5990. If Old=-1 then
  5991. Exit;
  5992. // Check value
  5993. If Value<0 Then Value:=0;
  5994. If Value>=Count then Value:=Count-1;
  5995. If Value<>Old then
  5996. begin
  5997. FFieldList.Delete(Old);
  5998. FFieldList.Insert(Value,Field);
  5999. Field.PropertyChanged(True);
  6000. Changed;
  6001. end;
  6002. end;
  6003. procedure TFields.Add(Field: TField);
  6004. begin
  6005. CheckFieldName(Field.FieldName);
  6006. FFieldList.Add(Field);
  6007. Field.FFields:=Self;
  6008. Changed;
  6009. end;
  6010. procedure TFields.CheckFieldName(const Value: String);
  6011. begin
  6012. If FindField(Value)<>Nil then
  6013. DataBaseErrorFmt(SDuplicateFieldName,[Value],FDataset);
  6014. end;
  6015. procedure TFields.CheckFieldNames(const Value: String);
  6016. var
  6017. N: String;
  6018. StrPos: Integer;
  6019. begin
  6020. if Value = '' then
  6021. Exit;
  6022. StrPos := 1;
  6023. repeat
  6024. N := ExtractFieldName(Value, StrPos);
  6025. // Will raise an error if no such field...
  6026. FieldByName(N);
  6027. until StrPos > Length(Value);
  6028. end;
  6029. procedure TFields.Clear;
  6030. var
  6031. AField: TField;
  6032. begin
  6033. while FFieldList.Count > 0 do
  6034. begin
  6035. AField := TField(FFieldList.Last);
  6036. AField.FDataSet := Nil;
  6037. AField.Free;
  6038. FFieldList.Delete(FFieldList.Count - 1);
  6039. end;
  6040. Changed;
  6041. end;
  6042. function TFields.FindField(const Value: String): TField;
  6043. var S : String;
  6044. I : longint;
  6045. begin
  6046. S:=UpperCase(Value);
  6047. For I:=0 To FFieldList.Count-1 do
  6048. begin
  6049. Result:=TField(FFieldList[I]);
  6050. if S=UpperCase(Result.FieldName) then
  6051. begin
  6052. {$ifdef dsdebug}
  6053. Writeln ('Found field ',Value);
  6054. {$endif}
  6055. Exit;
  6056. end;
  6057. end;
  6058. Result:=Nil;
  6059. end;
  6060. function TFields.FieldByName(const Value: String): TField;
  6061. begin
  6062. Result:=FindField(Value);
  6063. If result=Nil then
  6064. DatabaseErrorFmt(SFieldNotFound,[Value],FDataset);
  6065. end;
  6066. function TFields.FieldByNumber(FieldNo: Integer): TField;
  6067. var i : Longint;
  6068. begin
  6069. For I:=0 to FFieldList.Count-1 do
  6070. begin
  6071. Result:=TField(FFieldList[I]);
  6072. if FieldNo=Result.FieldNo then
  6073. Exit;
  6074. end;
  6075. Result:=Nil;
  6076. end;
  6077. function TFields.GetEnumerator: TFieldsEnumerator;
  6078. begin
  6079. Result:=TFieldsEnumerator.Create(Self);
  6080. end;
  6081. procedure TFields.GetFieldNames(Values: TStrings);
  6082. var i : longint;
  6083. begin
  6084. Values.Clear;
  6085. For I:=0 to FFieldList.Count-1 do
  6086. Values.Add(Tfield(FFieldList[I]).FieldName);
  6087. end;
  6088. function TFields.IndexOf(Field: TField): Longint;
  6089. begin
  6090. Result:=FFieldList.IndexOf(Field);
  6091. end;
  6092. procedure TFields.Remove(Value : TField);
  6093. begin
  6094. FFieldList.Remove(Value);
  6095. Value.FFields := nil;
  6096. Changed;
  6097. end;
  6098. { ---------------------------------------------------------------------
  6099. TDatalink
  6100. ---------------------------------------------------------------------}
  6101. Constructor TDataLink.Create;
  6102. begin
  6103. Inherited Create;
  6104. FBufferCount:=1;
  6105. FFirstRecord := 0;
  6106. FDataSource := nil;
  6107. FDatasourceFixed:=False;
  6108. end;
  6109. Destructor TDataLink.Destroy;
  6110. begin
  6111. Factive:=False;
  6112. FEditing:=False;
  6113. FDataSourceFixed:=False;
  6114. DataSource:=Nil;
  6115. Inherited Destroy;
  6116. end;
  6117. Procedure TDataLink.ActiveChanged;
  6118. begin
  6119. FFirstRecord := 0;
  6120. end;
  6121. Procedure TDataLink.CheckActiveAndEditing;
  6122. Var
  6123. B : Boolean;
  6124. begin
  6125. B:=Assigned(DataSource) and Not (DataSource.State in [dsInactive,dsOpening]);
  6126. If B<>FActive then
  6127. begin
  6128. FActive:=B;
  6129. ActiveChanged;
  6130. end;
  6131. B:=Assigned(DataSource) and (DataSource.State in dsEditModes) and Not FReadOnly;
  6132. If B<>FEditing Then
  6133. begin
  6134. FEditing:=B;
  6135. EditingChanged;
  6136. end;
  6137. end;
  6138. Procedure TDataLink.CheckBrowseMode;
  6139. begin
  6140. end;
  6141. Function TDataLink.CalcFirstRecord(Index : Integer) : Integer;
  6142. begin
  6143. if DataSource.DataSet.FActiveRecord > FFirstRecord + Index + FBufferCount - 1 then
  6144. Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index + FBufferCount - 1)
  6145. else if DataSource.DataSet.FActiveRecord < FFirstRecord + Index then
  6146. Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index)
  6147. else Result := 0;
  6148. Inc(FFirstRecord, Index + Result);
  6149. end;
  6150. Procedure TDataLink.CalcRange;
  6151. var
  6152. aMax, aMin: integer;
  6153. begin
  6154. aMin:= DataSet.FActiveRecord - FBufferCount + 1;
  6155. If aMin < 0 Then aMin:= 0;
  6156. aMax:= Dataset.FBufferCount - FBufferCount;
  6157. If aMax < 0 then aMax:= 0;
  6158. If aMax>DataSet.FActiveRecord Then aMax:=DataSet.FActiveRecord;
  6159. If FFirstRecord < aMin Then FFirstRecord:= aMin;
  6160. If FFirstrecord > aMax Then FFirstRecord:= aMax;
  6161. If (FfirstRecord<>0) And
  6162. (DataSet.FActiveRecord - FFirstRecord < FBufferCount -1) Then
  6163. Dec(FFirstRecord, 1);
  6164. end;
  6165. Procedure TDataLink.DataEvent(Event: TDataEvent; Info: JSValue);
  6166. begin
  6167. Case Event of
  6168. deFieldChange, deRecordChange:
  6169. If Not FUpdatingRecord then
  6170. RecordChanged(TField(Info));
  6171. deDataSetChange: begin
  6172. SetActive(DataSource.DataSet.Active);
  6173. CalcRange;
  6174. CalcFirstRecord(Integer(Info));
  6175. DatasetChanged;
  6176. end;
  6177. deDataSetScroll: DatasetScrolled(CalcFirstRecord(Integer(Info)));
  6178. deLayoutChange: begin
  6179. CalcFirstRecord(Integer(Info));
  6180. LayoutChanged;
  6181. end;
  6182. deUpdateRecord: UpdateRecord;
  6183. deUpdateState: CheckActiveAndEditing;
  6184. deCheckBrowseMode: CheckBrowseMode;
  6185. deFocusControl:
  6186. FocusControl(Info);
  6187. end;
  6188. end;
  6189. Procedure TDataLink.DataSetChanged;
  6190. begin
  6191. RecordChanged(Nil);
  6192. end;
  6193. Procedure TDataLink.DataSetScrolled(Distance: Integer);
  6194. begin
  6195. DataSetChanged;
  6196. end;
  6197. Procedure TDataLink.EditingChanged;
  6198. begin
  6199. end;
  6200. Procedure TDataLink.FocusControl(Field: JSValue);
  6201. begin
  6202. end;
  6203. Function TDataLink.GetActiveRecord: Integer;
  6204. begin
  6205. Result:=Dataset.FActiveRecord - FFirstRecord;
  6206. end;
  6207. Function TDatalink.GetDataSet : TDataset;
  6208. begin
  6209. If Assigned(Datasource) then
  6210. Result:=DataSource.DataSet
  6211. else
  6212. Result:=Nil;
  6213. end;
  6214. Function TDataLink.GetBOF: Boolean;
  6215. begin
  6216. Result:=DataSet.BOF
  6217. end;
  6218. Function TDataLink.GetBufferCount: Integer;
  6219. begin
  6220. Result:=FBufferCount;
  6221. end;
  6222. Function TDataLink.GetEOF: Boolean;
  6223. begin
  6224. Result:=DataSet.EOF
  6225. end;
  6226. Function TDataLink.GetRecordCount: Integer;
  6227. begin
  6228. Result:=Dataset.FRecordCount;
  6229. If Result>BufferCount then
  6230. Result:=BufferCount;
  6231. end;
  6232. Procedure TDataLink.LayoutChanged;
  6233. begin
  6234. DataSetChanged;
  6235. end;
  6236. Function TDataLink.MoveBy(Distance: Integer): Integer;
  6237. begin
  6238. Result:=DataSet.MoveBy(Distance);
  6239. end;
  6240. Procedure TDataLink.RecordChanged(Field: TField);
  6241. begin
  6242. end;
  6243. Procedure TDataLink.SetActiveRecord(Value: Integer);
  6244. begin
  6245. {$ifdef dsdebug}
  6246. Writeln('Datalink. Setting active record to ',Value,' with firstrecord ',ffirstrecord);
  6247. {$endif}
  6248. Dataset.FActiveRecord:=Value + FFirstRecord;
  6249. end;
  6250. Procedure TDataLink.SetBufferCount(Value: Integer);
  6251. begin
  6252. If FBufferCount<>Value then
  6253. begin
  6254. FBufferCount:=Value;
  6255. if Active then begin
  6256. DataSet.RecalcBufListSize;
  6257. CalcRange;
  6258. end;
  6259. end;
  6260. end;
  6261. procedure TDataLink.SetActive(AActive: Boolean);
  6262. begin
  6263. if Active <> AActive then
  6264. begin
  6265. FActive := AActive;
  6266. // !!!: Set internal state
  6267. ActiveChanged;
  6268. end;
  6269. end;
  6270. Procedure TDataLink.SetDataSource(Value : TDatasource);
  6271. begin
  6272. if FDataSource = Value then
  6273. Exit;
  6274. if not FDataSourceFixed then
  6275. begin
  6276. if Assigned(DataSource) then
  6277. Begin
  6278. DataSource.UnregisterDatalink(Self);
  6279. FDataSource := nil;
  6280. CheckActiveAndEditing;
  6281. End;
  6282. FDataSource := Value;
  6283. if Assigned(DataSource) then
  6284. begin
  6285. DataSource.RegisterDatalink(Self);
  6286. CheckActiveAndEditing;
  6287. End;
  6288. end;
  6289. end;
  6290. Procedure TDatalink.SetReadOnly(Value : Boolean);
  6291. begin
  6292. If FReadOnly<>Value then
  6293. begin
  6294. FReadOnly:=Value;
  6295. CheckActiveAndEditing;
  6296. end;
  6297. end;
  6298. Procedure TDataLink.UpdateData;
  6299. begin
  6300. end;
  6301. Function TDataLink.Edit: Boolean;
  6302. begin
  6303. If Not FReadOnly then
  6304. DataSource.Edit;
  6305. // Triggered event will set FEditing
  6306. Result:=FEditing;
  6307. end;
  6308. Procedure TDataLink.UpdateRecord;
  6309. begin
  6310. FUpdatingRecord:=True;
  6311. Try
  6312. UpdateData;
  6313. finally
  6314. FUpdatingRecord:=False;
  6315. end;
  6316. end;
  6317. { ---------------------------------------------------------------------
  6318. TDetailDataLink
  6319. ---------------------------------------------------------------------}
  6320. Function TDetailDataLink.GetDetailDataSet: TDataSet;
  6321. begin
  6322. Result := nil;
  6323. end;
  6324. { ---------------------------------------------------------------------
  6325. TMasterDataLink
  6326. ---------------------------------------------------------------------}
  6327. constructor TMasterDataLink.Create(ADataSet: TDataSet);
  6328. begin
  6329. inherited Create;
  6330. FDetailDataSet:=ADataSet;
  6331. FFields:=TList.Create;
  6332. end;
  6333. destructor TMasterDataLink.Destroy;
  6334. begin
  6335. FFields.Free;
  6336. inherited Destroy;
  6337. end;
  6338. Procedure TMasterDataLink.ActiveChanged;
  6339. begin
  6340. FFields.Clear;
  6341. if Active then
  6342. try
  6343. DataSet.GetFieldList(FFields, FFieldNames);
  6344. except
  6345. FFields.Clear;
  6346. raise;
  6347. end;
  6348. if FDetailDataSet.Active and not (csDestroying in FDetailDataSet.ComponentState) then
  6349. if Active and (FFields.Count > 0) then
  6350. DoMasterChange
  6351. else
  6352. DoMasterDisable;
  6353. end;
  6354. Procedure TMasterDataLink.CheckBrowseMode;
  6355. begin
  6356. if FDetailDataSet.Active then FDetailDataSet.CheckBrowseMode;
  6357. end;
  6358. Function TMasterDataLink.GetDetailDataSet: TDataSet;
  6359. begin
  6360. Result := FDetailDataSet;
  6361. end;
  6362. Procedure TMasterDataLink.LayoutChanged;
  6363. begin
  6364. ActiveChanged;
  6365. end;
  6366. Procedure TMasterDataLink.RecordChanged(Field: TField);
  6367. begin
  6368. if (DataSource.State <> dsSetKey) and FDetailDataSet.Active and
  6369. (FFields.Count > 0) and ((Field = nil) or
  6370. (FFields.IndexOf(Field) >= 0)) then
  6371. DoMasterChange;
  6372. end;
  6373. procedure TMasterDatalink.SetFieldNames(const Value: string);
  6374. begin
  6375. if FFieldNames <> Value then
  6376. begin
  6377. FFieldNames := Value;
  6378. ActiveChanged;
  6379. end;
  6380. end;
  6381. Procedure TMasterDataLink.DoMasterDisable;
  6382. begin
  6383. if Assigned(FOnMasterDisable) then
  6384. FOnMasterDisable(Self);
  6385. end;
  6386. Procedure TMasterDataLink.DoMasterChange;
  6387. begin
  6388. If Assigned(FOnMasterChange) then
  6389. FOnMasterChange(Self);
  6390. end;
  6391. { ---------------------------------------------------------------------
  6392. TMasterParamsDataLink
  6393. ---------------------------------------------------------------------}
  6394. constructor TMasterParamsDataLink.Create(ADataSet: TDataSet);
  6395. Var
  6396. P : TParams;
  6397. begin
  6398. inherited Create(ADataset);
  6399. If (ADataset<>Nil) then
  6400. begin
  6401. P:=TParams(GetObjectProp(ADataset,'Params',TParams));
  6402. if (P<>Nil) then
  6403. Params:=P;
  6404. end;
  6405. end;
  6406. Procedure TMasterParamsDataLink.SetParams(AValue : TParams);
  6407. begin
  6408. FParams:=AValue;
  6409. If (AValue<>Nil) then
  6410. RefreshParamNames;
  6411. end;
  6412. Procedure TMasterParamsDataLink.RefreshParamNames;
  6413. Var
  6414. FN : String;
  6415. DS : TDataset;
  6416. F : TField;
  6417. I : Integer;
  6418. P : TParam;
  6419. begin
  6420. FN:='';
  6421. DS:=Dataset;
  6422. If Assigned(FParams) then
  6423. begin
  6424. F:=Nil;
  6425. For I:=0 to FParams.Count-1 do
  6426. begin
  6427. P:=FParams[i];
  6428. if not P.Bound then
  6429. begin
  6430. If Assigned(DS) then
  6431. F:=DS.FindField(P.Name);
  6432. If (Not Assigned(DS)) or (not DS.Active) or (F<>Nil) then
  6433. begin
  6434. If (FN<>'') then
  6435. FN:=FN+';';
  6436. FN:=FN+P.Name;
  6437. end;
  6438. end;
  6439. end;
  6440. end;
  6441. FieldNames:=FN;
  6442. end;
  6443. Procedure TMasterParamsDataLink.CopyParamsFromMaster(CopyBound : Boolean);
  6444. begin
  6445. if Assigned(FParams) then
  6446. FParams.CopyParamValuesFromDataset(Dataset,CopyBound);
  6447. end;
  6448. Procedure TMasterParamsDataLink.DoMasterDisable;
  6449. begin
  6450. Inherited;
  6451. // If master dataset is closing, leave detail dataset intact (Delphi compatible behavior)
  6452. // If master dataset is reopened, relationship will be reestablished
  6453. end;
  6454. Procedure TMasterParamsDataLink.DoMasterChange;
  6455. begin
  6456. Inherited;
  6457. if Assigned(Params) and Assigned(DetailDataset) and DetailDataset.Active then
  6458. begin
  6459. DetailDataSet.CheckBrowseMode;
  6460. DetailDataset.Close;
  6461. DetailDataset.Open;
  6462. end;
  6463. end;
  6464. { ---------------------------------------------------------------------
  6465. TDatasource
  6466. ---------------------------------------------------------------------}
  6467. Constructor TDataSource.Create(AOwner: TComponent);
  6468. begin
  6469. Inherited Create(AOwner);
  6470. FDatalinks := TList.Create;
  6471. FEnabled := True;
  6472. FAutoEdit := True;
  6473. end;
  6474. Destructor TDataSource.Destroy;
  6475. begin
  6476. FOnStateCHange:=Nil;
  6477. Dataset:=Nil;
  6478. With FDataLinks do
  6479. While Count>0 do
  6480. TDatalink(Items[Count - 1]).DataSource:=Nil;
  6481. FDatalinks.Free;
  6482. inherited Destroy;
  6483. end;
  6484. Procedure TDatasource.Edit;
  6485. begin
  6486. If (State=dsBrowse) and AutoEdit Then
  6487. Dataset.Edit;
  6488. end;
  6489. Function TDataSource.IsLinkedTo(ADataSet: TDataSet): Boolean;
  6490. begin
  6491. Result:=False;
  6492. end;
  6493. procedure TDatasource.DistributeEvent(Event: TDataEvent; Info: JSValue);
  6494. Var
  6495. i : Longint;
  6496. begin
  6497. With FDatalinks do
  6498. begin
  6499. For I:=0 to Count-1 do
  6500. With TDatalink(Items[i]) do
  6501. If Not VisualControl Then
  6502. DataEvent(Event,Info);
  6503. For I:=0 to Count-1 do
  6504. With TDatalink(Items[i]) do
  6505. If VisualControl Then
  6506. DataEvent(Event,Info);
  6507. end;
  6508. end;
  6509. procedure TDatasource.RegisterDataLink(DataLink: TDataLink);
  6510. begin
  6511. FDatalinks.Add(DataLink);
  6512. if Assigned(DataSet) then
  6513. DataSet.RecalcBufListSize;
  6514. end;
  6515. procedure TDatasource.SetDataSet(ADataSet: TDataSet);
  6516. begin
  6517. If FDataset<>Nil Then
  6518. Begin
  6519. FDataset.UnRegisterDataSource(Self);
  6520. FDataSet:=nil;
  6521. ProcessEvent(deUpdateState,0);
  6522. End;
  6523. If ADataset<>Nil Then
  6524. begin
  6525. ADataset.RegisterDatasource(Self);
  6526. FDataSet:=ADataset;
  6527. ProcessEvent(deUpdateState,0);
  6528. End;
  6529. end;
  6530. procedure TDatasource.SetEnabled(Value: Boolean);
  6531. begin
  6532. FEnabled:=Value;
  6533. end;
  6534. Procedure TDatasource.DoDataChange (Info : Pointer);
  6535. begin
  6536. If Assigned(OnDataChange) Then
  6537. OnDataChange(Self,TField(Info));
  6538. end;
  6539. Procedure TDatasource.DoStateChange;
  6540. begin
  6541. If Assigned(OnStateChange) Then
  6542. OnStateChange(Self);
  6543. end;
  6544. Procedure TDatasource.DoUpdateData;
  6545. begin
  6546. If Assigned(OnUpdateData) Then
  6547. OnUpdateData(Self);
  6548. end;
  6549. procedure TDatasource.UnregisterDataLink(DataLink: TDataLink);
  6550. begin
  6551. FDatalinks.Remove(Datalink);
  6552. If Dataset<>Nil then
  6553. DataSet.RecalcBufListSize;
  6554. //Dataset.SetBufListSize(DataLink.BufferCount);
  6555. end;
  6556. procedure TDataSource.ProcessEvent(Event : TDataEvent; Info : JSValue);
  6557. Const
  6558. OnDataChangeEvents = [deRecordChange, deDataSetChange, deDataSetScroll,
  6559. deLayoutChange,deUpdateState];
  6560. Var
  6561. NeedDataChange : Boolean;
  6562. FLastState : TdataSetState;
  6563. begin
  6564. // Special UpdateState handling.
  6565. If Event=deUpdateState then
  6566. begin
  6567. NeedDataChange:=(FState=dsInactive);
  6568. FLastState:=FState;
  6569. If Assigned(Dataset) then
  6570. FState:=Dataset.State
  6571. else
  6572. FState:=dsInactive;
  6573. // Don't do events if nothing changed.
  6574. If FState=FLastState then
  6575. exit;
  6576. end
  6577. else
  6578. NeedDataChange:=True;
  6579. DistributeEvent(Event,Info);
  6580. // Extra handlers
  6581. If Not (csDestroying in ComponentState) then
  6582. begin
  6583. If (Event=deUpdateState) then
  6584. DoStateChange;
  6585. If (Event in OnDataChangeEvents) and
  6586. NeedDataChange Then
  6587. DoDataChange(Nil);
  6588. If (Event = deFieldChange) Then
  6589. DoDataCHange(Pointer(Info));
  6590. If (Event=deUpdateRecord) then
  6591. DoUpdateData;
  6592. end;
  6593. end;
  6594. procedure SkipQuotesString(S : String; var p : integer; QuoteChar : char; EscapeSlash, EscapeRepeat : Boolean);
  6595. var notRepeatEscaped : boolean;
  6596. begin
  6597. Inc(p);
  6598. repeat
  6599. notRepeatEscaped := True;
  6600. while not CharInSet(S[p],[#0, QuoteChar]) do
  6601. begin
  6602. if EscapeSlash and (S[p]='\') and (P<Length(S)) then
  6603. Inc(p,2) // make sure we handle \' and \\ correct
  6604. else
  6605. Inc(p);
  6606. end;
  6607. if S[p]=QuoteChar then
  6608. begin
  6609. Inc(p); // skip final '
  6610. if (S[p]=QuoteChar) and EscapeRepeat then // Handle escaping by ''
  6611. begin
  6612. notRepeatEscaped := False;
  6613. inc(p);
  6614. end
  6615. end;
  6616. until notRepeatEscaped;
  6617. end;
  6618. { TParams }
  6619. Function TParams.GetItem(Index: Integer): TParam;
  6620. begin
  6621. Result:=(Inherited GetItem(Index)) as TParam;
  6622. end;
  6623. Function TParams.GetParamValue(const ParamName: string): JSValue;
  6624. begin
  6625. Result:=ParamByName(ParamName).Value;
  6626. end;
  6627. Procedure TParams.SetItem(Index: Integer; Value: TParam);
  6628. begin
  6629. Inherited SetItem(Index,Value);
  6630. end;
  6631. Procedure TParams.SetParamValue(const ParamName: string; const Value: JSValue);
  6632. begin
  6633. ParamByName(ParamName).Value:=Value;
  6634. end;
  6635. Procedure TParams.AssignTo(Dest: TPersistent);
  6636. begin
  6637. if (Dest is TParams) then
  6638. TParams(Dest).Assign(Self)
  6639. else
  6640. inherited AssignTo(Dest);
  6641. end;
  6642. Function TParams.GetDataSet: TDataSet;
  6643. begin
  6644. If (FOwner is TDataset) Then
  6645. Result:=TDataset(FOwner)
  6646. else
  6647. Result:=Nil;
  6648. end;
  6649. Function TParams.GetOwner: TPersistent;
  6650. begin
  6651. Result:=FOwner;
  6652. end;
  6653. Class Function TParams.ParamClass: TParamClass;
  6654. begin
  6655. Result:=TParam;
  6656. end;
  6657. Constructor TParams.Create(AOwner: TPersistent; AItemClass: TCollectionItemClass
  6658. );
  6659. begin
  6660. Inherited Create(AItemClass);
  6661. FOwner:=AOwner;
  6662. end;
  6663. Constructor TParams.Create(AOwner: TPersistent);
  6664. begin
  6665. Create(AOwner,ParamClass);
  6666. end;
  6667. Constructor TParams.Create;
  6668. begin
  6669. Create(Nil);
  6670. end;
  6671. Procedure TParams.AddParam(Value: TParam);
  6672. begin
  6673. Value.Collection:=Self;
  6674. end;
  6675. Procedure TParams.AssignValues(Value: TParams);
  6676. Var
  6677. I : Integer;
  6678. P,PS : TParam;
  6679. begin
  6680. For I:=0 to Value.Count-1 do
  6681. begin
  6682. PS:=Value[i];
  6683. P:=FindParam(PS.Name);
  6684. If Assigned(P) then
  6685. P.Assign(PS);
  6686. end;
  6687. end;
  6688. Function TParams.CreateParam(FldType: TFieldType; const ParamName: string;
  6689. ParamType: TParamType): TParam;
  6690. begin
  6691. Result:=Add as TParam;
  6692. Result.Name:=ParamName;
  6693. Result.DataType:=FldType;
  6694. Result.ParamType:=ParamType;
  6695. end;
  6696. Function TParams.FindParam(const Value: string): TParam;
  6697. Var
  6698. I : Integer;
  6699. begin
  6700. Result:=Nil;
  6701. I:=Count-1;
  6702. While (Result=Nil) and (I>=0) do
  6703. If (CompareText(Value,Items[i].Name)=0) then
  6704. Result:=Items[i]
  6705. else
  6706. Dec(i);
  6707. end;
  6708. Procedure TParams.GetParamList(List: TList; const ParamNames: string);
  6709. Var
  6710. P: TParam;
  6711. N: String;
  6712. StrPos: Integer;
  6713. begin
  6714. if (ParamNames = '') or (List = nil) then
  6715. Exit;
  6716. StrPos := 1;
  6717. repeat
  6718. N := ExtractFieldName(ParamNames, StrPos);
  6719. P := ParamByName(N);
  6720. List.Add(P);
  6721. until StrPos > Length(ParamNames);
  6722. end;
  6723. Function TParams.IsEqual(Value: TParams): Boolean;
  6724. Var
  6725. I : Integer;
  6726. begin
  6727. Result:=(Value.Count=Count);
  6728. I:=Count-1;
  6729. While Result and (I>=0) do
  6730. begin
  6731. Result:=Items[I].IsEqual(Value[i]);
  6732. Dec(I);
  6733. end;
  6734. end;
  6735. Function TParams.ParamByName(const Value: string): TParam;
  6736. begin
  6737. Result:=FindParam(Value);
  6738. If (Result=Nil) then
  6739. DatabaseErrorFmt(SParameterNotFound,[Value],Dataset);
  6740. end;
  6741. Function TParams.ParseSQL(SQL: String; DoCreate: Boolean): String;
  6742. var pb : TParamBinding;
  6743. rs : string;
  6744. begin
  6745. Result := ParseSQL(SQL,DoCreate,True,True,psInterbase, pb, rs);
  6746. end;
  6747. Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
  6748. EscapeRepeat: Boolean; ParameterStyle: TParamStyle): String;
  6749. var pb : TParamBinding;
  6750. rs : string;
  6751. begin
  6752. Result := ParseSQL(SQL,DoCreate,EscapeSlash,EscapeRepeat,ParameterStyle,pb, rs);
  6753. end;
  6754. Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
  6755. EscapeRepeat: Boolean; ParameterStyle: TParamStyle; out
  6756. ParamBinding: TParambinding): String;
  6757. var rs : string;
  6758. begin
  6759. Result := ParseSQL(SQL,DoCreate,EscapeSlash, EscapeRepeat, ParameterStyle,ParamBinding, rs);
  6760. end;
  6761. function SkipComments(S : String; Var p: Integer; EscapeSlash, EscapeRepeat : Boolean) : Boolean;
  6762. begin
  6763. Result := False;
  6764. case S[P] of
  6765. '''', '"', '`':
  6766. begin
  6767. Result := True;
  6768. // single quote, double quote or backtick delimited string
  6769. SkipQuotesString(S,p, S[p], EscapeSlash, EscapeRepeat);
  6770. end;
  6771. '-': // possible start of -- comment
  6772. begin
  6773. Inc(p);
  6774. if S[p]='-' then // -- comment
  6775. begin
  6776. Result := True;
  6777. repeat // skip until at end of line
  6778. Inc(p);
  6779. until CharInset(S[p],[#10, #13, #0]);
  6780. while CharInSet(S[p],[#10, #13]) do
  6781. Inc(p); // newline is part of comment
  6782. end;
  6783. end;
  6784. '/': // possible start of /* */ comment
  6785. begin
  6786. Inc(p);
  6787. if S[p]='*' then // /* */ comment
  6788. begin
  6789. Result := True;
  6790. Inc(p);
  6791. while p<=Length(S) do
  6792. begin
  6793. if S[p]='*' then // possible end of comment
  6794. begin
  6795. Inc(p);
  6796. if S[p]='/' then Break; // end of comment
  6797. end
  6798. else
  6799. Inc(p);
  6800. end;
  6801. if (P<=Length(s)) and (S[p]='/') then
  6802. Inc(p); // skip final /
  6803. end;
  6804. end;
  6805. end; {case}
  6806. end;
  6807. Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
  6808. EscapeRepeat: Boolean; ParameterStyle: TParamStyle; out
  6809. ParamBinding: TParambinding; out ReplaceString: string): String;
  6810. type
  6811. // used for ParamPart
  6812. TStringPart = record
  6813. Start,Stop:integer;
  6814. end;
  6815. const
  6816. ParamAllocStepSize = 8;
  6817. PAramDelimiters : Array of char = (';',',',' ','(',')',#13,#10,#9,#0,'=','+','-','*','\','/','[',']','|');
  6818. var
  6819. IgnorePart:boolean;
  6820. p,ParamNameStart,BufStart:Integer;
  6821. ParamName:string;
  6822. QuestionMarkParamCount,ParameterIndex,NewLength:integer;
  6823. ParamCount:integer; // actual number of parameters encountered so far;
  6824. // always <= Length(ParamPart) = Length(Parambinding)
  6825. // Parambinding will have length ParamCount in the end
  6826. ParamPart:array of TStringPart; // describe which parts of buf are parameters
  6827. NewQueryLength:integer;
  6828. NewQuery:string;
  6829. NewQueryIndex,BufIndex,CopyLen,i:integer; // Parambinding will have length ParamCount in the end
  6830. tmpParam:TParam;
  6831. begin
  6832. if DoCreate then Clear;
  6833. // Parse the SQL and build ParamBinding
  6834. ParamCount:=0;
  6835. NewQueryLength:=Length(SQL);
  6836. SetLength(ParamPart,ParamAllocStepSize);
  6837. SetLength(ParamBinding,ParamAllocStepSize);
  6838. QuestionMarkParamCount:=0; // number of ? params found in query so far
  6839. ReplaceString := '$';
  6840. if ParameterStyle = psSimulated then
  6841. while pos(ReplaceString,SQL) > 0 do ReplaceString := ReplaceString+'$';
  6842. p:=1;
  6843. BufStart:=p; // used to calculate ParamPart.Start values
  6844. repeat
  6845. while SkipComments(SQL,p,EscapeSlash,EscapeRepeat) do ;
  6846. case SQL[p] of
  6847. ':','?': // parameter
  6848. begin
  6849. IgnorePart := False;
  6850. if SQL[p]=':' then
  6851. begin // find parameter name
  6852. Inc(p);
  6853. if charInSet(SQL[p],[':','=',' ']) then // ignore ::, since some databases uses this as a cast (wb 4813)
  6854. begin
  6855. IgnorePart := True;
  6856. Inc(p);
  6857. end
  6858. else
  6859. begin
  6860. if (SQL[p]='"') then // Check if the parameter-name is between quotes
  6861. begin
  6862. ParamNameStart:=p;
  6863. SkipQuotesString(SQL,p,'"',EscapeSlash,EscapeRepeat);
  6864. // Do not include the quotes in ParamName, but they must be included
  6865. // when the parameter is replaced by some place-holder.
  6866. ParamName:=Copy(SQL,ParamNameStart+1,p-ParamNameStart-2);
  6867. end
  6868. else
  6869. begin
  6870. ParamNameStart:=p;
  6871. while not CharInSet(SQL[p], ParamDelimiters) do
  6872. Inc(p);
  6873. ParamName:=Copy(SQL,ParamNameStart,p-ParamNameStart);
  6874. end;
  6875. end;
  6876. end
  6877. else
  6878. begin
  6879. Inc(p);
  6880. ParamNameStart:=p;
  6881. ParamName:='';
  6882. end;
  6883. if not IgnorePart then
  6884. begin
  6885. Inc(ParamCount);
  6886. if ParamCount>Length(ParamPart) then
  6887. begin
  6888. NewLength:=Length(ParamPart)+ParamAllocStepSize;
  6889. SetLength(ParamPart,NewLength);
  6890. SetLength(ParamBinding,NewLength);
  6891. end;
  6892. if DoCreate then
  6893. begin
  6894. // Check if this is the first occurance of the parameter
  6895. tmpParam := FindParam(ParamName);
  6896. // If so, create the parameter and assign the Parameterindex
  6897. if not assigned(tmpParam) then
  6898. ParameterIndex := CreateParam(ftUnknown, ParamName, ptInput).Index
  6899. else // else only assign the ParameterIndex
  6900. ParameterIndex := tmpParam.Index;
  6901. end
  6902. // else find ParameterIndex
  6903. else
  6904. begin
  6905. if ParamName<>'' then
  6906. ParameterIndex:=ParamByName(ParamName).Index
  6907. else
  6908. begin
  6909. ParameterIndex:=QuestionMarkParamCount;
  6910. Inc(QuestionMarkParamCount);
  6911. end;
  6912. end;
  6913. if ParameterStyle in [psPostgreSQL,psSimulated] then
  6914. begin
  6915. i:=ParameterIndex+1;
  6916. repeat
  6917. inc(NewQueryLength);
  6918. i:=i div 10;
  6919. until i=0;
  6920. end;
  6921. // store ParameterIndex in FParamIndex, ParamPart data
  6922. ParamBinding[ParamCount-1]:=ParameterIndex;
  6923. ParamPart[ParamCount-1].Start:=ParamNameStart-BufStart;
  6924. ParamPart[ParamCount-1].Stop:=p-BufStart+1;
  6925. // update NewQueryLength
  6926. Dec(NewQueryLength,p-ParamNameStart);
  6927. end;
  6928. end;
  6929. #0:
  6930. Break; // end of SQL
  6931. else
  6932. Inc(p);
  6933. end;
  6934. until false;
  6935. SetLength(ParamPart,ParamCount);
  6936. SetLength(ParamBinding,ParamCount);
  6937. if ParamCount<=0 then
  6938. NewQuery:=SQL
  6939. else
  6940. begin
  6941. // replace :ParamName by ? for interbase and by $x for postgresql/psSimulated
  6942. // (using ParamPart array and NewQueryLength)
  6943. if (ParameterStyle = psSimulated) and (length(ReplaceString) > 1) then
  6944. inc(NewQueryLength,(paramcount)*(length(ReplaceString)-1));
  6945. SetLength(NewQuery,NewQueryLength);
  6946. NewQueryIndex:=1;
  6947. BufIndex:=1;
  6948. for i:=0 to High(ParamPart) do
  6949. begin
  6950. CopyLen:=ParamPart[i].Start-BufIndex;
  6951. NewQuery:=NewQuery+Copy(SQL,BufIndex,CopyLen);
  6952. Inc(NewQueryIndex,CopyLen);
  6953. case ParameterStyle of
  6954. psInterbase : begin
  6955. NewQuery:=NewQuery+'?';
  6956. Inc(NewQueryIndex);
  6957. end;
  6958. psPostgreSQL,
  6959. psSimulated : begin
  6960. ParamName := IntToStr(ParamBinding[i]+1);
  6961. NewQuery:=StringOfChar('$',Length(ReplaceString));
  6962. NewQuery:=NewQuery+ParamName;
  6963. end;
  6964. end;
  6965. BufIndex:=ParamPart[i].Stop;
  6966. end;
  6967. CopyLen:=Length(SQL)+1-BufIndex;
  6968. if (CopyLen>0) then
  6969. NewQuery:=NewQuery+Copy(SQL,BufIndex,CopyLen);
  6970. end;
  6971. Result:=NewQuery;
  6972. end;
  6973. Procedure TParams.RemoveParam(Value: TParam);
  6974. begin
  6975. Value.Collection:=Nil;
  6976. end;
  6977. { TParam }
  6978. Function TParam.GetDataSet: TDataSet;
  6979. begin
  6980. If Assigned(Collection) and (Collection is TParams) then
  6981. Result:=TParams(Collection).GetDataset
  6982. else
  6983. Result:=Nil;
  6984. end;
  6985. Function TParam.IsParamStored: Boolean;
  6986. begin
  6987. Result:=Bound;
  6988. end;
  6989. Procedure TParam.AssignParam(Param: TParam);
  6990. begin
  6991. if Not Assigned(Param) then
  6992. begin
  6993. Clear;
  6994. FDataType:=ftunknown;
  6995. FParamType:=ptUnknown;
  6996. Name:='';
  6997. Size:=0;
  6998. Precision:=0;
  6999. NumericScale:=0;
  7000. end
  7001. else
  7002. begin
  7003. FDataType:=Param.DataType;
  7004. if Param.IsNull then
  7005. Clear
  7006. else
  7007. FValue:=Param.FValue;
  7008. FBound:=Param.Bound;
  7009. Name:=Param.Name;
  7010. if (ParamType=ptUnknown) then
  7011. ParamType:=Param.ParamType;
  7012. Size:=Param.Size;
  7013. Precision:=Param.Precision;
  7014. NumericScale:=Param.NumericScale;
  7015. end;
  7016. end;
  7017. Procedure TParam.AssignTo(Dest: TPersistent);
  7018. begin
  7019. if (Dest is TField) then
  7020. AssignToField(TField(Dest))
  7021. else
  7022. inherited AssignTo(Dest);
  7023. end;
  7024. Function TParam.GetAsBoolean: Boolean;
  7025. begin
  7026. If IsNull then
  7027. Result:=False
  7028. else
  7029. Result:=FValue=true;
  7030. end;
  7031. Function TParam.GetAsBytes: TBytes;
  7032. begin
  7033. if IsNull then
  7034. Result:=nil
  7035. else if isArray(FValue) then
  7036. Result:=TBytes(FValue)
  7037. end;
  7038. Function TParam.GetAsDateTime: TDateTime;
  7039. begin
  7040. If IsNull then
  7041. Result:=0.0
  7042. else
  7043. Result:=TDateTime(FValue);
  7044. end;
  7045. Function TParam.GetAsFloat: Double;
  7046. begin
  7047. If IsNull then
  7048. Result:=0.0
  7049. else
  7050. Result:=Double(FValue);
  7051. end;
  7052. Function TParam.GetAsInteger: Longint;
  7053. begin
  7054. If IsNull or not IsInteger(FValue) then
  7055. Result:=0
  7056. else
  7057. Result:=Integer(FValue);
  7058. end;
  7059. Function TParam.GetAsLargeInt: NativeInt;
  7060. begin
  7061. If IsNull or not IsInteger(FValue) then
  7062. Result:=0
  7063. else
  7064. Result:=NativeInt(FValue);
  7065. end;
  7066. Function TParam.GetAsMemo: string;
  7067. begin
  7068. If IsNull or not IsString(FValue) then
  7069. Result:=''
  7070. else
  7071. Result:=String(FValue);
  7072. end;
  7073. Function TParam.GetAsString: string;
  7074. begin
  7075. If IsNull or not IsString(FValue) then
  7076. Result:=''
  7077. else
  7078. Result:=String(FValue);
  7079. end;
  7080. Function TParam.GetAsJSValue: JSValue;
  7081. begin
  7082. if IsNull then
  7083. Result:=Null
  7084. else
  7085. Result:=FValue;
  7086. end;
  7087. Function TParam.GetDisplayName: string;
  7088. begin
  7089. if (FName<>'') then
  7090. Result:=FName
  7091. else
  7092. Result:=inherited GetDisplayName
  7093. end;
  7094. Function TParam.GetIsNull: Boolean;
  7095. begin
  7096. Result:= JS.IsNull(FValue);
  7097. end;
  7098. Function TParam.IsEqual(AValue: TParam): Boolean;
  7099. begin
  7100. Result:=(Name=AValue.Name)
  7101. and (IsNull=AValue.IsNull)
  7102. and (Bound=AValue.Bound)
  7103. and (DataType=AValue.DataType)
  7104. and (ParamType=AValue.ParamType)
  7105. and (GetValueType(FValue)=GetValueType(AValue.FValue))
  7106. and (FValue=AValue.FValue);
  7107. end;
  7108. Procedure TParam.SetAsBlob(const AValue: TBlobData);
  7109. begin
  7110. FDataType:=ftBlob;
  7111. Value:=AValue;
  7112. end;
  7113. Procedure TParam.SetAsBoolean(AValue: Boolean);
  7114. begin
  7115. FDataType:=ftBoolean;
  7116. Value:=AValue;
  7117. end;
  7118. procedure TParam.SetAsBytes(const AValue: TBytes);
  7119. begin
  7120. end;
  7121. Procedure TParam.SetAsDate(const AValue: TDateTime);
  7122. begin
  7123. FDataType:=ftDate;
  7124. Value:=AValue;
  7125. end;
  7126. Procedure TParam.SetAsDateTime(const AValue: TDateTime);
  7127. begin
  7128. FDataType:=ftDateTime;
  7129. Value:=AValue;
  7130. end;
  7131. Procedure TParam.SetAsFloat(const AValue: Double);
  7132. begin
  7133. FDataType:=ftFloat;
  7134. Value:=AValue;
  7135. end;
  7136. Procedure TParam.SetAsInteger(AValue: Longint);
  7137. begin
  7138. FDataType:=ftInteger;
  7139. Value:=AValue;
  7140. end;
  7141. Procedure TParam.SetAsLargeInt(AValue: NativeInt);
  7142. begin
  7143. FDataType:=ftLargeint;
  7144. Value:=AValue;
  7145. end;
  7146. Procedure TParam.SetAsMemo(const AValue: string);
  7147. begin
  7148. FDataType:=ftMemo;
  7149. Value:=AValue;
  7150. end;
  7151. Procedure TParam.SetAsString(const AValue: string);
  7152. begin
  7153. if FDataType <> ftFixedChar then
  7154. FDataType := ftString;
  7155. Value:=AValue;
  7156. end;
  7157. Procedure TParam.SetAsTime(const AValue: TDateTime);
  7158. begin
  7159. FDataType:=ftTime;
  7160. Value:=AValue;
  7161. end;
  7162. Procedure TParam.SetAsJSValue(const AValue: JSValue);
  7163. begin
  7164. FValue:=AValue;
  7165. FBound:=not JS.IsNull(AValue);
  7166. if FBound then
  7167. case GetValueType(aValue) of
  7168. jvtBoolean : FDataType:=ftBoolean;
  7169. jvtInteger : FDataType:=ftInteger;
  7170. jvtFloat : FDataType:=ftFloat;
  7171. jvtObject,jvtArray : FDataType:=ftBlob;
  7172. end;
  7173. end;
  7174. Procedure TParam.SetDataType(AValue: TFieldType);
  7175. begin
  7176. FDataType:=AValue;
  7177. end;
  7178. Procedure TParam.SetText(const AValue: string);
  7179. begin
  7180. Value:=AValue;
  7181. end;
  7182. constructor TParam.Create(ACollection: TCollection);
  7183. begin
  7184. inherited Create(ACollection);
  7185. ParamType:=ptUnknown;
  7186. DataType:=ftUnknown;
  7187. FValue:=Null;
  7188. end;
  7189. constructor TParam.Create(AParams: TParams; AParamType: TParamType);
  7190. begin
  7191. Create(AParams);
  7192. ParamType:=AParamType;
  7193. end;
  7194. Procedure TParam.Assign(Source: TPersistent);
  7195. begin
  7196. if (Source is TParam) then
  7197. AssignParam(TParam(Source))
  7198. else if (Source is TField) then
  7199. AssignField(TField(Source))
  7200. else if (source is TStrings) then
  7201. AsMemo:=TStrings(Source).Text
  7202. else
  7203. inherited Assign(Source);
  7204. end;
  7205. Procedure TParam.AssignField(Field: TField);
  7206. begin
  7207. if Assigned(Field) then
  7208. begin
  7209. // Need TField.Value
  7210. AssignFieldValue(Field,Field.Value);
  7211. Name:=Field.FieldName;
  7212. end
  7213. else
  7214. begin
  7215. Clear;
  7216. Name:='';
  7217. end
  7218. end;
  7219. Procedure TParam.AssignToField(Field : TField);
  7220. begin
  7221. if Assigned(Field) then
  7222. case FDataType of
  7223. ftUnknown : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
  7224. // Need TField.AsSmallInt
  7225. // Need TField.AsWord
  7226. ftInteger,
  7227. ftAutoInc : Field.AsInteger:=AsInteger;
  7228. ftFloat : Field.AsFloat:=AsFloat;
  7229. ftBoolean : Field.AsBoolean:=AsBoolean;
  7230. ftBlob,
  7231. ftString,
  7232. ftMemo,
  7233. ftFixedChar: Field.AsString:=AsString;
  7234. ftTime,
  7235. ftDate,
  7236. ftDateTime : Field.AsDateTime:=AsDateTime;
  7237. end;
  7238. end;
  7239. Procedure TParam.AssignFromField(Field : TField);
  7240. begin
  7241. if Assigned(Field) then
  7242. begin
  7243. FDataType:=Field.DataType;
  7244. case Field.DataType of
  7245. ftUnknown : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
  7246. ftInteger,
  7247. ftAutoInc : AsInteger:=Field.AsInteger;
  7248. ftFloat : AsFloat:=Field.AsFloat;
  7249. ftBoolean : AsBoolean:=Field.AsBoolean;
  7250. ftBlob,
  7251. ftString,
  7252. ftMemo,
  7253. ftFixedChar: AsString:=Field.AsString;
  7254. ftTime,
  7255. ftDate,
  7256. ftDateTime : AsDateTime:=Field.AsDateTime;
  7257. end;
  7258. end;
  7259. end;
  7260. Procedure TParam.AssignFieldValue(Field: TField; const AValue: JSValue);
  7261. begin
  7262. If Assigned(Field) then
  7263. begin
  7264. if (Field.DataType = ftString) and TStringField(Field).FixedChar then
  7265. FDataType := ftFixedChar
  7266. else if (Field.DataType = ftMemo) and (Field.Size > 255) then
  7267. FDataType := ftString
  7268. else
  7269. FDataType := Field.DataType;
  7270. if JS.IsNull(AValue) then
  7271. Clear
  7272. else
  7273. Value:=AValue;
  7274. Size:=Field.DataSize;
  7275. FBound:=True;
  7276. end;
  7277. end;
  7278. Procedure TParam.Clear;
  7279. begin
  7280. FValue:=Null;
  7281. end;
  7282. Procedure TParams.CopyParamValuesFromDataset(ADataSet: TDataSet;
  7283. CopyBound: Boolean);
  7284. Var
  7285. I : Integer;
  7286. P : TParam;
  7287. F : TField;
  7288. begin
  7289. If assigned(ADataSet) then
  7290. For I:=0 to Count-1 do
  7291. begin
  7292. P:=Items[i];
  7293. if CopyBound or (not P.Bound) then
  7294. begin
  7295. // Master dataset must be active and unbound parameters must have fields
  7296. // with same names in master dataset (Delphi compatible behavior)
  7297. F:=ADataSet.FieldByName(P.Name);
  7298. P.AssignField(F);
  7299. If Not CopyBound then
  7300. P.Bound:=False;
  7301. end;
  7302. end;
  7303. end;
  7304. initialization
  7305. end.