db.pas 215 KB

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