db.pas 219 KB

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