db.pas 212 KB

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