123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086108710881089109010911092109310941095109610971098109911001101110211031104110511061107110811091110111111121113111411151116111711181119112011211122112311241125112611271128112911301131113211331134113511361137113811391140114111421143114411451146114711481149115011511152115311541155115611571158115911601161116211631164116511661167116811691170117111721173117411751176117711781179118011811182118311841185118611871188118911901191119211931194119511961197119811991200120112021203120412051206120712081209121012111212121312141215121612171218121912201221122212231224122512261227122812291230123112321233123412351236123712381239124012411242124312441245124612471248124912501251125212531254125512561257125812591260126112621263126412651266126712681269127012711272127312741275127612771278127912801281128212831284128512861287128812891290129112921293129412951296129712981299130013011302130313041305130613071308130913101311131213131314131513161317131813191320132113221323132413251326132713281329133013311332133313341335133613371338133913401341134213431344134513461347134813491350135113521353135413551356135713581359136013611362136313641365136613671368136913701371137213731374137513761377137813791380138113821383138413851386138713881389139013911392139313941395139613971398139914001401140214031404140514061407140814091410141114121413141414151416141714181419142014211422142314241425142614271428142914301431143214331434143514361437143814391440144114421443144414451446144714481449145014511452145314541455145614571458145914601461146214631464146514661467146814691470147114721473147414751476147714781479148014811482148314841485148614871488148914901491149214931494149514961497149814991500150115021503150415051506150715081509151015111512151315141515151615171518151915201521152215231524152515261527152815291530153115321533153415351536153715381539154015411542154315441545154615471548154915501551155215531554155515561557155815591560156115621563156415651566156715681569157015711572157315741575157615771578157915801581158215831584158515861587158815891590159115921593159415951596159715981599160016011602160316041605160616071608160916101611161216131614161516161617161816191620162116221623162416251626162716281629163016311632163316341635163616371638163916401641164216431644164516461647164816491650165116521653165416551656165716581659166016611662166316641665166616671668166916701671167216731674167516761677167816791680168116821683168416851686168716881689169016911692169316941695169616971698169917001701170217031704170517061707170817091710171117121713171417151716171717181719172017211722172317241725172617271728172917301731173217331734173517361737173817391740174117421743174417451746174717481749175017511752175317541755175617571758175917601761176217631764176517661767176817691770177117721773177417751776177717781779178017811782178317841785178617871788178917901791179217931794179517961797179817991800180118021803180418051806180718081809181018111812181318141815181618171818181918201821182218231824182518261827182818291830183118321833183418351836183718381839184018411842184318441845184618471848184918501851185218531854185518561857185818591860186118621863186418651866186718681869187018711872187318741875187618771878187918801881188218831884188518861887188818891890189118921893189418951896189718981899190019011902190319041905190619071908190919101911191219131914191519161917191819191920192119221923192419251926192719281929193019311932193319341935193619371938193919401941194219431944194519461947194819491950195119521953195419551956195719581959196019611962196319641965196619671968196919701971197219731974197519761977197819791980198119821983198419851986198719881989199019911992199319941995199619971998199920002001200220032004200520062007200820092010201120122013201420152016201720182019202020212022202320242025202620272028202920302031203220332034203520362037203820392040204120422043204420452046204720482049205020512052205320542055205620572058205920602061206220632064206520662067206820692070207120722073207420752076207720782079208020812082208320842085208620872088208920902091209220932094209520962097209820992100210121022103210421052106210721082109211021112112211321142115211621172118211921202121212221232124212521262127212821292130213121322133213421352136213721382139214021412142214321442145214621472148214921502151215221532154215521562157215821592160216121622163216421652166216721682169217021712172217321742175217621772178217921802181218221832184218521862187218821892190219121922193219421952196219721982199220022012202220322042205220622072208220922102211221222132214221522162217221822192220222122222223222422252226222722282229223022312232223322342235223622372238223922402241224222432244224522462247224822492250225122522253225422552256225722582259226022612262226322642265226622672268226922702271227222732274227522762277227822792280228122822283228422852286228722882289229022912292229322942295229622972298229923002301230223032304230523062307230823092310231123122313231423152316231723182319232023212322232323242325232623272328232923302331233223332334233523362337233823392340234123422343234423452346234723482349235023512352235323542355235623572358235923602361236223632364236523662367236823692370237123722373237423752376237723782379238023812382238323842385238623872388238923902391239223932394239523962397239823992400240124022403240424052406240724082409241024112412241324142415241624172418241924202421242224232424242524262427242824292430243124322433243424352436243724382439244024412442244324442445244624472448244924502451245224532454245524562457245824592460246124622463246424652466246724682469247024712472247324742475247624772478247924802481248224832484248524862487248824892490249124922493249424952496249724982499250025012502250325042505250625072508250925102511251225132514251525162517251825192520252125222523252425252526252725282529253025312532253325342535253625372538253925402541254225432544254525462547254825492550255125522553255425552556255725582559256025612562256325642565256625672568256925702571257225732574257525762577257825792580258125822583258425852586258725882589259025912592259325942595259625972598259926002601260226032604260526062607260826092610261126122613261426152616261726182619262026212622262326242625262626272628262926302631263226332634263526362637263826392640264126422643264426452646264726482649265026512652265326542655265626572658265926602661266226632664266526662667266826692670267126722673267426752676267726782679268026812682268326842685268626872688268926902691269226932694269526962697269826992700270127022703270427052706270727082709271027112712271327142715271627172718271927202721272227232724272527262727272827292730273127322733273427352736273727382739274027412742274327442745274627472748274927502751275227532754275527562757275827592760276127622763276427652766276727682769277027712772277327742775277627772778277927802781278227832784278527862787278827892790279127922793279427952796279727982799280028012802280328042805280628072808280928102811281228132814281528162817281828192820282128222823282428252826282728282829283028312832283328342835283628372838283928402841284228432844284528462847284828492850285128522853285428552856285728582859286028612862286328642865286628672868286928702871287228732874287528762877287828792880288128822883288428852886288728882889289028912892289328942895289628972898289929002901290229032904290529062907290829092910291129122913291429152916291729182919292029212922292329242925292629272928292929302931293229332934293529362937293829392940294129422943294429452946294729482949295029512952295329542955295629572958295929602961296229632964296529662967296829692970297129722973297429752976297729782979298029812982298329842985298629872988298929902991299229932994299529962997299829993000300130023003300430053006300730083009301030113012301330143015301630173018301930203021302230233024302530263027302830293030303130323033303430353036303730383039304030413042304330443045304630473048304930503051305230533054305530563057305830593060306130623063306430653066306730683069307030713072307330743075307630773078307930803081308230833084308530863087308830893090309130923093309430953096309730983099310031013102310331043105310631073108310931103111311231133114311531163117311831193120312131223123312431253126312731283129313031313132313331343135313631373138313931403141314231433144314531463147314831493150315131523153315431553156315731583159316031613162316331643165316631673168316931703171317231733174317531763177317831793180318131823183318431853186318731883189319031913192319331943195319631973198319932003201320232033204320532063207320832093210321132123213321432153216321732183219322032213222322332243225322632273228322932303231323232333234323532363237323832393240324132423243324432453246324732483249325032513252325332543255325632573258325932603261326232633264326532663267326832693270327132723273327432753276327732783279328032813282328332843285328632873288328932903291329232933294329532963297329832993300330133023303330433053306330733083309331033113312331333143315331633173318331933203321332233233324332533263327332833293330333133323333333433353336333733383339334033413342334333443345334633473348334933503351335233533354335533563357335833593360336133623363336433653366336733683369337033713372337333743375337633773378337933803381338233833384338533863387338833893390339133923393339433953396339733983399340034013402340334043405340634073408340934103411341234133414341534163417341834193420342134223423342434253426342734283429343034313432343334343435343634373438343934403441344234433444344534463447344834493450345134523453345434553456345734583459346034613462346334643465346634673468346934703471347234733474347534763477347834793480348134823483348434853486348734883489349034913492349334943495349634973498349935003501350235033504350535063507350835093510351135123513351435153516351735183519352035213522352335243525352635273528352935303531353235333534353535363537353835393540354135423543354435453546354735483549355035513552355335543555355635573558355935603561356235633564356535663567356835693570357135723573357435753576357735783579358035813582358335843585358635873588358935903591359235933594359535963597359835993600360136023603360436053606360736083609361036113612361336143615361636173618361936203621362236233624362536263627362836293630363136323633363436353636363736383639364036413642364336443645364636473648364936503651365236533654365536563657365836593660366136623663366436653666366736683669367036713672367336743675367636773678367936803681368236833684368536863687368836893690369136923693369436953696369736983699370037013702370337043705370637073708370937103711371237133714371537163717371837193720372137223723372437253726372737283729373037313732373337343735373637373738373937403741374237433744374537463747374837493750375137523753375437553756375737583759376037613762376337643765376637673768376937703771377237733774377537763777377837793780378137823783378437853786378737883789379037913792379337943795379637973798379938003801380238033804380538063807380838093810381138123813381438153816381738183819382038213822382338243825382638273828382938303831383238333834383538363837383838393840384138423843384438453846384738483849385038513852385338543855385638573858385938603861386238633864386538663867386838693870387138723873387438753876387738783879388038813882388338843885388638873888388938903891389238933894389538963897389838993900390139023903390439053906390739083909391039113912391339143915391639173918391939203921392239233924392539263927392839293930393139323933393439353936393739383939394039413942394339443945394639473948394939503951395239533954395539563957395839593960396139623963396439653966396739683969397039713972397339743975397639773978397939803981398239833984398539863987398839893990399139923993399439953996399739983999400040014002400340044005400640074008400940104011401240134014401540164017401840194020402140224023402440254026402740284029403040314032403340344035403640374038403940404041404240434044404540464047404840494050405140524053405440554056405740584059406040614062406340644065406640674068406940704071407240734074407540764077407840794080408140824083408440854086408740884089409040914092409340944095409640974098409941004101410241034104410541064107410841094110411141124113411441154116411741184119412041214122412341244125412641274128412941304131413241334134413541364137413841394140414141424143414441454146414741484149415041514152415341544155415641574158415941604161416241634164416541664167416841694170417141724173417441754176417741784179418041814182418341844185418641874188418941904191419241934194419541964197419841994200420142024203420442054206420742084209421042114212421342144215421642174218421942204221422242234224422542264227422842294230423142324233423442354236423742384239424042414242424342444245424642474248424942504251425242534254425542564257425842594260426142624263426442654266426742684269427042714272427342744275427642774278427942804281428242834284428542864287428842894290429142924293429442954296429742984299430043014302430343044305430643074308430943104311431243134314431543164317431843194320432143224323432443254326432743284329433043314332433343344335433643374338433943404341434243434344434543464347434843494350435143524353435443554356435743584359436043614362436343644365436643674368436943704371437243734374437543764377437843794380438143824383438443854386438743884389439043914392439343944395439643974398439944004401440244034404440544064407440844094410441144124413441444154416441744184419442044214422442344244425442644274428442944304431443244334434443544364437443844394440444144424443444444454446444744484449445044514452445344544455445644574458445944604461446244634464446544664467446844694470447144724473447444754476447744784479448044814482448344844485448644874488448944904491449244934494449544964497449844994500450145024503450445054506450745084509451045114512451345144515451645174518451945204521452245234524452545264527452845294530453145324533453445354536453745384539454045414542454345444545454645474548454945504551455245534554455545564557455845594560456145624563456445654566456745684569457045714572457345744575457645774578457945804581458245834584458545864587458845894590459145924593459445954596459745984599460046014602460346044605460646074608460946104611461246134614461546164617461846194620462146224623462446254626462746284629463046314632463346344635463646374638463946404641464246434644464546464647464846494650465146524653465446554656465746584659466046614662466346644665466646674668466946704671467246734674467546764677467846794680468146824683468446854686468746884689469046914692469346944695469646974698469947004701470247034704470547064707470847094710471147124713471447154716471747184719472047214722472347244725472647274728472947304731473247334734473547364737473847394740474147424743474447454746474747484749475047514752475347544755475647574758475947604761476247634764476547664767476847694770477147724773477447754776477747784779478047814782478347844785478647874788478947904791479247934794479547964797479847994800480148024803480448054806480748084809481048114812481348144815481648174818481948204821482248234824482548264827482848294830483148324833483448354836483748384839484048414842484348444845484648474848484948504851485248534854485548564857485848594860486148624863486448654866486748684869487048714872487348744875487648774878487948804881488248834884488548864887488848894890489148924893489448954896489748984899490049014902490349044905490649074908490949104911491249134914491549164917491849194920492149224923492449254926492749284929493049314932493349344935493649374938493949404941494249434944494549464947494849494950495149524953495449554956495749584959496049614962496349644965496649674968496949704971497249734974497549764977497849794980498149824983498449854986498749884989499049914992499349944995499649974998499950005001500250035004500550065007500850095010501150125013501450155016501750185019502050215022502350245025502650275028502950305031503250335034503550365037503850395040504150425043504450455046504750485049505050515052505350545055505650575058505950605061506250635064506550665067506850695070507150725073507450755076507750785079508050815082508350845085508650875088508950905091509250935094509550965097509850995100510151025103510451055106510751085109511051115112511351145115511651175118511951205121512251235124512551265127512851295130513151325133513451355136513751385139514051415142514351445145514651475148514951505151515251535154515551565157515851595160516151625163516451655166516751685169517051715172517351745175517651775178517951805181518251835184518551865187518851895190519151925193519451955196519751985199520052015202520352045205520652075208520952105211521252135214521552165217521852195220522152225223522452255226522752285229523052315232523352345235523652375238523952405241524252435244524552465247524852495250525152525253525452555256525752585259526052615262526352645265526652675268526952705271527252735274527552765277527852795280528152825283528452855286528752885289529052915292529352945295529652975298529953005301530253035304530553065307530853095310531153125313531453155316531753185319532053215322532353245325532653275328532953305331533253335334533553365337533853395340534153425343534453455346534753485349535053515352535353545355535653575358535953605361536253635364536553665367536853695370537153725373537453755376537753785379538053815382538353845385538653875388538953905391539253935394539553965397539853995400540154025403540454055406540754085409541054115412541354145415541654175418541954205421542254235424542554265427542854295430543154325433543454355436543754385439544054415442544354445445544654475448544954505451545254535454545554565457545854595460546154625463546454655466546754685469547054715472547354745475547654775478547954805481548254835484548554865487548854895490549154925493549454955496549754985499550055015502550355045505550655075508550955105511551255135514551555165517551855195520552155225523552455255526552755285529553055315532553355345535553655375538553955405541554255435544554555465547554855495550555155525553555455555556555755585559556055615562556355645565556655675568556955705571557255735574557555765577557855795580558155825583558455855586558755885589559055915592559355945595559655975598559956005601560256035604560556065607560856095610561156125613561456155616561756185619562056215622562356245625562656275628562956305631563256335634563556365637563856395640564156425643564456455646564756485649565056515652565356545655565656575658565956605661566256635664566556665667566856695670567156725673567456755676567756785679568056815682568356845685568656875688568956905691569256935694569556965697569856995700570157025703570457055706570757085709571057115712571357145715571657175718571957205721572257235724572557265727572857295730573157325733573457355736573757385739574057415742574357445745574657475748574957505751575257535754575557565757575857595760576157625763576457655766576757685769577057715772577357745775577657775778577957805781578257835784578557865787578857895790579157925793579457955796579757985799580058015802580358045805580658075808580958105811581258135814581558165817581858195820582158225823582458255826582758285829583058315832583358345835583658375838583958405841584258435844584558465847584858495850585158525853585458555856585758585859586058615862586358645865586658675868586958705871587258735874587558765877587858795880588158825883588458855886588758885889589058915892589358945895589658975898589959005901590259035904590559065907590859095910591159125913591459155916591759185919592059215922592359245925592659275928592959305931593259335934593559365937593859395940594159425943594459455946594759485949595059515952595359545955595659575958595959605961596259635964596559665967596859695970597159725973597459755976597759785979598059815982598359845985598659875988598959905991599259935994599559965997599859996000600160026003600460056006600760086009601060116012601360146015601660176018601960206021602260236024602560266027602860296030603160326033603460356036603760386039604060416042604360446045604660476048604960506051605260536054605560566057605860596060606160626063606460656066606760686069607060716072607360746075607660776078607960806081608260836084608560866087608860896090609160926093609460956096609760986099610061016102610361046105610661076108610961106111611261136114611561166117611861196120612161226123612461256126612761286129613061316132613361346135613661376138613961406141614261436144614561466147614861496150615161526153615461556156615761586159616061616162616361646165616661676168616961706171617261736174617561766177617861796180618161826183618461856186618761886189619061916192619361946195619661976198619962006201620262036204620562066207620862096210621162126213621462156216621762186219622062216222622362246225622662276228622962306231623262336234623562366237623862396240624162426243624462456246624762486249625062516252625362546255625662576258625962606261626262636264626562666267626862696270627162726273627462756276627762786279628062816282628362846285628662876288628962906291629262936294629562966297629862996300630163026303630463056306630763086309631063116312631363146315631663176318631963206321632263236324632563266327632863296330633163326333633463356336633763386339634063416342634363446345634663476348634963506351635263536354635563566357635863596360636163626363636463656366636763686369637063716372637363746375637663776378637963806381638263836384638563866387638863896390639163926393639463956396639763986399640064016402640364046405640664076408640964106411641264136414641564166417641864196420642164226423642464256426642764286429643064316432643364346435643664376438643964406441644264436444644564466447644864496450645164526453645464556456645764586459646064616462646364646465646664676468646964706471647264736474647564766477647864796480648164826483648464856486648764886489649064916492649364946495649664976498649965006501650265036504650565066507650865096510651165126513651465156516651765186519652065216522652365246525652665276528652965306531653265336534653565366537653865396540654165426543654465456546654765486549655065516552655365546555655665576558655965606561656265636564656565666567656865696570657165726573657465756576657765786579658065816582658365846585658665876588658965906591659265936594659565966597659865996600660166026603660466056606660766086609661066116612661366146615661666176618661966206621662266236624662566266627662866296630663166326633663466356636663766386639664066416642664366446645664666476648664966506651665266536654665566566657665866596660666166626663666466656666666766686669667066716672667366746675667666776678667966806681668266836684668566866687668866896690669166926693669466956696669766986699670067016702670367046705670667076708670967106711671267136714671567166717671867196720672167226723672467256726672767286729673067316732673367346735673667376738673967406741674267436744674567466747674867496750675167526753675467556756675767586759676067616762676367646765676667676768676967706771677267736774677567766777677867796780678167826783678467856786678767886789679067916792679367946795679667976798679968006801680268036804680568066807680868096810681168126813681468156816681768186819682068216822682368246825682668276828682968306831683268336834683568366837683868396840684168426843684468456846684768486849685068516852685368546855685668576858685968606861686268636864686568666867686868696870687168726873687468756876687768786879688068816882688368846885688668876888688968906891689268936894689568966897689868996900690169026903690469056906690769086909691069116912691369146915691669176918691969206921692269236924692569266927692869296930693169326933693469356936693769386939694069416942694369446945694669476948694969506951695269536954695569566957695869596960696169626963696469656966696769686969697069716972697369746975697669776978697969806981698269836984698569866987698869896990699169926993699469956996699769986999700070017002700370047005700670077008700970107011701270137014701570167017701870197020702170227023702470257026702770287029703070317032703370347035703670377038703970407041704270437044704570467047704870497050705170527053705470557056705770587059706070617062706370647065706670677068706970707071707270737074707570767077707870797080708170827083708470857086708770887089709070917092709370947095709670977098709971007101710271037104710571067107710871097110711171127113711471157116711771187119712071217122712371247125712671277128712971307131713271337134713571367137713871397140714171427143714471457146714771487149715071517152715371547155715671577158715971607161716271637164716571667167716871697170717171727173717471757176717771787179718071817182718371847185718671877188718971907191719271937194719571967197719871997200720172027203720472057206720772087209721072117212721372147215721672177218721972207221722272237224722572267227722872297230723172327233723472357236723772387239724072417242724372447245724672477248724972507251725272537254725572567257725872597260726172627263726472657266726772687269727072717272727372747275727672777278727972807281728272837284728572867287728872897290729172927293729472957296729772987299730073017302730373047305730673077308730973107311731273137314731573167317731873197320732173227323732473257326732773287329733073317332733373347335733673377338733973407341734273437344734573467347734873497350735173527353735473557356735773587359736073617362736373647365736673677368736973707371737273737374737573767377737873797380738173827383738473857386738773887389739073917392739373947395739673977398739974007401740274037404740574067407740874097410741174127413741474157416741774187419742074217422742374247425742674277428742974307431743274337434743574367437743874397440744174427443744474457446744774487449745074517452745374547455745674577458745974607461746274637464746574667467746874697470747174727473747474757476747774787479748074817482748374847485748674877488748974907491749274937494749574967497749874997500750175027503750475057506750775087509751075117512751375147515751675177518751975207521752275237524752575267527752875297530753175327533753475357536753775387539754075417542754375447545754675477548754975507551755275537554755575567557755875597560756175627563756475657566756775687569757075717572757375747575757675777578757975807581758275837584758575867587758875897590759175927593759475957596759775987599760076017602760376047605760676077608760976107611761276137614761576167617761876197620762176227623762476257626762776287629763076317632763376347635763676377638763976407641764276437644764576467647764876497650765176527653765476557656765776587659766076617662766376647665766676677668766976707671767276737674767576767677767876797680768176827683768476857686768776887689769076917692769376947695769676977698769977007701770277037704770577067707770877097710771177127713771477157716771777187719772077217722772377247725772677277728772977307731773277337734773577367737773877397740774177427743774477457746774777487749775077517752775377547755775677577758775977607761776277637764776577667767776877697770777177727773777477757776777777787779778077817782778377847785778677877788778977907791779277937794779577967797779877997800780178027803780478057806780778087809781078117812781378147815781678177818781978207821782278237824782578267827782878297830783178327833783478357836783778387839784078417842784378447845784678477848784978507851785278537854785578567857785878597860786178627863786478657866786778687869787078717872787378747875787678777878787978807881788278837884788578867887788878897890789178927893789478957896789778987899790079017902790379047905790679077908790979107911791279137914791579167917791879197920792179227923792479257926792779287929793079317932793379347935793679377938793979407941794279437944794579467947794879497950795179527953795479557956795779587959796079617962796379647965796679677968796979707971797279737974797579767977797879797980798179827983798479857986798779887989799079917992799379947995799679977998799980008001800280038004800580068007800880098010801180128013801480158016801780188019802080218022802380248025802680278028802980308031803280338034803580368037803880398040804180428043804480458046804780488049805080518052805380548055805680578058805980608061806280638064806580668067806880698070807180728073807480758076807780788079808080818082808380848085808680878088808980908091809280938094809580968097809880998100810181028103810481058106810781088109811081118112811381148115811681178118811981208121812281238124812581268127812881298130813181328133813481358136813781388139814081418142814381448145814681478148814981508151815281538154815581568157815881598160816181628163816481658166816781688169817081718172817381748175817681778178817981808181818281838184818581868187818881898190819181928193819481958196819781988199820082018202820382048205820682078208820982108211821282138214821582168217821882198220822182228223822482258226822782288229823082318232823382348235823682378238823982408241824282438244824582468247824882498250825182528253825482558256825782588259826082618262826382648265826682678268826982708271827282738274827582768277827882798280828182828283828482858286828782888289829082918292829382948295829682978298829983008301830283038304830583068307830883098310831183128313831483158316831783188319832083218322832383248325832683278328832983308331833283338334833583368337833883398340834183428343834483458346834783488349835083518352835383548355835683578358835983608361836283638364836583668367836883698370837183728373837483758376837783788379838083818382838383848385838683878388838983908391839283938394839583968397839883998400840184028403840484058406840784088409841084118412841384148415841684178418841984208421842284238424842584268427842884298430843184328433843484358436843784388439844084418442844384448445844684478448844984508451845284538454845584568457845884598460846184628463846484658466846784688469847084718472847384748475847684778478847984808481848284838484848584868487848884898490849184928493849484958496849784988499850085018502850385048505850685078508850985108511851285138514851585168517851885198520852185228523852485258526852785288529853085318532853385348535853685378538853985408541854285438544854585468547854885498550855185528553855485558556855785588559856085618562856385648565856685678568856985708571857285738574857585768577857885798580858185828583858485858586858785888589859085918592859385948595859685978598859986008601860286038604860586068607860886098610861186128613861486158616861786188619862086218622862386248625862686278628862986308631863286338634863586368637863886398640864186428643864486458646864786488649865086518652865386548655865686578658865986608661866286638664866586668667866886698670867186728673867486758676867786788679868086818682868386848685868686878688868986908691869286938694869586968697869886998700870187028703870487058706870787088709871087118712871387148715871687178718871987208721872287238724872587268727872887298730873187328733873487358736873787388739874087418742874387448745874687478748874987508751875287538754875587568757875887598760876187628763876487658766876787688769877087718772877387748775877687778778877987808781878287838784878587868787878887898790879187928793879487958796879787988799880088018802880388048805880688078808880988108811881288138814881588168817881888198820882188228823882488258826882788288829883088318832883388348835883688378838883988408841884288438844884588468847884888498850885188528853885488558856885788588859886088618862886388648865886688678868886988708871887288738874887588768877887888798880888188828883888488858886888788888889889088918892889388948895889688978898889989008901890289038904 |
- {
- This file is part of the Free Pascal run time library.
- Copyright (c) 1999-2017 by Michael Van Canneyt, member of the
- Free Pascal development team
- DB database unit
- See the file COPYING.FPC, included in this distribution,
- for details about the copyright.
- This program is distributed in the hope that it will be useful,
- but WITHOUT ANY WARRANTY; without even the implied warranty of
- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
- **********************************************************************}
- unit DB;
- {$mode objfpc}
- { $define dsdebug}
- interface
- uses Classes, SysUtils, JS, Types, DateUtils;
- const
- dsMaxBufferCount = MAXINT div 8;
- dsMaxStringSize = 8192;
- // Used in AsBoolean for string fields to determine
- // whether it's true or false.
- YesNoChars : Array[Boolean] of char = ('N', 'Y');
- SQLDelimiterCharacters = [';',',',' ','(',')',#13,#10,#9];
- type
- { Misc Dataset types }
- TDataSetState = (dsInactive, dsBrowse, dsEdit, dsInsert, dsSetKey,
- dsCalcFields, dsFilter, dsNewValue, dsOldValue, dsCurValue, dsBlockRead,
- dsInternalCalc, dsOpening, dsRefreshFields);
- TDataEvent = (deFieldChange, deRecordChange, deDataSetChange,
- deDataSetScroll, deLayoutChange, deUpdateRecord, deUpdateState,
- deCheckBrowseMode, dePropertyChange, deFieldListChange, deFocusControl,
- deParentScroll,deConnectChange,deReconcileError,deDisabledStateChange);
- TUpdateStatus = (usUnmodified, usModified, usInserted, usDeleted, usResolved, usResolveFailed);
- TUpdateStatusSet = Set of TUpdateStatus;
- TUpdateMode = (upWhereAll, upWhereChanged, upWhereKeyOnly);
- TResolverResponse = (rrSkip, rrAbort, rrMerge, rrApply, rrIgnore);
- TProviderFlag = (pfInUpdate, pfInWhere, pfInKey, pfHidden, pfRefreshOnInsert,pfRefreshOnUpdate);
- TProviderFlags = set of TProviderFlag;
- { Forward declarations }
- TFieldDef = class;
- TFieldDefs = class;
- TField = class;
- TFields = Class;
- TDataSet = class;
- TDataSource = Class;
- TDataLink = Class;
- TDataProxy = Class;
- TDataRequest = class;
- TRecordUpdateDescriptor = class;
- TRecordUpdateDescriptorList = class;
- TRecordUpdateBatch = class;
- { Exception classes }
- EDatabaseError = class(Exception);
- EUpdateError = class(EDatabaseError)
- private
- FContext : String;
- FErrorCode : integer;
- FOriginalException : Exception;
- FPreviousError : Integer;
- public
- constructor Create(NativeError, Context : String;
- ErrCode, PrevError : integer; E: Exception); reintroduce;
- Destructor Destroy; override;
- property Context : String read FContext;
- property ErrorCode : integer read FErrorcode;
- property OriginalException : Exception read FOriginalException;
- property PreviousError : Integer read FPreviousError;
- end;
-
- { TFieldDef }
- TFieldClass = class of TField;
- // Data type for field.
- TFieldType = (
- ftUnknown, ftString, ftInteger, ftLargeInt, ftBoolean, ftFloat, ftDate,
- ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftFixedChar,
- ftVariant,ftDataset
- );
- { TDateTimeRec }
- TFieldAttribute = (faHiddenCol, faReadonly, faRequired, faLink, faUnNamed, faFixed);
- TFieldAttributes = set of TFieldAttribute;
- { TNamedItem }
- TNamedItem = class(TCollectionItem)
- private
- FName: string;
- protected
- function GetDisplayName: string; override;
- procedure SetDisplayName(const Value: string); override;
- Public
- property DisplayName : string read GetDisplayName write SetDisplayName;
- published
- property Name : string read FName write SetDisplayName;
- end;
- { TDefCollection }
- TDefCollection = class(TOwnedCollection)
- private
- FDataset: TDataset;
- FUpdated: boolean;
- protected
- procedure SetItemName(Item: TCollectionItem); override;
- public
- constructor create(ADataset: TDataset; AOwner: TPersistent; AClass: TCollectionItemClass); reintroduce;
- function Find(const AName: string): TNamedItem;
- procedure GetItemNames(List: TStrings);
- function IndexOf(const AName: string): Longint;
- property Dataset: TDataset read FDataset;
- property Updated: boolean read FUpdated write FUpdated;
- end;
- { TFieldDef }
- TFieldDef = class(TNamedItem)
- Private
- FAttributes : TFieldAttributes;
- FDataType : TFieldType;
- FFieldNo : Longint;
- FInternalCalcField : Boolean;
- FPrecision : Longint;
- FRequired : Boolean;
- FSize : Integer;
- Function GetFieldClass : TFieldClass;
- procedure SetAttributes(AValue: TFieldAttributes);
- procedure SetDataType(AValue: TFieldType);
- procedure SetPrecision(const AValue: Longint);
- procedure SetSize(const AValue: Integer);
- procedure SetRequired(const AValue: Boolean);
- public
- constructor Create(ACollection : TCollection); override;
- constructor Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType; ASize: Integer; ARequired: Boolean; AFieldNo: Longint); overload;
- destructor Destroy; override;
- procedure Assign(Source: TPersistent); override;
- function CreateField(AOwner: TComponent): TField;
- property FieldClass: TFieldClass read GetFieldClass;
- property FieldNo: Longint read FFieldNo;
- property InternalCalcField: Boolean read FInternalCalcField write FInternalCalcField;
- property Required: Boolean read FRequired write SetRequired;
- Published
- property Attributes: TFieldAttributes read FAttributes write SetAttributes default [];
- property DataType: TFieldType read FDataType write SetDataType;
- property Precision: Longint read FPrecision write SetPrecision default 0;
- property Size: Integer read FSize write SetSize default 0;
- end;
- TFieldDefClass = Class of TFieldDef;
- { TFieldDefs }
- TFieldDefs = class(TDefCollection)
- private
- FHiddenFields : Boolean;
- function GetItem(Index: Longint): TFieldDef; reintroduce;
- procedure SetItem(Index: Longint; const AValue: TFieldDef); reintroduce;
- Protected
- Class Function FieldDefClass : TFieldDefClass; virtual;
- public
- constructor Create(ADataSet: TDataSet); reintroduce;
- // destructor Destroy; override;
- Function Add(const AName: string; ADataType: TFieldType; ASize, APrecision{%H-}: Integer; ARequired, AReadOnly: Boolean; AFieldNo : Integer) : TFieldDef; overload;
- Function Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo : Integer) : TFieldDef; overload;
- procedure Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean); overload;
- procedure Add(const AName: string; ADataType: TFieldType; ASize: Word); overload;
- procedure Add(const AName: string; ADataType: TFieldType); overload;
- Function AddFieldDef : TFieldDef;
- procedure Assign(FieldDefs: TFieldDefs); overload;
- function Find(const AName: string): TFieldDef; reintroduce;
- // procedure Clear;
- // procedure Delete(Index: Longint);
- procedure Update; overload;
- Function MakeNameUnique(const AName : String) : string; virtual;
- Property HiddenFields : Boolean Read FHiddenFields Write FHiddenFields;
- property Items[Index: Longint]: TFieldDef read GetItem write SetItem; default;
- end;
- TFieldDefsClass = Class of TFieldDefs;
- { TField }
- TFieldKind = (fkData, fkCalculated, fkLookup, fkInternalCalc);
- TFieldKinds = Set of TFieldKind;
- TFieldNotifyEvent = procedure(Sender: TField) of object;
- TFieldGetTextEvent = procedure(Sender: TField; var aText: string;
- DisplayText: Boolean) of object;
- TFieldSetTextEvent = procedure(Sender: TField; const aText: string) of object;
- TFieldChars = Array of Char;
- { TLookupList }
- TLookupList = class(TObject)
- private
- FList: TFPList;
- public
- constructor Create; reintroduce;
- destructor Destroy; override;
- procedure Add(const AKey, AValue: JSValue);
- procedure Clear;
- function FirstKeyByValue(const AValue: JSValue): JSValue;
- function ValueOfKey(const AKey: JSValue): JSValue;
- procedure ValuesToStrings(AStrings: TStrings);
- end;
- { TField }
- TField = class(TComponent)
- private
- FAlignment : TAlignment;
- FAttributeSet : String;
- FCalculated : Boolean;
- FConstraintErrorMessage : String;
- FCustomConstraint : String;
- FDataSet : TDataSet;
- // FDataSize : Word;
- FDataType : TFieldType;
- FDefaultExpression : String;
- FDisplayLabel : String;
- FDisplayWidth : Longint;
- // FEditMask: TEditMask;
- FFieldDef: TFieldDef;
- FFieldKind : TFieldKind;
- FFieldName : String;
- FFieldNo : Longint;
- FFields : TFields;
- FHasConstraints : Boolean;
- FImportedConstraint : String;
- FIsIndexField : Boolean;
- FKeyFields : String;
- FLookupCache : Boolean;
- FLookupDataSet : TDataSet;
- FLookupKeyfields : String;
- FLookupresultField : String;
- FLookupList: TLookupList;
- FOnChange : TFieldNotifyEvent;
- FOnGetText: TFieldGetTextEvent;
- FOnSetText: TFieldSetTextEvent;
- FOnValidate: TFieldNotifyEvent;
- FOrigin : String;
- FReadOnly : Boolean;
- FRequired : Boolean;
- FSize : integer;
- FValidChars : TFieldChars;
- FValueBuffer : JSValue;
- FValidating : Boolean;
- FVisible : Boolean;
- FProviderFlags : TProviderFlags;
- function GetIndex : longint;
- function GetLookup: Boolean;
- procedure SetAlignment(const AValue: TAlignMent);
- procedure SetIndex(const AValue: Longint);
- function GetDisplayText: String;
- function GetEditText: String;
- procedure SetEditText(const AValue: string);
- procedure SetDisplayLabel(const AValue: string);
- procedure SetDisplayWidth(const AValue: Longint);
- function GetDisplayWidth: integer;
- procedure SetLookup(const AValue: Boolean);
- procedure SetReadOnly(const AValue: Boolean);
- procedure SetVisible(const AValue: Boolean);
- function IsDisplayLabelStored : Boolean;
- function IsDisplayWidthStored: Boolean;
- function GetLookupList: TLookupList;
- procedure CalcLookupValue;
- protected
- Procedure RaiseAccessError(const TypeName: string);
- function AccessError(const TypeName: string): EDatabaseError;
- procedure CheckInactive;
- class procedure CheckTypeSize(AValue: Longint); virtual;
- procedure Change; virtual;
- procedure Bind(Binding: Boolean); virtual;
- procedure DataChanged;
- function GetAsBoolean: Boolean; virtual;
- function GetAsBytes: TBytes; virtual;
- function GetAsLargeInt: NativeInt; virtual;
- function GetAsDateTime: TDateTime; virtual;
- function GetAsFloat: Double; virtual;
- function GetAsLongint: Longint; virtual;
- function GetAsInteger: Longint; virtual;
- function GetAsJSValue: JSValue; virtual;
- function GetOldValue: JSValue; virtual;
- function GetAsString: string; virtual;
- function GetCanModify: Boolean; virtual;
- function GetClassDesc: String; virtual;
- function GetDataSize: Integer; virtual;
- function GetDefaultWidth: Longint; virtual;
- function GetDisplayName : String;
- function GetCurValue: JSValue; virtual;
- function GetNewValue: JSValue; virtual;
- function GetIsNull: Boolean; virtual;
- procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); virtual;
- procedure Notification(AComponent: TComponent; Operation: TOperation); override;
- procedure PropertyChanged(LayoutAffected: Boolean);
- procedure SetAsBoolean(AValue{%H-}: Boolean); virtual;
- procedure SetAsDateTime(AValue{%H-}: TDateTime); virtual;
- procedure SetAsFloat(AValue{%H-}: Double); virtual;
- procedure SetAsLongint(AValue: Longint); virtual;
- procedure SetAsInteger(AValue{%H-}: Longint); virtual;
- procedure SetAsLargeInt(AValue{%H-}: NativeInt); virtual;
- procedure SetAsJSValue(const AValue: JSValue); virtual;
- procedure SetAsString(const AValue{%H-}: string); virtual;
- procedure SetDataset(AValue : TDataset); virtual;
- procedure SetDataType(AValue: TFieldType);
- procedure SetNewValue(const AValue: JSValue);
- procedure SetSize(AValue: Integer); virtual;
- procedure SetParentComponent(Value: TComponent); override;
- procedure SetText(const AValue: string); virtual;
- procedure SetVarValue(const AValue{%H-}: JSValue); virtual;
- procedure SetAsBytes(const AValue{%H-}: TBytes); virtual;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- function GetParentComponent: TComponent; override;
- function HasParent: Boolean; override;
- procedure Assign(Source: TPersistent); override;
- procedure AssignValue(const AValue: JSValue);
- procedure Clear; virtual;
- procedure FocusControl;
- function GetData : JSValue;
- class function IsBlob: Boolean; virtual;
- function IsValidChar(InputChar: Char): Boolean; virtual;
- procedure RefreshLookupList;
- procedure SetData(Buffer: JSValue); overload;
- procedure SetFieldType(AValue{%H-}: TFieldType); virtual;
- procedure Validate(Buffer: Pointer);
- property AsBoolean: Boolean read GetAsBoolean write SetAsBoolean;
- property AsDateTime: TDateTime read GetAsDateTime write SetAsDateTime;
- property AsFloat: Double read GetAsFloat write SetAsFloat;
- property AsLongint: Longint read GetAsLongint write SetAsLongint;
- property AsLargeInt: NativeInt read GetAsLargeInt write SetAsLargeInt;
- property AsInteger: Longint read GetAsInteger write SetAsInteger;
- property AsString: string read GetAsString write SetAsString;
- property AsJSValue: JSValue read GetAsJSValue write SetAsJSValue;
- property AttributeSet: string read FAttributeSet write FAttributeSet;
- property Calculated: Boolean read FCalculated write FCalculated;
- property CanModify: Boolean read GetCanModify;
- property CurValue: JSValue read GetCurValue;
- property DataSet: TDataSet read FDataSet write SetDataSet;
- property DataSize: Integer read GetDataSize;
- property DataType: TFieldType read FDataType;
- property DisplayName: String Read GetDisplayName;
- property DisplayText: String read GetDisplayText;
- property FieldNo: Longint read FFieldNo;
- property IsIndexField: Boolean read FIsIndexField;
- property IsNull: Boolean read GetIsNull;
- property Lookup: Boolean read GetLookup write SetLookup; deprecated;
- property NewValue: JSValue read GetNewValue write SetNewValue;
- property Size: Integer read FSize write SetSize;
- property Text: string read GetEditText write SetEditText;
- property ValidChars : TFieldChars read FValidChars write FValidChars;
- property Value: JSValue read GetAsJSValue write SetAsJSValue;
- property OldValue: JSValue read GetOldValue;
- property LookupList: TLookupList read GetLookupList;
- Property FieldDef : TFieldDef Read FFieldDef;
- published
- property Alignment : TAlignment read FAlignment write SetAlignment default taLeftJustify;
- property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
- property ConstraintErrorMessage: string read FConstraintErrorMessage write FConstraintErrorMessage;
- property DefaultExpression: string read FDefaultExpression write FDefaultExpression;
- property DisplayLabel : string read GetDisplayName write SetDisplayLabel stored IsDisplayLabelStored;
- property DisplayWidth: Longint read GetDisplayWidth write SetDisplayWidth stored IsDisplayWidthStored;
- property FieldKind: TFieldKind read FFieldKind write FFieldKind;
- property FieldName: string read FFieldName write FFieldName;
- property HasConstraints: Boolean read FHasConstraints;
- property Index: Longint read GetIndex write SetIndex;
- property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
- property KeyFields: string read FKeyFields write FKeyFields;
- property LookupCache: Boolean read FLookupCache write FLookupCache;
- property LookupDataSet: TDataSet read FLookupDataSet write FLookupDataSet;
- property LookupKeyFields: string read FLookupKeyFields write FLookupKeyFields;
- property LookupResultField: string read FLookupResultField write FLookupResultField;
- property Origin: string read FOrigin write FOrigin;
- property ProviderFlags : TProviderFlags read FProviderFlags write FProviderFlags;
- property ReadOnly: Boolean read FReadOnly write SetReadOnly;
- property Required: Boolean read FRequired write FRequired;
- property Visible: Boolean read FVisible write SetVisible default True;
- property OnChange: TFieldNotifyEvent read FOnChange write FOnChange;
- property OnGetText: TFieldGetTextEvent read FOnGetText write FOnGetText;
- property OnSetText: TFieldSetTextEvent read FOnSetText write FOnSetText;
- property OnValidate: TFieldNotifyEvent read FOnValidate write FOnValidate;
- end;
- { TStringField }
- TStringField = class(TField)
- private
- FFixedChar : boolean;
- FTransliterate : Boolean;
- protected
- class procedure CheckTypeSize(AValue: Longint); override;
- function GetAsBoolean: Boolean; override;
- function GetAsDateTime: TDateTime; override;
- function GetAsFloat: Double; override;
- function GetAsInteger: Longint; override;
- function GetAsLargeInt: NativeInt; override;
- function GetAsString: String; override;
- function GetAsJSValue: JSValue; override;
- function GetDefaultWidth: Longint; override;
- procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
- procedure SetAsBoolean(AValue: Boolean); override;
- procedure SetAsDateTime(AValue: TDateTime); override;
- procedure SetAsFloat(AValue: Double); override;
- procedure SetAsInteger(AValue: Longint); override;
- procedure SetAsLargeInt(AValue: NativeInt); override;
- procedure SetAsString(const AValue: String); override;
- procedure SetVarValue(const AValue: JSValue); override;
- public
- constructor Create(AOwner: TComponent); override;
- procedure SetFieldType(AValue: TFieldType); override;
- property FixedChar : Boolean read FFixedChar write FFixedChar;
- property Transliterate: Boolean read FTransliterate write FTransliterate;
- property Value: String read GetAsString write SetAsString;
- published
- property Size default 20;
- end;
- { TNumericField }
- TNumericField = class(TField)
- Private
- FDisplayFormat : String;
- FEditFormat : String;
- protected
- class procedure CheckTypeSize(AValue: Longint); override;
- procedure RangeError(AValue, Min, Max: Double);
- procedure SetDisplayFormat(const AValue: string);
- procedure SetEditFormat(const AValue: string);
- function GetAsBoolean: Boolean; override;
- Procedure SetAsBoolean(AValue: Boolean); override;
- public
- constructor Create(AOwner: TComponent); override;
- published
- property Alignment default taRightJustify;
- property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
- property EditFormat: string read FEditFormat write SetEditFormat;
- end;
- { TLongintField }
- TIntegerField = class(TNumericField)
- private
- FMinValue,
- FMaxValue,
- FMinRange,
- FMaxRange : Longint;
- Procedure SetMinValue (AValue : longint);
- Procedure SetMaxValue (AValue : longint);
- protected
- function GetAsFloat: Double; override;
- function GetAsInteger: Longint; override;
- function GetAsString: string; override;
- function GetAsJSValue: JSValue; override;
- procedure GetText(var AText: string; ADisplayText: Boolean); override;
- function GetValue(var AValue: Longint): Boolean;
- procedure SetAsFloat(AValue: Double); override;
- procedure SetAsInteger(AValue: Longint); override;
- procedure SetAsString(const AValue: string); override;
- procedure SetVarValue(const AValue: JSValue); override;
- function GetAsLargeInt: NativeInt; override;
- procedure SetAsLargeInt(AValue: NativeInt); override;
- public
- constructor Create(AOwner: TComponent); override;
- Function CheckRange(AValue : Longint) : Boolean;
- property Value: Longint read GetAsInteger write SetAsInteger;
- published
- property MaxValue: Longint read FMaxValue write SetMaxValue default 0;
- property MinValue: Longint read FMinValue write SetMinValue default 0;
- end;
- { TLargeintField }
- TLargeintField = class(TNumericField)
- private
- FMinValue,
- FMaxValue,
- FMinRange,
- FMaxRange : NativeInt;
- Procedure SetMinValue (AValue : NativeInt);
- Procedure SetMaxValue (AValue : NativeInt);
- protected
- function GetAsFloat: Double; override;
- function GetAsInteger: Longint; override;
- function GetAsLargeInt: NativeInt; override;
- function GetAsString: string; override;
- function GetAsJSValue: JSValue; override;
- procedure GetText(var AText: string; ADisplayText: Boolean); override;
- function GetValue(var AValue: NativeInt): Boolean;
- procedure SetAsFloat(AValue: Double); override;
- procedure SetAsInteger(AValue: Longint); override;
- procedure SetAsLargeInt(AValue: NativeInt); override;
- procedure SetAsString(const AValue: string); override;
- procedure SetVarValue(const AValue: JSValue); override;
- public
- constructor Create(AOwner: TComponent); override;
- Function CheckRange(AValue : NativeInt) : Boolean;
- property Value: NativeInt read GetAsLargeInt write SetAsLargeInt;
- published
- property MaxValue: NativeInt read FMaxValue write SetMaxValue default 0;
- property MinValue: NativeInt read FMinValue write SetMinValue default 0;
- end;
- { TAutoIncField }
- TAutoIncField = class(TIntegerField)
- Protected
- procedure SetAsInteger(AValue: Longint); override;
- public
- constructor Create(AOwner: TComponent); override;
- end;
- { TFloatField }
- TFloatField = class(TNumericField)
- private
- FCurrency: Boolean;
- FMaxValue : Double;
- FMinValue : Double;
- FPrecision : Longint;
- procedure SetCurrency(const AValue: Boolean);
- procedure SetPrecision(const AValue: Longint);
- protected
- function GetAsFloat: Double; override;
- function GetAsLargeInt: NativeInt; override;
- function GetAsInteger: Longint; override;
- function GetAsJSValue: JSValue; override;
- function GetAsString: string; override;
- procedure GetText(var AText: string; ADisplayText: Boolean); override;
- procedure SetAsFloat(AValue: Double); override;
- procedure SetAsLargeInt(AValue: NativeInt); override;
- procedure SetAsInteger(AValue: Longint); override;
- procedure SetAsString(const AValue: string); override;
- procedure SetVarValue(const AValue: JSValue); override;
- public
- constructor Create(AOwner: TComponent); override;
- Function CheckRange(AValue : Double) : Boolean;
- property Value: Double read GetAsFloat write SetAsFloat;
- published
- property Currency: Boolean read FCurrency write SetCurrency default False;
- property MaxValue: Double read FMaxValue write FMaxValue;
- property MinValue: Double read FMinValue write FMinValue;
- property Precision: Longint read FPrecision write SetPrecision default 15; // min 2 instellen, delphi compat
- end;
- { TBooleanField }
- TBooleanField = class(TField)
- private
- FDisplayValues : String;
- // First byte indicates uppercase or not.
- FDisplays : Array[Boolean,Boolean] of string;
- Procedure SetDisplayValues(const AValue : String);
- protected
- function GetAsBoolean: Boolean; override;
- function GetAsString: string; override;
- function GetAsJSValue: JSValue; override;
- function GetAsInteger: Longint; override;
- function GetDefaultWidth: Longint; override;
- procedure SetAsBoolean(AValue: Boolean); override;
- procedure SetAsString(const AValue: string); override;
- procedure SetAsInteger(AValue: Longint); override;
- procedure SetVarValue(const AValue: JSValue); override;
- public
- constructor Create(AOwner: TComponent); override;
- property Value: Boolean read GetAsBoolean write SetAsBoolean;
- published
- property DisplayValues: string read FDisplayValues write SetDisplayValues;
- end;
- { TDateTimeField }
- TDateTimeField = class(TField)
- private
- FDisplayFormat : String;
- procedure SetDisplayFormat(const AValue: string);
- protected
- Function ConvertToDateTime(aValue : JSValue; aRaiseError : Boolean) : TDateTime; virtual;
- Function DateTimeToNativeDateTime(aValue : TDateTime) : JSValue; virtual;
- function GetAsDateTime: TDateTime; override;
- function GetAsFloat: Double; override;
- function GetAsString: string; override;
- function GetAsJSValue: JSValue; override;
- function GetDataSize: Integer; override;
- procedure GetText(var AText: string; ADisplayText: Boolean); override;
- procedure SetAsDateTime(AValue: TDateTime); override;
- procedure SetAsFloat(AValue: Double); override;
- procedure SetAsString(const AValue: string); override;
- procedure SetVarValue(const AValue: JSValue); override;
- public
- constructor Create(AOwner: TComponent); override;
- property Value: TDateTime read GetAsDateTime write SetAsDateTime;
- published
- property DisplayFormat: string read FDisplayFormat write SetDisplayFormat;
- end;
- { TDateField }
- TDateField = class(TDateTimeField)
- public
- constructor Create(AOwner: TComponent); override;
- end;
- { TTimeField }
- TTimeField = class(TDateTimeField)
- protected
- procedure SetAsString(const AValue: string); override;
- public
- constructor Create(AOwner: TComponent); override;
- end;
- { TBinaryField }
- TBinaryField = class(TField)
- protected
- class procedure CheckTypeSize(AValue: Longint); override;
- Function BlobToBytes(aValue : JSValue) : TBytes; virtual;
- Function BytesToBlob(aValue : TBytes) : JSValue; virtual;
- function GetAsString: string; override;
- function GetAsJSValue: JSValue; override;
- function GetValue(var AValue: TBytes): Boolean;
- procedure SetAsString(const AValue: string); override;
- procedure SetVarValue(const AValue: JSValue); override;
- public
- constructor Create(AOwner: TComponent); override;
- published
- property Size default 16;
- end;
- { TBytesField }
- { TBlobField }
- TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);
- // TBlobType = ftBlob..ftMemo;
- TBlobField = class(TBinaryField)
- private
- FModified : Boolean;
- // Wrapper that retrieves FDataType as a TBlobType
- // function GetBlobType: TBlobType;
- // Wrapper that calls SetFieldType
- // procedure SetBlobType(AValue: TBlobType);
- protected
- class procedure CheckTypeSize(AValue: Longint); override;
- function GetBlobSize: Longint; virtual;
- function GetIsNull: Boolean; override;
- procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
- public
- constructor Create(AOwner: TComponent); override;
- procedure Clear; override;
- class function IsBlob: Boolean; override;
- procedure SetFieldType(AValue: TFieldType); override;
- property BlobSize: Longint read GetBlobSize;
- property Modified: Boolean read FModified write FModified;
- property Value: string read GetAsString write SetAsString;
- published
- // property BlobType: TBlobType read GetBlobType write SetBlobType; // default ftBlob;
- property Size default 0;
- end;
- { TMemoField }
- TMemoField = class(TBlobField)
- public
- constructor Create(AOwner: TComponent); override;
- end;
- { TVariantField }
- TVariantField = class(TField)
- protected
- class procedure CheckTypeSize(aValue{%H-}: Integer); override;
- function GetAsBoolean: Boolean; override;
- procedure SetAsBoolean(aValue: Boolean); override;
- function GetAsDateTime: TDateTime; override;
- procedure SetAsDateTime(aValue: TDateTime); override;
- function GetAsFloat: Double; override;
- procedure SetAsFloat(aValue: Double); override;
- function GetAsInteger: Longint; override;
- procedure SetAsInteger(AValue: Longint); override;
- function GetAsString: string; override;
- procedure SetAsString(const aValue: string); override;
- function GetAsJSValue: JSValue; override;
- procedure SetVarValue(const aValue: JSValue); override;
- public
- constructor Create(AOwner: TComponent); override;
- end;
- { TIndexDef }
- TIndexDefs = class;
- TIndexOption = (ixPrimary, ixUnique, ixDescending, ixCaseInsensitive,
- ixExpression, ixNonMaintained);
- TIndexOptions = set of TIndexOption;
- TIndexDef = class(TNamedItem)
- Private
- FCaseinsFields: string;
- FDescFields: string;
- FExpression : String;
- FFields : String;
- FOptions : TIndexOptions;
- FSource : String;
- protected
- function GetExpression: string;
- procedure SetCaseInsFields(const AValue: string); virtual;
- procedure SetDescFields(const AValue: string);
- procedure SetExpression(const AValue: string);
- public
- constructor Create(Owner: TIndexDefs; const AName, TheFields: string;
- TheOptions: TIndexOptions); overload;
- procedure Assign(Source: TPersistent); override;
- published
- property Expression: string read GetExpression write SetExpression;
- property Fields: string read FFields write FFields;
- property CaseInsFields: string read FCaseinsFields write SetCaseInsFields;
- property DescFields: string read FDescFields write SetDescFields;
- property Options: TIndexOptions read FOptions write FOptions;
- property Source: string read FSource write FSource;
- end;
- TIndexDefClass = class of TIndexDef;
- { TIndexDefs }
- TIndexDefs = class(TDefCollection)
- Private
- Function GetItem(Index: Integer): TIndexDef; reintroduce;
- Procedure SetItem(Index: Integer; Value: TIndexDef); reintroduce;
- public
- constructor Create(ADataSet: TDataSet); virtual; overload;
- procedure Add(const Name, Fields: string; Options: TIndexOptions); reintroduce;
- Function AddIndexDef: TIndexDef;
- function Find(const IndexName: string): TIndexDef; reintroduce;
- function FindIndexForFields(const Fields{%H-}: string): TIndexDef;
- function GetIndexForFields(const Fields: string;
- CaseInsensitive: Boolean): TIndexDef;
- procedure Update; overload; virtual;
- Property Items[Index: Integer] : TIndexDef read GetItem write SetItem; default;
- end;
- { TCheckConstraint }
- TCheckConstraint = class(TCollectionItem)
- Private
- FCustomConstraint : String;
- FErrorMessage : String;
- FFromDictionary : Boolean;
- FImportedConstraint : String;
- public
- procedure Assign(Source{%H-}: TPersistent); override;
- // function GetDisplayName: string; override;
- published
- property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
- property ErrorMessage: string read FErrorMessage write FErrorMessage;
- property FromDictionary: Boolean read FFromDictionary write FFromDictionary;
- property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
- end;
- { TCheckConstraints }
- TCheckConstraints = class(TCollection)
- Private
- Function GetItem(Index{%H-} : Longint) : TCheckConstraint; reintroduce;
- Procedure SetItem(index{%H-} : Longint; Value{%H-} : TCheckConstraint); reintroduce;
- protected
- function GetOwner: TPersistent; override;
- public
- constructor Create(AOwner{%H-}: TPersistent); reintroduce;
- function Add: TCheckConstraint; reintroduce;
- property Items[Index: Longint]: TCheckConstraint read GetItem write SetItem; default;
- end;
- { TFieldsEnumerator }
- TFieldsEnumerator = class
- private
- FPosition: Integer;
- FFields: TFields;
- function GetCurrent: TField;
- public
- constructor Create(AFields: TFields); reintroduce;
- function MoveNext: Boolean;
- property Current: TField read GetCurrent;
- end;
- { TFields }
- TFields = Class(TObject)
- Private
- FDataset : TDataset;
- FFieldList : TFpList;
- FOnChange : TNotifyEvent;
- FValidFieldKinds : TFieldKinds;
- Protected
- Procedure ClearFieldDefs;
- Procedure Changed;
- Procedure CheckfieldKind(Fieldkind : TFieldKind; Field : TField);
- Function GetCount : Longint;
- Function GetField (Index : Integer) : TField;
- Procedure SetField(Index: Integer; Value: TField);
- Procedure SetFieldIndex (Field : TField;Value : Integer);
- Property OnChange : TNotifyEvent Read FOnChange Write FOnChange;
- Property ValidFieldKinds : TFieldKinds Read FValidFieldKinds;
- Public
- Constructor Create(ADataset : TDataset); reintroduce;
- Destructor Destroy;override;
- Procedure Add(Field : TField);
- Procedure CheckFieldName (Const Value : String);
- Procedure CheckFieldNames (Const Value : String);
- Procedure Clear;
- Function FindField (Const Value : String) : TField;
- Function FieldByName (Const Value : String) : TField;
- Function FieldByNumber(FieldNo : Integer) : TField;
- Function GetEnumerator: TFieldsEnumerator;
- Procedure GetFieldNames (Values : TStrings);
- Function IndexOf(Field : TField) : Longint;
- procedure Remove(Value : TField);
- Property Count : Integer Read GetCount;
- Property Dataset : TDataset Read FDataset;
- Property Fields [Index : Integer] : TField Read GetField Write SetField; default;
- end;
- TFieldsClass = Class of TFields;
- { TParam }
- TBlobData = TBytes; // Delphi defines it as alias to TBytes
- TParamBinding = array of integer;
- TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult);
- TParamTypes = set of TParamType;
- TParamStyle = (psInterbase,psPostgreSQL,psSimulated);
- TParams = class;
- TParam = class(TCollectionItem)
- private
- FValue: JSValue;
- FPrecision: Integer;
- FNumericScale: Integer;
- FName: string;
- FDataType: TFieldType;
- FBound: Boolean;
- FParamType: TParamType;
- FSize: Integer;
- Function GetDataSet: TDataSet;
- Function IsParamStored: Boolean;
- protected
- Procedure AssignParam(Param: TParam);
- Procedure AssignTo(Dest: TPersistent); override;
- Function GetAsBoolean: Boolean;
- Function GetAsBytes: TBytes;
- Function GetAsDateTime: TDateTime;
- Function GetAsFloat: Double;
- Function GetAsInteger: Longint;
- Function GetAsLargeInt: NativeInt;
- Function GetAsMemo: string;
- Function GetAsString: string;
- Function GetAsJSValue: JSValue;
- Function GetDisplayName: string; override;
- Function GetIsNull: Boolean;
- Function IsEqual(AValue: TParam): Boolean;
- Procedure SetAsBlob(const AValue: TBlobData);
- Procedure SetAsBoolean(AValue: Boolean);
- Procedure SetAsBytes(const AValue{%H-}: TBytes);
- Procedure SetAsDate(const AValue: TDateTime);
- Procedure SetAsDateTime(const AValue: TDateTime);
- Procedure SetAsFloat(const AValue: Double);
- Procedure SetAsInteger(AValue: Longint);
- Procedure SetAsLargeInt(AValue: NativeInt);
- Procedure SetAsMemo(const AValue: string);
- Procedure SetAsString(const AValue: string);
- Procedure SetAsTime(const AValue: TDateTime);
- Procedure SetAsJSValue(const AValue: JSValue);
- Procedure SetDataType(AValue: TFieldType);
- Procedure SetText(const AValue: string);
- public
- constructor Create(ACollection: TCollection); overload; override;
- constructor Create(AParams: TParams; AParamType: TParamType); reintroduce; overload;
- Procedure Assign(Source: TPersistent); override;
- Procedure AssignField(Field: TField);
- Procedure AssignToField(Field: TField);
- Procedure AssignFieldValue(Field: TField; const AValue: JSValue);
- Procedure AssignFromField(Field : TField);
- Procedure Clear;
- Property AsBlob : TBlobData read GetAsBytes write SetAsBytes;
- Property AsBoolean : Boolean read GetAsBoolean write SetAsBoolean;
- Property AsBytes : TBytes read GetAsBytes write SetAsBytes;
- Property AsDate : TDateTime read GetAsDateTime write SetAsDate;
- Property AsDateTime : TDateTime read GetAsDateTime write SetAsDateTime;
- Property AsFloat : Double read GetAsFloat write SetAsFloat;
- Property AsInteger : LongInt read GetAsInteger write SetAsInteger;
- Property AsLargeInt : NativeInt read GetAsLargeInt write SetAsLargeInt;
- Property AsMemo : string read GetAsMemo write SetAsMemo;
- Property AsSmallInt : LongInt read GetAsInteger write SetAsInteger;
- Property AsString : string read GetAsString write SetAsString;
- Property AsTime : TDateTime read GetAsDateTime write SetAsTime;
- Property Bound : Boolean read FBound write FBound;
- Property Dataset : TDataset Read GetDataset;
- Property IsNull : Boolean read GetIsNull;
- Property Text : string read GetAsString write SetText;
- published
- Property DataType : TFieldType read FDataType write SetDataType;
- Property Name : string read FName write FName;
- Property NumericScale : Integer read FNumericScale write FNumericScale default 0;
- Property ParamType : TParamType read FParamType write FParamType;
- Property Precision : Integer read FPrecision write FPrecision default 0;
- Property Size : Integer read FSize write FSize default 0;
- Property Value : JSValue read GetAsJSValue write SetAsJSValue stored IsParamStored;
- end;
- TParamClass = Class of TParam;
- { TParams }
- TParams = class(TCollection)
- private
- FOwner: TPersistent;
- Function GetItem(Index: Integer): TParam; reintroduce;
- Function GetParamValue(const ParamName: string): JSValue;
- Procedure SetItem(Index: Integer; Value: TParam); reintroduce;
- Procedure SetParamValue(const ParamName: string; const Value: JSValue);
- protected
- Procedure AssignTo(Dest: TPersistent); override;
- Function GetDataSet: TDataSet;
- Function GetOwner: TPersistent; override;
- Class Function ParamClass : TParamClass; virtual;
- public
- Constructor Create(AOwner: TPersistent; AItemClass : TCollectionItemClass); overload;
- Constructor Create(AOwner: TPersistent); overload;
- Constructor Create; overload; reintroduce;
- Procedure AddParam(Value: TParam);
- Procedure AssignValues(Value: TParams);
- Function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType): TParam;
- Function FindParam(const Value: string): TParam;
- Procedure GetParamList(List: TList; const ParamNames: string);
- Function IsEqual(Value: TParams): Boolean;
- Function ParamByName(const Value: string): TParam;
- Function ParseSQL(SQL: String; DoCreate: Boolean): String; overload;
- Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle): String; overload;
- Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding): String; overload;
- Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding; out ReplaceString : string): String; overload;
- Procedure RemoveParam(Value: TParam);
- Procedure CopyParamValuesFromDataset(ADataset : TDataset; CopyBound : Boolean);
- Property Dataset : TDataset Read GetDataset;
- Property Items[Index: Integer] : TParam read GetItem write SetItem; default;
- Property ParamValues[const ParamName: string] : JSValue read GetParamValue write SetParamValue;
- end;
- { TDataSet }
-
- TBookmarkFlag = (bfCurrent, bfBOF, bfEOF, bfInserted);
- TBookmark = record
- Data : JSValue;
- Flag : TBookmarkFlag;
- end; // Bookmark is always the index in the data array.
- TBookmarkStr = string; // JSON encoded version of the above
- TGetMode = (gmCurrent, gmNext, gmPrior);
- TGetResult = (grOK, grBOF, grEOF, grError);
- TResyncMode = set of (rmExact, rmCenter);
- TDataAction = (daFail, daAbort, daRetry);
- TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
- TUpdateKind = (ukModify, ukInsert, ukDelete);
- TLocateOption = (loCaseInsensitive, loPartialKey);
- TLocateOptions = set of TLocateOption;
- TDataOperation = procedure of object;
- TDataSetNotifyEvent = procedure(DataSet: TDataSet) of object;
- TDataSetErrorEvent = procedure(DataSet: TDataSet; E: EDatabaseError;
- var DataAction: TDataAction) of object;
- TFilterOption = (foCaseInsensitive, foNoPartialCompare);
- TFilterOptions = set of TFilterOption;
- TLoadOption = (loNoOpen,loNoEvents,loAtEOF);
- TLoadOptions = Set of TLoadOption;
- TDatasetLoadEvent = procedure(DataSet: TDataSet; Data : JSValue) of object;
- TDatasetLoadFailEvent = procedure(DataSet: TDataSet; ID : Integer; Const ErrorMsg : String) of object;
- TFilterRecordEvent = procedure(DataSet: TDataSet;
- var Accept: Boolean) of object;
- TDatasetClass = Class of TDataset;
- TRecordState = (rsNew,rsClean,rsUpdate,rsDelete);
- TDataRecord = record
- data : JSValue;
- state : TRecordState;
- bookmark : JSValue;
- bookmarkFlag : TBookmarkFlag;
- end;
- TBuffers = Array of TDataRecord;
- TResolveInfo = record
- Data : JSValue;
- Status : TUpdateStatus;
- Error : String; // Only filled on error.
- BookMark : TBookmark;
- _private : JSValue; // for use by descendents of TDataset
- end;
- TResolveInfoArray = Array of TResolveInfo;
- // Record so we can extend later on
- TResolveResults = record
- Records : TResolveInfoArray;
- end;
- TOnRecordResolveEvent = Procedure (Sender : TDataset; info : TResolveInfo) of object;
- TApplyUpdatesEvent = Procedure (Sender : TDataset; info : TResolveResults) of object;
- {------------------------------------------------------------------------------}
- TDataSet = class(TComponent)
- Private
- FAfterApplyUpdates: TApplyUpdatesEvent;
- FAfterLoad: TDatasetNotifyEvent;
- FBeforeApplyUpdates: TDatasetNotifyEvent;
- FBeforeLoad: TDatasetNotifyEvent;
- FBlockReadSize: Integer;
- FCalcBuffer: TDataRecord;
- FCalcFieldsCount: Longint;
- FOnLoadFail: TDatasetLoadFailEvent;
- FOnRecordResolved: TOnRecordResolveEvent;
- FOpenAfterRead : boolean;
- FActiveRecord: Longint;
- FAfterCancel: TDataSetNotifyEvent;
- FAfterClose: TDataSetNotifyEvent;
- FAfterDelete: TDataSetNotifyEvent;
- FAfterEdit: TDataSetNotifyEvent;
- FAfterInsert: TDataSetNotifyEvent;
- FAfterOpen: TDataSetNotifyEvent;
- FAfterPost: TDataSetNotifyEvent;
- FAfterRefresh: TDataSetNotifyEvent;
- FAfterScroll: TDataSetNotifyEvent;
- FAutoCalcFields: Boolean;
- FBOF: Boolean;
- FBeforeCancel: TDataSetNotifyEvent;
- FBeforeClose: TDataSetNotifyEvent;
- FBeforeDelete: TDataSetNotifyEvent;
- FBeforeEdit: TDataSetNotifyEvent;
- FBeforeInsert: TDataSetNotifyEvent;
- FBeforeOpen: TDataSetNotifyEvent;
- FBeforePost: TDataSetNotifyEvent;
- FBeforeRefresh: TDataSetNotifyEvent;
- FBeforeScroll: TDataSetNotifyEvent;
- FBlobFieldCount: Longint;
- FBuffers : TBuffers;
- // The actual length of FBuffers is FBufferCount+1
- FBufferCount: Longint;
- FConstraints: TCheckConstraints;
- FDisableControlsCount : Integer;
- FDisableControlsState : TDatasetState;
- FCurrentRecord: Longint;
- FDataSources : TFPList;
- FDefaultFields: Boolean;
- FEOF: Boolean;
- FEnableControlsEvent : TDataEvent;
- FFieldList : TFields;
- FFieldDefs: TFieldDefs;
- FFilterOptions: TFilterOptions;
- FFilterText: string;
- FFiltered: Boolean;
- FFound: Boolean;
- FInternalCalcFields: Boolean;
- FModified: Boolean;
- FOnCalcFields: TDataSetNotifyEvent;
- FOnDeleteError: TDataSetErrorEvent;
- FOnEditError: TDataSetErrorEvent;
- FOnFilterRecord: TFilterRecordEvent;
- FOnNewRecord: TDataSetNotifyEvent;
- FOnPostError: TDataSetErrorEvent;
- FRecordCount: Longint;
- FIsUniDirectional: Boolean;
- FState : TDataSetState;
- FInternalOpenComplete: Boolean;
- FDataProxy : TDataProxy;
- FDataRequestID : Integer;
- FUpdateBatchID : Integer;
- FChangeList : TFPList;
- FBatchList : TFPList;
- Procedure DoInsertAppend(DoAppend : Boolean);
- Procedure DoInternalOpen;
- Function GetBuffer (Index : longint) : TDataRecord;
- function GetDataProxy: TDataProxy;
- Procedure RegisterDataSource(ADataSource : TDataSource);
- procedure SetConstraints(Value: TCheckConstraints);
- procedure SetDataProxy(AValue: TDataProxy);
- Procedure ShiftBuffersForward;
- Procedure ShiftBuffersBackward;
- Function TryDoing (P : TDataOperation; Ev : TDatasetErrorEvent) : Boolean;
- Function GetActive : boolean;
- Procedure UnRegisterDataSource(ADataSource : TDataSource);
- procedure SetBlockReadSize(AValue: Integer); virtual;
- Procedure SetFieldDefs(AFieldDefs: TFieldDefs);
- procedure DoInsertAppendRecord(const Values: array of jsValue; DoAppend : boolean);
- // Callback for Tdataproxy.DoGetData;
- function ResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
- procedure HandleRequestresponse(ARequest: TDataRequest);
- protected
- // Proxy methods
- // Override this to integrate package in local data
- // call OnRecordResolved
- procedure DoOnRecordResolved(anUpdate: TRecordUpdateDescriptor); virtual;
- // Convert TRecordUpdateDescriptor to ResolveInfo
- function RecordUpdateDescriptorToResolveInfo(anUpdate: TRecordUpdateDescriptor): TResolveInfo; virtual;
- function DoResolveRecordUpdate(anUpdate{%H-}: TRecordUpdateDescriptor): Boolean; virtual;
- Function GetRecordUpdates(AList: TRecordUpdateDescriptorList) : Integer; virtual;
- procedure ResolveUpdateBatch(Sender: TObject; aBatch: TRecordUpdateBatch); virtual;
- Function DataPacketReceived(ARequest{%H-}: TDataRequest) : Boolean; virtual;
- function DoLoad(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean; virtual;
- function DoGetDataProxy: TDataProxy; virtual;
- Procedure InitChangeList; virtual;
- Procedure DoneChangeList; virtual;
- Procedure ClearChangeList;
- Function IndexInChangeList(aBookmark: TBookmark): Integer; virtual;
- Function AddToChangeList(aChange : TUpdateStatus) : TRecordUpdateDescriptor ; virtual;
- Procedure RemoveFromChangeList(R : TRecordUpdateDescriptor); virtual;
- Procedure DoApplyUpdates;
- procedure RecalcBufListSize;
- procedure ActivateBuffers; virtual;
- procedure BindFields(Binding: Boolean);
- procedure BlockReadNext; virtual;
- function BookmarkAvailable: Boolean;
- procedure CalculateFields(Var Buffer: TDataRecord); virtual;
- procedure CheckActive; virtual;
- procedure CheckInactive; virtual;
- procedure CheckBiDirectional;
- procedure Loaded; override;
- procedure ClearBuffers; virtual;
- procedure ClearCalcFields(var Buffer{%H-}: TDataRecord); virtual;
- procedure CloseBlob(Field{%H-}: TField); virtual;
- procedure CloseCursor; virtual;
- procedure CreateFields; virtual;
- procedure DataEvent(Event: TDataEvent; Info: JSValue); virtual;
- procedure DestroyFields; virtual;
- procedure DoAfterCancel; virtual;
- procedure DoAfterClose; virtual;
- procedure DoAfterDelete; virtual;
- procedure DoAfterEdit; virtual;
- procedure DoAfterInsert; virtual;
- procedure DoAfterOpen; virtual;
- procedure DoAfterPost; virtual;
- procedure DoAfterScroll; virtual;
- procedure DoAfterRefresh; virtual;
- procedure DoBeforeCancel; virtual;
- procedure DoBeforeClose; virtual;
- procedure DoBeforeDelete; virtual;
- procedure DoBeforeEdit; virtual;
- procedure DoBeforeInsert; virtual;
- procedure DoBeforeOpen; virtual;
- procedure DoBeforePost; virtual;
- procedure DoBeforeScroll; virtual;
- procedure DoBeforeRefresh; virtual;
- procedure DoOnCalcFields; virtual;
- procedure DoOnNewRecord; virtual;
- procedure DoBeforeLoad; virtual;
- procedure DoAfterLoad; virtual;
- procedure DoBeforeApplyUpdates; virtual;
- procedure DoAfterApplyUpdates(const ResolveInfo: TResolveResults); virtual;
- function FieldByNumber(FieldNo: Longint): TField;
- function FindRecord(Restart{%H-}, GoForward{%H-}: Boolean): Boolean; virtual;
- function GetBookmarkStr: TBookmarkStr; virtual;
- procedure GetCalcFields(Var Buffer: TDataRecord); virtual;
- function GetCanModify: Boolean; virtual;
- procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
- function GetFieldClass(FieldType: TFieldType): TFieldClass; virtual;
- Function GetfieldCount : Integer;
- function GetFieldValues(const FieldName : string) : JSValue; virtual;
- function GetIsIndexField(Field{%H-}: TField): Boolean; virtual;
- function GetIndexDefs(IndexDefs : TIndexDefs; IndexTypes : TIndexOptions) : TIndexDefs;
- function GetNextRecords: Longint; virtual;
- function GetNextRecord: Boolean; virtual;
- function GetPriorRecords: Longint; virtual;
- function GetPriorRecord: Boolean; virtual;
- function GetRecordCount: Longint; virtual;
- function GetRecNo: Longint; virtual;
- procedure InitFieldDefs; virtual;
- procedure InitFieldDefsFromfields;
- procedure InitRecord(var Buffer: TDataRecord); virtual;
- procedure InternalCancel; virtual;
- procedure InternalEdit; virtual;
- procedure InternalInsert; virtual;
- procedure InternalRefresh; virtual;
- procedure OpenCursor(InfoQuery: Boolean); virtual;
- procedure OpenCursorcomplete; virtual;
- procedure RefreshInternalCalcFields(Var Buffer{%H-}: TDataRecord); virtual;
- procedure RestoreState(const Value: TDataSetState);
- Procedure SetActive (Value : Boolean); virtual;
- procedure SetBookmarkStr(const Value: TBookmarkStr); virtual;
- procedure SetBufListSize(Value: Longint); virtual;
- procedure SetChildOrder(Child: TComponent; Order: Longint); override;
- procedure SetCurrentRecord(Index: Longint); virtual;
- procedure SetDefaultFields(const Value: Boolean);
- procedure SetFiltered(Value: Boolean); virtual;
- procedure SetFilterOptions(Value: TFilterOptions); virtual;
- procedure SetFilterText(const Value: string); virtual;
- procedure SetFieldValues(const FieldName: string; Value: JSValue); virtual;
- procedure SetFound(const Value: Boolean); virtual;
- procedure SetModified(Value: Boolean);
- procedure SetName(const NewName: TComponentName); override;
- procedure SetOnFilterRecord(const Value: TFilterRecordEvent); virtual;
- procedure SetRecNo(Value{%H-}: Longint); virtual;
- procedure SetState(Value: TDataSetState);
- function SetTempState(const Value: TDataSetState): TDataSetState;
- Function TempBuffer: TDataRecord;
- procedure UpdateIndexDefs; virtual;
- property ActiveRecord: Longint read FActiveRecord;
- property CurrentRecord: Longint read FCurrentRecord;
- property BlobFieldCount: Longint read FBlobFieldCount;
- property Buffers[Index: Longint]: TDataRecord read GetBuffer;
- property BufferCount: Longint read FBufferCount;
- property CalcBuffer: TDataRecord read FCalcBuffer;
- property CalcFieldsCount: Longint read FCalcFieldsCount;
- property InternalCalcFields: Boolean read FInternalCalcFields;
- property Constraints: TCheckConstraints read FConstraints write SetConstraints;
- function AllocRecordBuffer: TDataRecord; virtual;
- procedure FreeRecordBuffer(var Buffer{%H-}: TDataRecord); virtual;
- procedure GetBookmarkData(Buffer{%H-}: TDataRecord; var Data{%H-}: TBookmark); virtual;
- function GetBookmarkFlag(Buffer{%H-}: TDataRecord): TBookmarkFlag; virtual;
- function GetDataSource: TDataSource; virtual;
- function GetRecordSize: Word; virtual;
- procedure InternalAddRecord(Buffer{%H-}: Pointer; AAppend{%H-}: Boolean); virtual;
- procedure InternalDelete; virtual;
- procedure InternalFirst; virtual;
- procedure InternalGotoBookmark(ABookmark{%H-}: TBookmark); virtual;
- procedure InternalHandleException(E: Exception); virtual;
- procedure InternalInitRecord(var Buffer{%H-}: TDataRecord); virtual;
- procedure InternalLast; virtual;
- procedure InternalPost; virtual;
- procedure InternalSetToRecord(Buffer{%H-}: TDataRecord); virtual;
- procedure SetBookmarkFlag(Var Buffer{%H-}: TDataRecord; Value{%H-}: TBookmarkFlag); virtual;
- procedure SetBookmarkData(Var Buffer{%H-}: TDataRecord; Data{%H-}: TBookmark); virtual;
- procedure SetUniDirectional(const Value: Boolean);
- procedure Notification(AComponent: TComponent; Operation: TOperation); override;
- // These use the active buffer
- function GetFieldData(Field: TField): JSValue; virtual; overload;
- procedure SetFieldData(Field: TField; AValue : JSValue); virtual; overload;
- function GetFieldData(Field: TField; Buffer: TDatarecord): JSValue; virtual; overload;
- procedure SetFieldData(Field: TField; var Buffer: TDatarecord; AValue : JSValue); virtual; overload;
- class function FieldDefsClass : TFieldDefsClass; virtual;
- class function FieldsClass : TFieldsClass; virtual;
- protected { abstract methods }
- function GetRecord(var Buffer: TDataRecord; GetMode: TGetMode; DoCheck: Boolean): TGetResult; virtual; abstract;
- procedure InternalClose; virtual; abstract;
- procedure InternalOpen; virtual; abstract;
- procedure InternalInitFieldDefs; virtual; abstract;
- function IsCursorOpen: Boolean; virtual; abstract;
- property DataProxy : TDataProxy Read GetDataProxy Write SetDataProxy;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- function ActiveBuffer: TDataRecord;
- procedure Append;
- procedure AppendRecord(const Values: array of jsValue);
- function BookmarkValid(ABookmark{%H-}: TBookmark): Boolean; virtual;
- function ConvertToDateTime(aValue : JSValue; ARaiseException : Boolean) : TDateTime; virtual;
- function ConvertDateTimeToNative(aValue : TDateTime) : JSValue; virtual;
- Class function DefaultConvertToDateTime(aValue : JSValue; ARaiseException{%H-} : Boolean) : TDateTime; virtual;
- Class function DefaultConvertDateTimeToNative(aValue : TDateTime) : JSValue; virtual;
- Function BlobDataToBytes(aValue : JSValue) : TBytes; virtual;
- Class Function DefaultBlobDataToBytes(aValue : JSValue) : TBytes; virtual;
- Function BytesToBlobData(aValue : TBytes) : JSValue ; virtual;
- Class Function DefaultBytesToBlobData(aValue : TBytes) : JSValue; virtual;
- procedure Cancel; virtual;
- procedure CheckBrowseMode;
- procedure ClearFields;
- procedure Close;
- Procedure ApplyUpdates;
- function ControlsDisabled: Boolean;
- function CompareBookmarks(Bookmark1{%H-}, Bookmark2{%H-}: TBookmark): Longint; virtual;
- procedure CursorPosChanged;
- procedure Delete; virtual;
- procedure DisableControls;
- procedure Edit;
- procedure EnableControls;
- function FieldByName(const FieldName: string): TField;
- function FindField(const FieldName: string): TField;
- function FindFirst: Boolean; virtual;
- function FindLast: Boolean; virtual;
- function FindNext: Boolean; virtual;
- function FindPrior: Boolean; virtual;
- procedure First;
- procedure FreeBookmark(ABookmark{%H-}: TBookmark); virtual;
- function GetBookmark: TBookmark; virtual;
- function GetCurrentRecord(Buffer{%H-}: TDataRecord): Boolean; virtual;
- procedure GetFieldList(List: TList; const FieldNames: string); overload;
- procedure GetFieldList(List: TFPList; const FieldNames: string); overload;
- procedure GetFieldNames(List: TStrings);
- procedure GotoBookmark(const ABookmark: TBookmark);
- procedure Insert; reintroduce;
- procedure InsertRecord(const Values: array of JSValue);
- function IsEmpty: Boolean;
- function IsLinkedTo(ADataSource: TDataSource): Boolean;
- function IsSequenced: Boolean; virtual;
- procedure Last;
- Function Load(aOptions : TLoadOptions; aAfterLoad : TDatasetLoadEvent) : Boolean;
- function Locate(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; Options{%H-}: TLocateOptions) : boolean; virtual;
- function Lookup(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; const ResultFields{%H-}: string): JSValue; virtual;
- function MoveBy(Distance: Longint): Longint;
- procedure Next;
- procedure Open;
- procedure Post; virtual;
- procedure Prior;
- procedure Refresh;
- procedure Resync(Mode: TResyncMode); virtual;
- procedure SetFields(const Values: array of JSValue);
- procedure UpdateCursorPos;
- procedure UpdateRecord;
- Function GetPendingUpdates : TResolveInfoArray;
- function UpdateStatus: TUpdateStatus; virtual;
- property BlockReadSize: Integer read FBlockReadSize write SetBlockReadSize;
- property BOF: Boolean read FBOF;
- property Bookmark: TBookmark read GetBookmark write GotoBookmark;
- property CanModify: Boolean read GetCanModify;
- property DataSource: TDataSource read GetDataSource;
- property DefaultFields: Boolean read FDefaultFields;
- property EOF: Boolean read FEOF;
- property FieldCount: Longint read GetFieldCount;
- property FieldDefs: TFieldDefs read FFieldDefs write SetFieldDefs;
- property Found: Boolean read FFound;
- property Modified: Boolean read FModified;
- property IsUniDirectional: Boolean read FIsUniDirectional default False;
- property RecordCount: Longint read GetRecordCount;
- property RecNo: Longint read GetRecNo write SetRecNo;
- property RecordSize: Word read GetRecordSize;
- property State: TDataSetState read FState;
- property Fields : TFields read FFieldList;
- property FieldValues[FieldName : string] : JSValue read GetFieldValues write SetFieldValues; default;
- property Filter: string read FFilterText write SetFilterText;
- property Filtered: Boolean read FFiltered write SetFiltered default False;
- property FilterOptions: TFilterOptions read FFilterOptions write SetFilterOptions;
- property Active: Boolean read GetActive write SetActive default False;
- property AutoCalcFields: Boolean read FAutoCalcFields write FAutoCalcFields default true;
- property BeforeOpen: TDataSetNotifyEvent read FBeforeOpen write FBeforeOpen;
- property AfterOpen: TDataSetNotifyEvent read FAfterOpen write FAfterOpen;
- property BeforeClose: TDataSetNotifyEvent read FBeforeClose write FBeforeClose;
- property AfterClose: TDataSetNotifyEvent read FAfterClose write FAfterClose;
- property BeforeInsert: TDataSetNotifyEvent read FBeforeInsert write FBeforeInsert;
- property AfterInsert: TDataSetNotifyEvent read FAfterInsert write FAfterInsert;
- property BeforeEdit: TDataSetNotifyEvent read FBeforeEdit write FBeforeEdit;
- property AfterEdit: TDataSetNotifyEvent read FAfterEdit write FAfterEdit;
- property BeforePost: TDataSetNotifyEvent read FBeforePost write FBeforePost;
- property AfterPost: TDataSetNotifyEvent read FAfterPost write FAfterPost;
- property BeforeCancel: TDataSetNotifyEvent read FBeforeCancel write FBeforeCancel;
- property AfterCancel: TDataSetNotifyEvent read FAfterCancel write FAfterCancel;
- property BeforeDelete: TDataSetNotifyEvent read FBeforeDelete write FBeforeDelete;
- property AfterDelete: TDataSetNotifyEvent read FAfterDelete write FAfterDelete;
- property BeforeScroll: TDataSetNotifyEvent read FBeforeScroll write FBeforeScroll;
- property AfterScroll: TDataSetNotifyEvent read FAfterScroll write FAfterScroll;
- property BeforeRefresh: TDataSetNotifyEvent read FBeforeRefresh write FBeforeRefresh;
- property BeforeLoad : TDatasetNotifyEvent Read FBeforeLoad Write FBeforeLoad;
- Property AfterLoad : TDatasetNotifyEvent Read FAfterLoad Write FAfterLoad;
- Property BeforeApplyUpdates : TDatasetNotifyEvent Read FBeforeApplyUpdates Write FBeforeApplyUpdates;
- Property AfterApplyUpdates : TApplyUpdatesEvent Read FAfterApplyUpdates Write FAfterApplyUpdates;
- property AfterRefresh: TDataSetNotifyEvent read FAfterRefresh write FAfterRefresh;
- property OnCalcFields: TDataSetNotifyEvent read FOnCalcFields write FOnCalcFields;
- property OnDeleteError: TDataSetErrorEvent read FOnDeleteError write FOnDeleteError;
- property OnEditError: TDataSetErrorEvent read FOnEditError write FOnEditError;
- property OnFilterRecord: TFilterRecordEvent read FOnFilterRecord write SetOnFilterRecord;
- property OnNewRecord: TDataSetNotifyEvent read FOnNewRecord write FOnNewRecord;
- Property OnRecordResolved : TOnRecordResolveEvent Read FOnRecordResolved Write FOnRecordResolved;
- property OnPostError: TDataSetErrorEvent read FOnPostError write FOnPostError;
- property OnLoadFail : TDatasetLoadFailEvent Read FOnLoadFail Write FOnLoadFail;
- end;
- { TDataLink }
- TDataLink = class(TPersistent)
- private
- FFirstRecord,
- FBufferCount : Integer;
- FActive,
- FDataSourceFixed,
- FEditing,
- FReadOnly,
- FUpdatingRecord,
- FVisualControl : Boolean;
- FDataSource : TDataSource;
- Function CalcFirstRecord(Index : Integer) : Integer;
- Procedure CalcRange;
- Procedure CheckActiveAndEditing;
- Function GetDataset : TDataset;
- procedure SetActive(AActive: Boolean);
- procedure SetDataSource(Value: TDataSource);
- Procedure SetReadOnly(Value : Boolean);
- protected
- procedure ActiveChanged; virtual;
- procedure CheckBrowseMode; virtual;
- procedure DataEvent(Event: TDataEvent; Info: JSValue); virtual;
- procedure DataSetChanged; virtual;
- procedure DataSetScrolled(Distance{%H-}: Integer); virtual;
- procedure EditingChanged; virtual;
- procedure FocusControl(Field{%H-}: JSValue); virtual;
- function GetActiveRecord: Integer; virtual;
- function GetBOF: Boolean; virtual;
- function GetBufferCount: Integer; virtual;
- function GetEOF: Boolean; virtual;
- function GetRecordCount: Integer; virtual;
- procedure LayoutChanged; virtual;
- function MoveBy(Distance: Integer): Integer; virtual;
- procedure RecordChanged(Field{%H-}: TField); virtual;
- procedure SetActiveRecord(Value: Integer); virtual;
- procedure SetBufferCount(Value: Integer); virtual;
- procedure UpdateData; virtual;
- property VisualControl: Boolean read FVisualControl write FVisualControl;
- property FirstRecord: Integer read FFirstRecord write FFirstRecord;
- public
- constructor Create; reintroduce;
- destructor Destroy; override;
- function Edit: Boolean;
- procedure UpdateRecord;
- property Active: Boolean read FActive;
- property ActiveRecord: Integer read GetActiveRecord write SetActiveRecord;
- property BOF: Boolean read GetBOF;
- property BufferCount: Integer read GetBufferCount write SetBufferCount;
- property DataSet: TDataSet read GetDataSet;
- property DataSource: TDataSource read FDataSource write SetDataSource;
- property DataSourceFixed: Boolean read FDataSourceFixed write FDataSourceFixed;
- property Editing: Boolean read FEditing;
- property Eof: Boolean read GetEOF;
- property ReadOnly: Boolean read FReadOnly write SetReadOnly;
- property RecordCount: Integer read GetRecordCount;
- end;
- { TDetailDataLink }
- TDetailDataLink = class(TDataLink)
- protected
- function GetDetailDataSet: TDataSet; virtual;
- public
- property DetailDataSet: TDataSet read GetDetailDataSet;
- end;
- { TMasterDataLink }
- TMasterDataLink = class(TDetailDataLink)
- private
- FDetailDataSet: TDataSet;
- FFieldNames: string;
- FFields: TList;
- FOnMasterChange: TNotifyEvent;
- FOnMasterDisable: TNotifyEvent;
- procedure SetFieldNames(const Value: string);
- protected
- procedure ActiveChanged; override;
- procedure CheckBrowseMode; override;
- function GetDetailDataSet: TDataSet; override;
- procedure LayoutChanged; override;
- procedure RecordChanged(Field: TField); override;
- Procedure DoMasterDisable; virtual;
- Procedure DoMasterChange; virtual;
- public
- constructor Create(ADataSet: TDataSet);virtual; reintroduce;
- destructor Destroy; override;
- property FieldNames: string read FFieldNames write SetFieldNames;
- property Fields: TList read FFields;
- property OnMasterChange: TNotifyEvent read FOnMasterChange write FOnMasterChange;
- property OnMasterDisable: TNotifyEvent read FOnMasterDisable write FOnMasterDisable;
- end;
- { TMasterParamsDataLink }
- TMasterParamsDataLink = Class(TMasterDataLink)
- Private
- FParams : TParams;
- Procedure SetParams(AValue : TParams);
- Protected
- Procedure DoMasterDisable; override;
- Procedure DoMasterChange; override;
- Public
- constructor Create(ADataSet: TDataSet); override;
- Procedure RefreshParamNames; virtual;
- Procedure CopyParamsFromMaster(CopyBound : Boolean); virtual;
- Property Params : TParams Read FParams Write SetParams;
- end;
- { TDataSource }
- TDataChangeEvent = procedure(Sender: TObject; Field: TField) of object;
- TDataSource = class(TComponent)
- private
- FDataSet: TDataSet;
- FDataLinks: TList;
- FEnabled: Boolean;
- FAutoEdit: Boolean;
- FState: TDataSetState;
- FOnStateChange: TNotifyEvent;
- FOnDataChange: TDataChangeEvent;
- FOnUpdateData: TNotifyEvent;
- procedure DistributeEvent(Event: TDataEvent; Info: JSValue);
- procedure RegisterDataLink(DataLink: TDataLink);
- Procedure ProcessEvent(Event : TDataEvent; Info : JSValue);
- procedure SetDataSet(ADataSet: TDataSet);
- procedure SetEnabled(Value: Boolean);
- procedure UnregisterDataLink(DataLink: TDataLink);
- protected
- Procedure DoDataChange (Info : Pointer);virtual;
- Procedure DoStateChange; virtual;
- Procedure DoUpdateData;
- property DataLinks: TList read FDataLinks;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Edit;
- function IsLinkedTo(ADataSet{%H-}: TDataSet): Boolean;
- property State: TDataSetState read FState;
- published
- property AutoEdit: Boolean read FAutoEdit write FAutoEdit default True;
- property DataSet: TDataSet read FDataSet write SetDataSet;
- property Enabled: Boolean read FEnabled write SetEnabled default True;
- property OnStateChange: TNotifyEvent read FOnStateChange write FOnStateChange;
- property OnDataChange: TDataChangeEvent read FOnDataChange write FOnDataChange;
- property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData;
- end;
- { TDataRequest }
- TDataRequestResult = (rrFail,rrEOF,rrOK);
- TDataRequestEvent = Procedure (ARequest : TDataRequest) of object;
- TDataRequest = Class(TObject)
- private
- FBookmark: TBookMark;
- FCurrent: TBookMark;
- FDataset: TDataset;
- FErrorMsg: String;
- FEvent: TDatasetLoadEvent;
- FLoadOptions: TLoadOptions;
- FRequestID: Integer;
- FSuccess: TDataRequestResult;
- FData : JSValue;
- FAfterRequest : TDataRequestEvent;
- FDataProxy : TDataProxy;
- Protected
- Procedure DoAfterRequest;
- Public
- Constructor Create(aDataProxy : TDataProxy; aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent); virtual; reintroduce;
- property DataProxy : TDataProxy Read FDataProxy;
- Property Dataset : TDataset Read FDataset;
- Property Bookmark : TBookMark Read FBookmark;
- Property RequestID : Integer Read FRequestID;
- Property LoadOptions : TLoadOptions Read FLoadOptions;
- Property Current : TBookMark Read FCurrent;
- Property Success : TDataRequestResult Read FSuccess Write FSuccess;
- Property Event : TDatasetLoadEvent Read FEvent;
- Property ErrorMsg : String Read FErrorMsg Write FErrorMsg;
- Property Data : JSValue read FData Write FData;
- end;
- TDataRequestClass = Class of TDataRequest;
- { TRecordUpdateDescriptor }
- TRecordUpdateDescriptor = Class(TObject)
- private
- FBookmark: TBookmark;
- FData: JSValue;
- FDataset: TDataset;
- FProxy: TDataProxy;
- FResolveError: String;
- FServerData: JSValue;
- FStatus: TUpdateStatus;
- FOriginalStatus : TUpdateStatus;
- Protected
- Procedure SetStatus(aValue : TUpdateStatus); virtual;
- Procedure Reset;
- Public
- Constructor Create(aProxy : TDataProxy; aDataset : TDataset; aBookmark : TBookMark; AData : JSValue; AStatus : TUpdateStatus); reintroduce;
- Procedure Resolve(aData : JSValue);
- Procedure ResolveFailed(aError : String);
- Property Proxy : TDataProxy read FProxy;
- Property Dataset : TDataset Read FDataset;
- Property OriginalStatus : TUpdateStatus Read FOriginalStatus;
- Property Status : TUpdateStatus Read FStatus;
- Property ServerData : JSValue Read FServerData;
- Property Data : JSValue Read FData;
- Property Bookmark : TBookmark Read FBookmark;
- Property ResolveError : String Read FResolveError ;
- end;
- TRecordUpdateDescriptorClass = Class of TRecordUpdateDescriptor;
- { TRecordUpdateDescriptorList }
- TRecordUpdateDescriptorList = Class(TFPList)
- private
- function GetUpdate(AIndex : Integer): TRecordUpdateDescriptor;
- Public
- Property UpdateDescriptors[AIndex : Integer] : TRecordUpdateDescriptor Read GetUpdate; Default;
- end;
- { TRecordUpdateBatch }
- TUpdateBatchStatus = (ubsPending,ubsProcessing,ubsProcessed,ubsResolved);
- TResolveBatchEvent = Procedure (Sender : TObject; ARequest : TRecordUpdateBatch) of object;
- TRecordUpdateBatch = class(TObject)
- private
- FBatchID: Integer;
- FDataset: TDataset;
- FLastChangeIndex: Integer;
- FList: TRecordUpdateDescriptorList;
- FOnResolve: TResolveBatchEvent;
- FOwnsList: Boolean;
- FStatus: TUpdateBatchStatus;
- Protected
- Property LastChangeIndex : Integer Read FLastChangeIndex;
- Public
- Constructor Create (aBatchID : Integer; AList : TRecordUpdateDescriptorList; AOwnsList : Boolean); reintroduce;
- Destructor Destroy; override;
- Procedure FreeList;
- Property Dataset : TDataset Read FDataset Write FDataset;
- Property OnResolve : TResolveBatchEvent Read FOnResolve Write FOnResolve;
- Property OwnsList : Boolean Read FOwnsList;
- property BatchID : Integer Read FBatchID;
- Property Status : TUpdateBatchStatus Read FStatus Write FStatus;
- Property List : TRecordUpdateDescriptorList Read FList;
- end;
- TRecordUpdateBatchClass = Class of TRecordUpdateBatch;
- { TDataProxy }
- TDataProxy = Class(TComponent)
- Protected
- Function GetDataRequestClass : TDataRequestClass; virtual;
- Function GetUpdateDescriptorClass : TRecordUpdateDescriptorClass; virtual;
- Function GetUpdateBatchClass : TRecordUpdateBatchClass; virtual;
- // Use this to call resolve event, and free the batch.
- Procedure ResolveBatch(aBatch : TRecordUpdateBatch);
- Public
- Function GetDataRequest(aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent) : TDataRequest; virtual;
- Function GetUpdateDescriptor(aDataset : TDataset; aBookmark : TBookMark; AData : JSValue; AStatus : TUpdateStatus) : TRecordUpdateDescriptor; virtual;
- function GetRecordUpdateBatch(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList: Boolean=True): TRecordUpdateBatch; virtual;
- // actual calls to do the work. Dataset wi
- Function DoGetData(aRequest : TDataRequest) : Boolean; virtual; abstract;
- // TDataProxy is responsible for calling OnResolve and if not, Freeing the batch.
- Function ProcessUpdateBatch(aBatch : TRecordUpdateBatch): Boolean; virtual; abstract;
- end;
- const
- {
- TFieldType = (
- ftUnknown, ftString, ftInteger, ftLargeInt, ftBoolean, ftFloat, ftDate,
- ftTime, ftDateTime, ftAutoInc, ftBlob, ftMemo, ftFixedChar,
- ftVariant
- );
- }
- Const
- Fieldtypenames : Array [TFieldType] of String =
- (
- {ftUnknown} 'Unknown',
- {ftString} 'String',
- {ftInteger} 'Integer',
- {ftLargeint} 'NativeInt',
- {ftBoolean} 'Boolean',
- {ftFloat} 'Float',
- {ftDate} 'Date',
- {ftTime} 'Time',
- {ftDateTime} 'DateTime',
- {ftAutoInc} 'AutoInc',
- {ftBlob} 'Blob',
- {ftMemo} 'Memo',
- {ftFixedChar} 'FixedChar',
- {ftVariant} 'Variant',
- {ftDataset} 'Dataset'
- );
- DefaultFieldClasses : Array [TFieldType] of TFieldClass =
- (
- { ftUnknown} Tfield,
- { ftString} TStringField,
- { ftInteger} TIntegerField,
- { ftLargeint} TLargeIntField,
- { ftBoolean} TBooleanField,
- { ftFloat} TFloatField,
- { ftDate} TDateField,
- { ftTime} TTimeField,
- { ftDateTime} TDateTimeField,
- { ftAutoInc} TAutoIncField,
- { ftBlob} TBlobField,
- { ftMemo} TMemoField,
- { ftFixedChar} TStringField,
- { ftVariant} TVariantField,
- { ftDataset} Nil
- );
- dsEditModes = [dsEdit, dsInsert, dsSetKey];
- dsWriteModes = [dsEdit, dsInsert, dsSetKey, dsCalcFields, dsFilter,
- dsNewValue, dsInternalCalc, dsRefreshFields];
- // Correct list of all field types that are BLOB types.
- // Please use this instead of checking TBlobType which will give
- // incorrect results
- ftBlobTypes = [ftBlob, ftMemo];
- { Auxiliary functions }
- Procedure DatabaseError (Const Msg : String); overload;
- Procedure DatabaseError (Const Msg : String; Comp : TComponent); overload;
- Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue); overload;
- Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue; Comp : TComponent); overload;
- Function ExtractFieldName(Const Fields: String; var Pos: Integer): String;
- // function SkipComments(var p: PChar; EscapeSlash, EscapeRepeat : Boolean) : boolean;
- // operator Enumerator(ADataSet: TDataSet): TDataSetEnumerator;
-
- implementation
- uses DBConst,TypInfo;
- { ---------------------------------------------------------------------
- Auxiliary functions
- ---------------------------------------------------------------------}
- Procedure DatabaseError (Const Msg : String);
- begin
- Raise EDataBaseError.Create(Msg);
- end;
- Procedure DatabaseError (Const Msg : String; Comp : TComponent);
- begin
- if assigned(Comp) and (Comp.Name <> '') then
- Raise EDatabaseError.CreateFmt('%s : %s',[Comp.Name,Msg])
- else
- DatabaseError(Msg);
- end;
- Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue);
- begin
- Raise EDatabaseError.CreateFmt(Fmt,Args);
- end;
- Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of JSValue;
- Comp : TComponent);
- begin
- if assigned(comp) then
- Raise EDatabaseError.CreateFmt(Format('%s : %s',[Comp.Name,Fmt]),Args)
- else
- DatabaseErrorFmt(Fmt, Args);
- end;
- function ExtractFieldName(const Fields: string; var Pos: Integer): string;
- var
- i: Integer;
- FieldsLength: Integer;
- begin
- i:=Pos;
- FieldsLength:=Length(Fields);
- while (i<=FieldsLength) and (Fields[i]<>';') do Inc(i);
- Result:=Trim(Copy(Fields,Pos,i-Pos));
- if (i<=FieldsLength) and (Fields[i]=';') then Inc(i);
- Pos:=i;
- end;
- { TRecordUpdateBatch }
- constructor TRecordUpdateBatch.Create(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList : Boolean);
- begin
- FBatchID:=aBatchID;
- FList:=AList;
- FOwnsList:=AOwnsList;
- FStatus:=ubsPending;
- end;
- destructor TRecordUpdateBatch.Destroy;
- begin
- if OwnsList then
- FreeList;
- inherited Destroy;
- end;
- procedure TRecordUpdateBatch.FreeList;
- begin
- FreeAndNil(FList);
- end;
- { TRecordUpdateDescriptorList }
- function TRecordUpdateDescriptorList.GetUpdate(AIndex : Integer): TRecordUpdateDescriptor;
- begin
- Result:=TRecordUpdateDescriptor(Items[AIndex]);
- end;
- { TRecordUpdateDescriptor }
- procedure TRecordUpdateDescriptor.SetStatus(aValue: TUpdateStatus);
- begin
- FStatus:=AValue;
- end;
- procedure TRecordUpdateDescriptor.Reset;
- begin
- FStatus:=FOriginalStatus;
- FResolveError:='';
- FServerData:=Null;
- end;
- constructor TRecordUpdateDescriptor.Create(aProxy: TDataProxy; aDataset: TDataset; aBookmark: TBookMark; AData: JSValue;
- AStatus: TUpdateStatus);
- begin
- FDataset:=aDataset;
- FBookmark:=aBookmark;
- FData:=AData;
- FStatus:=AStatus;
- FOriginalStatus:=AStatus;
- FProxy:=aProxy;
- end;
- procedure TRecordUpdateDescriptor.Resolve(aData: JSValue);
- begin
- FStatus:=usResolved;
- FServerData:=AData;
- end;
- procedure TRecordUpdateDescriptor.ResolveFailed(aError: String);
- begin
- SetStatus(usResolveFailed);
- FResolveError:=AError;
- end;
- { TDataRequest }
- procedure TDataRequest.DoAfterRequest;
- begin
- if Assigned(FAfterRequest) then
- FAfterRequest(Self);
- end;
- constructor TDataRequest.Create(aDataProxy : TDataProxy; aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent);
- begin
- FDataProxy:=aDataProxy;
- FLoadOptions:=aOptions;
- FEvent:=aAfterLoad;
- FAfterRequest:=aAfterRequest;
- end;
- { TDataProxy }
- function TDataProxy.GetDataRequestClass: TDataRequestClass;
- begin
- Result:=TDataRequest;
- end;
- function TDataProxy.GetUpdateDescriptorClass: TRecordUpdateDescriptorClass;
- begin
- Result:=TRecordUpdateDescriptor;
- end;
- function TDataProxy.GetUpdateBatchClass: TRecordUpdateBatchClass;
- begin
- Result:=TRecordUpdateBatch;
- end;
- procedure TDataProxy.ResolveBatch(aBatch: TRecordUpdateBatch);
- begin
- try
- If Assigned(ABatch.FOnResolve) then
- ABatch.FOnResolve(Self,ABatch);
- finally
- aBatch.Free;
- end;
- end;
- function TDataProxy.GetDataRequest(aOptions: TLoadOptions; aAfterRequest : TDataRequestEvent; aAfterLoad: TDatasetLoadEvent): TDataRequest;
- begin
- Result:=GetDataRequestClass.Create(Self,aOptions,aAfterRequest,aAfterLoad);
- end;
- function TDataProxy.GetUpdateDescriptor(aDataset : TDataset; aBookmark: TBookMark; AData: JSValue; AStatus: TUpdateStatus): TRecordUpdateDescriptor;
- begin
- Result:=GetUpdateDescriptorClass.Create(Self,aDataset, aBookmark,AData,AStatus);
- end;
- function TDataProxy.GetRecordUpdateBatch(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList : Boolean = True): TRecordUpdateBatch;
- begin
- Result:=GetUpdateBatchClass.Create(aBatchID,AList,AOwnsList);
- end;
- { EUpdateError }
- constructor EUpdateError.Create(NativeError, Context : String;
- ErrCode, PrevError : integer; E: Exception);
-
- begin
- Inherited CreateFmt(NativeError,[Context]);
- FContext := Context;
- FErrorCode := ErrCode;
- FPreviousError := PrevError;
- FOriginalException := E;
- end;
- Destructor EUpdateError.Destroy;
- begin
- FOriginalException.Free;
- Inherited;
- end;
- { TNamedItem }
- function TNamedItem.GetDisplayName: string;
- begin
- Result := FName;
- end;
- procedure TNamedItem.SetDisplayName(const Value: string);
- Var TmpInd : Integer;
- begin
- if FName=Value then exit;
- if (Value <> '') and (Collection is TFieldDefs ) then
- begin
- TmpInd := (TDefCollection(Collection).IndexOf(Value));
- if (TmpInd >= 0) and (TmpInd <> Index) then
- DatabaseErrorFmt(SDuplicateName, [Value, Collection.ClassName]);
- end;
- FName:=Value;
- inherited SetDisplayName(Value);
- end;
- { TDefCollection }
- procedure TDefCollection.SetItemName(Item: TCollectionItem);
- Var
- N : TNamedItem;
- TN : String;
- begin
- N:=Item as TNamedItem;
- if N.Name = '' then
- begin
- TN:=Copy(ClassName, 2, 5) + IntToStr(N.ID+1);
- if assigned(Dataset) then
- TN:=Dataset.Name+TN;
- N.Name:=TN;
- end
- else
- inherited SetItemName(Item);
- end;
- constructor TDefCollection.create(ADataset: TDataset; AOwner: TPersistent;
- AClass: TCollectionItemClass);
- begin
- inherited Create(AOwner,AClass);
- FDataset := ADataset;
- end;
- function TDefCollection.Find(const AName: string): TNamedItem;
- var i: integer;
- begin
- Result := Nil;
- for i := 0 to Count - 1 do
- if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
- begin
- Result := TNamedItem(Items[i]);
- Break;
- end;
- end;
- procedure TDefCollection.GetItemNames(List: TStrings);
- var i: LongInt;
- begin
- for i := 0 to Count - 1 do
- List.Add(TNamedItem(Items[i]).Name);
- end;
- function TDefCollection.IndexOf(const AName: string): Longint;
- var i: LongInt;
- begin
- Result := -1;
- for i := 0 to Count - 1 do
- if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
- begin
- Result := i;
- Break;
- end;
- end;
- { TIndexDef }
- procedure TIndexDef.SetDescFields(const AValue: string);
- begin
- if FDescFields=AValue then exit;
- if AValue <> '' then FOptions:=FOptions + [ixDescending];
- FDescFields:=AValue;
- end;
- procedure TIndexDef.Assign(Source: TPersistent);
- var idef : TIndexDef;
- begin
- idef := nil;
- if Source is TIndexDef then
- idef := Source as TIndexDef;
- if Assigned(idef) then
- begin
- FName := idef.Name;
- FFields := idef.Fields;
- FOptions := idef.Options;
- FCaseinsFields := idef.CaseInsFields;
- FDescFields := idef.DescFields;
- FSource := idef.Source;
- FExpression := idef.Expression;
- end
- else
- inherited Assign(Source);
- end;
- function TIndexDef.GetExpression: string;
- begin
- Result := FExpression;
- end;
- procedure TIndexDef.SetExpression(const AValue: string);
- begin
- FExpression := AValue;
- end;
- procedure TIndexDef.SetCaseInsFields(const AValue: string);
- begin
- if FCaseinsFields=AValue then exit;
- if AValue <> '' then FOptions:=FOptions + [ixCaseInsensitive];
- FCaseinsFields:=AValue;
- end;
- constructor TIndexDef.Create(Owner: TIndexDefs; const AName, TheFields: string;
- TheOptions: TIndexOptions);
- begin
- FName := aname;
- inherited create(Owner);
- FFields := TheFields;
- FOptions := TheOptions;
- end;
- { TIndexDefs }
- Function TIndexDefs.GetItem (Index : integer) : TIndexDef;
- begin
- Result:=(Inherited GetItem(Index)) as TIndexDef;
- end;
- Procedure TIndexDefs.SetItem(Index: Integer; Value: TIndexDef);
- begin
- Inherited SetItem(Index,Value);
- end;
- constructor TIndexDefs.Create(ADataSet: TDataSet);
- begin
- inherited create(ADataset, Owner, TIndexDef);
- end;
- Function TIndexDefs.AddIndexDef: TIndexDef;
- begin
- // Result := inherited add as TIndexDef;
- Result:=TIndexDefClass(Self.ItemClass).Create(Self,'','',[]);
- end;
- procedure TIndexDefs.Add(const Name, Fields: string; Options: TIndexOptions);
- begin
- TIndexDefClass(Self.ItemClass).Create(Self,Name,Fields,Options);
- end;
- function TIndexDefs.Find(const IndexName: string): TIndexDef;
- begin
- Result := (inherited Find(IndexName)) as TIndexDef;
- if (Result=Nil) Then
- DatabaseErrorFmt(SIndexNotFound, [IndexName], FDataSet);
- end;
- function TIndexDefs.FindIndexForFields(const Fields: string): TIndexDef;
- begin
- //!! To be implemented
- Result:=nil;
- end;
- function TIndexDefs.GetIndexForFields(const Fields: string;
- CaseInsensitive: Boolean): TIndexDef;
- var
- i, FieldsLen: integer;
- Last: TIndexDef;
- begin
- Last := nil;
- FieldsLen := Length(Fields);
- for i := 0 to Count - 1 do
- begin
- Result := Items[I];
- if (Result.Options * [ixDescending, ixExpression] = []) and
- (not CaseInsensitive or (ixCaseInsensitive in Result.Options)) and
- AnsiSameText(Fields, Result.Fields) then
- begin
- Exit;
- end else
- if AnsiSameText(Fields, Copy(Result.Fields, 1, FieldsLen)) and
- ((Length(Result.Fields) = FieldsLen) or
- (Result.Fields[FieldsLen + 1] = ';')) then
- begin
- if (Last = nil) or
- ((Last <> nil) And (Length(Last.Fields) > Length(Result.Fields))) then
- Last := Result;
- end;
- end;
- Result := Last;
- end;
- procedure TIndexDefs.Update;
- begin
- if (not updated) and assigned(Dataset) then
- begin
- Dataset.UpdateIndexDefs;
- updated := True;
- end;
- end;
- { TCheckConstraint }
- procedure TCheckConstraint.Assign(Source: TPersistent);
- begin
- //!! To be implemented
- end;
- { TCheckConstraints }
- Function TCheckConstraints.GetItem(Index : Longint) : TCheckConstraint;
- begin
- //!! To be implemented
- Result := nil;
- end;
- Procedure TCheckConstraints.SetItem(index : Longint; Value : TCheckConstraint);
- begin
- //!! To be implemented
- end;
- function TCheckConstraints.GetOwner: TPersistent;
- begin
- //!! To be implemented
- Result := nil;
- end;
- constructor TCheckConstraints.Create(AOwner: TPersistent);
- begin
- //!! To be implemented
- inherited Create(TCheckConstraint);
- end;
- function TCheckConstraints.Add: TCheckConstraint;
- begin
- //!! To be implemented
- Result := nil;
- end;
- { TLookupList }
- constructor TLookupList.Create;
- begin
- FList := TFPList.Create;
- end;
- destructor TLookupList.Destroy;
- begin
- Clear;
- FList.Destroy;
- inherited Destroy;
- end;
- procedure TLookupList.Add(const AKey, AValue: JSValue);
- var LookupRec: TJSObject;
- begin
- LookupRec:=New(['Key',AKey,'Value',AValue]);
- FList.Add(LookupRec);
- end;
- procedure TLookupList.Clear;
- begin
- FList.Clear;
- end;
- function TLookupList.FirstKeyByValue(const AValue: JSValue): JSValue;
- var
- i: Integer;
- begin
- for i := 0 to FList.Count - 1 do
- with TJSObject(FList[i]) do
- if Properties['Value'] = AValue then
- begin
- Result := Properties['Key'];
- exit;
- end;
- Result := Null;
- end;
- function TLookupList.ValueOfKey(const AKey: JSValue): JSValue;
- Function VarArraySameValues(VarArray1,VarArray2 : TJSValueDynArray) : Boolean;
- // This only works for one-dimensional vararrays with a lower bound of 0
- // and equal higher bounds wich only contains JSValues.
- // The vararrays returned by GetFieldValues do apply.
- var i : integer;
- begin
- Result := True;
- if (Length(VarArray1)<>Length(VarArray2)) then
- exit;
- for i := 0 to Length(VarArray1) do
- begin
- if VarArray1[i]<>VarArray2[i] then
- begin
- Result := false;
- Exit;
- end;
- end;
- end;
- var I: Integer;
- begin
- Result := Null;
- if IsNull(AKey) then Exit;
- i := FList.Count - 1;
- if IsArray(AKey) then
- while (i >= 0) And not VarArraySameValues(TJSValueDynArray(TJSOBject(FList.Items[I]).Properties['Key']),TJSValueDynArray(AKey)) do Dec(i)
- else
- while (i >= 0) And (TJSObject(FList[I]).Properties['Key'] <> AKey) do Dec(i);
- if i >= 0 then Result := TJSObject(FList[I]).Properties['Value'];
- end;
- procedure TLookupList.ValuesToStrings(AStrings: TStrings);
- var
- i: Integer;
- p: TJSObject;
- begin
- AStrings.Clear;
- for i := 0 to FList.Count - 1 do
- begin
- p := TJSObject(FList[i]);
- AStrings.AddObject(String(p.properties['Value']), TObject(p));
- end;
- end;
- { ---------------------------------------------------------------------
- TDataSet
- ---------------------------------------------------------------------}
- Const
- DefaultBufferCount = 10;
- constructor TDataSet.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- FFieldDefs:=FieldDefsClass.Create(Self);
- FFieldList:=FieldsClass.Create(Self);
- FDataSources:=TFPList.Create;
- FConstraints:=TCheckConstraints.Create(Self);
- SetLength(FBuffers,1);
- FActiveRecord := 0;
- FEOF := True;
- FBOF := True;
- FIsUniDirectional := False;
- FAutoCalcFields := True;
- FDataRequestID:=0;
- end;
- destructor TDataSet.Destroy;
- var
- i: Integer;
- begin
- Active:=False;
- FFieldDefs.Free;
- FFieldList.Free;
- With FDataSources do
- begin
- While Count>0 do
- TDataSource(Items[Count - 1]).DataSet:=Nil;
- Destroy;
- end;
- for i := 0 to FBufferCount do
- FreeRecordBuffer(FBuffers[i]);
- FConstraints.Free;
- SetLength(FBuffers,1);
- Inherited Destroy;
- end;
- // This procedure must be called when the first record is made/read
- procedure TDataSet.ActivateBuffers;
- begin
- FBOF:=False;
- FEOF:=False;
- FActiveRecord:=0;
- end;
- procedure TDataSet.BindFields(Binding: Boolean);
- var i, FieldIndex: Integer;
- FieldDef: TFieldDef;
- Field: TField;
- begin
- { FieldNo is set to -1 for calculated/lookup fields, to 0 for unbound field
- and for bound fields it is set to FieldDef.FieldNo }
- FCalcFieldsCount := 0;
- FBlobFieldCount := 0;
- for i := 0 to Fields.Count - 1 do
- begin
- Field := Fields[i];
- Field.FFieldDef := Nil;
- if not Binding then
- Field.FFieldNo := 0
- else if Field.FieldKind in [fkCalculated, fkLookup] then
- begin
- Field.FFieldNo := -1;
- Inc(FCalcFieldsCount);
- end
- else
- begin
- FieldIndex := FieldDefs.IndexOf(Field.FieldName);
- if FieldIndex = -1 then
- DatabaseErrorFmt(SFieldNotFound,[Field.FieldName],Self)
- else
- begin
- FieldDef := FieldDefs[FieldIndex];
- Field.FFieldDef := FieldDef;
- Field.FFieldNo := FieldDef.FieldNo;
- if FieldDef.InternalCalcField then
- FInternalCalcFields := True;
- if Field.IsBlob then
- begin
- Field.FSize := FieldDef.Size;
- Inc(FBlobFieldCount);
- end;
- // synchronize CodePage between TFieldDef and TField
- // character data in record buffer and field buffer should have same CodePage
- end;
- end;
- Field.Bind(Binding);
- end;
- end;
- function TDataSet.BookmarkAvailable: Boolean;
- Const BookmarkStates = [dsBrowse,dsEdit,dsInsert];
- begin
- Result:=(Not IsEmpty) and not FIsUniDirectional and (State in BookmarkStates)
- and (getBookMarkFlag(ActiveBuffer)=bfCurrent);
- end;
- procedure TDataSet.CalculateFields(var Buffer: TDataRecord);
- var
- i: Integer;
- OldState: TDatasetState;
- begin
- FCalcBuffer := Buffer;
- if FState <> dsInternalCalc then
- begin
- OldState := FState;
- FState := dsCalcFields;
- try
- ClearCalcFields(FCalcBuffer);
- if not IsUniDirectional then
- for i := 0 to FFieldList.Count - 1 do
- if FFieldList[i].FieldKind = fkLookup then
- FFieldList[i].CalcLookupValue;
- finally
- DoOnCalcFields;
- FState := OldState;
- end;
- end;
- end;
- procedure TDataSet.CheckActive;
- begin
- If Not Active then
- DataBaseError(SInactiveDataset,Self);
- end;
- procedure TDataSet.CheckInactive;
- begin
- If Active then
- DataBaseError(SActiveDataset,Self);
- end;
- procedure TDataSet.ClearBuffers;
- begin
- FRecordCount:=0;
- FActiveRecord:=0;
- FCurrentRecord:=-1;
- FBOF:=True;
- FEOF:=True;
- end;
- procedure TDataSet.ClearCalcFields(var Buffer: TDataRecord);
- begin
- // Empty
- end;
- procedure TDataSet.CloseBlob(Field: TField);
- begin
- //!! To be implemented
- end;
- procedure TDataSet.CloseCursor;
- begin
- ClearBuffers;
- SetBufListSize(0);
- Fields.ClearFieldDefs;
- InternalClose;
- FInternalOpenComplete := False;
- end;
- procedure TDataSet.CreateFields;
- Var I : longint;
- begin
- {$ifdef DSDebug}
- Writeln ('Creating fields');
- Writeln ('Count : ',fielddefs.Count);
- For I:=0 to FieldDefs.Count-1 do
- Writeln('Def ',I,' : ',Fielddefs.items[i].Name,'(',Fielddefs.items[i].FieldNo,')');
- {$endif}
- For I:=0 to FieldDefs.Count-1 do
- With FieldDefs.Items[I] do
- If DataType<>ftUnknown then
- begin
- {$ifdef DSDebug}
- Writeln('About to create field ',FieldDefs.Items[i].Name);
- {$endif}
- CreateField(self);
- end;
- end;
- procedure TDataSet.DataEvent(Event: TDataEvent; Info: JSValue);
- procedure HandleFieldChange(aField: TField);
- begin
- if aField.FieldKind in [fkData, fkInternalCalc] then
- SetModified(True);
-
- if State <> dsSetKey then begin
- if aField.FieldKind = fkData then begin
- if FInternalCalcFields then
- RefreshInternalCalcFields(FBuffers[FActiveRecord])
- else if FAutoCalcFields and (FCalcFieldsCount <> 0) then
- CalculateFields(FBuffers[FActiveRecord]);
- end;
- aField.Change;
- end;
- end;
-
- procedure HandleScrollOrChange;
- begin
- if State <> dsInsert then
- UpdateCursorPos;
- end;
- var
- i: Integer;
- begin
- case Event of
- deFieldChange : HandleFieldChange(TField(Info));
- deDataSetChange,
- deDataSetScroll : HandleScrollOrChange;
- deLayoutChange : FEnableControlsEvent:=deLayoutChange;
- end;
- if not ControlsDisabled and (FState <> dsBlockRead) then begin
- for i := 0 to FDataSources.Count - 1 do
- TDataSource(FDataSources[i]).ProcessEvent(Event, Info);
- end;
- end;
- procedure TDataSet.DestroyFields;
- begin
- FFieldList.Clear;
- end;
- procedure TDataSet.DoAfterCancel;
- begin
- If assigned(FAfterCancel) then
- FAfterCancel(Self);
- end;
- procedure TDataSet.DoAfterClose;
- begin
- If assigned(FAfterClose) and not (csDestroying in ComponentState) then
- FAfterClose(Self);
- end;
- procedure TDataSet.DoAfterDelete;
- begin
- If assigned(FAfterDelete) then
- FAfterDelete(Self);
- end;
- procedure TDataSet.DoAfterEdit;
- begin
- If assigned(FAfterEdit) then
- FAfterEdit(Self);
- end;
- procedure TDataSet.DoAfterInsert;
- begin
- If assigned(FAfterInsert) then
- FAfterInsert(Self);
- end;
- procedure TDataSet.DoAfterOpen;
- begin
- If assigned(FAfterOpen) then
- FAfterOpen(Self);
- end;
- procedure TDataSet.DoAfterPost;
- begin
- If assigned(FAfterPost) then
- FAfterPost(Self);
- end;
- procedure TDataSet.DoAfterScroll;
- begin
- If assigned(FAfterScroll) then
- FAfterScroll(Self);
- end;
- procedure TDataSet.DoAfterRefresh;
- begin
- If assigned(FAfterRefresh) then
- FAfterRefresh(Self);
- end;
- procedure TDataSet.DoBeforeCancel;
- begin
- If assigned(FBeforeCancel) then
- FBeforeCancel(Self);
- end;
- procedure TDataSet.DoBeforeClose;
- begin
- If assigned(FBeforeClose) and not (csDestroying in ComponentState) then
- FBeforeClose(Self);
- end;
- procedure TDataSet.DoBeforeDelete;
- begin
- If assigned(FBeforeDelete) then
- FBeforeDelete(Self);
- end;
- procedure TDataSet.DoBeforeEdit;
- begin
- If assigned(FBeforeEdit) then
- FBeforeEdit(Self);
- end;
- procedure TDataSet.DoBeforeInsert;
- begin
- If assigned(FBeforeInsert) then
- FBeforeInsert(Self);
- end;
- procedure TDataSet.DoBeforeOpen;
- begin
- If assigned(FBeforeOpen) then
- FBeforeOpen(Self);
- end;
- procedure TDataSet.DoBeforePost;
- begin
- If assigned(FBeforePost) then
- FBeforePost(Self);
- end;
- procedure TDataSet.DoBeforeScroll;
- begin
- If assigned(FBeforeScroll) then
- FBeforeScroll(Self);
- end;
- procedure TDataSet.DoBeforeRefresh;
- begin
- If assigned(FBeforeRefresh) then
- FBeforeRefresh(Self);
- end;
- procedure TDataSet.DoInternalOpen;
- begin
- InternalOpen;
- FInternalOpenComplete := True;
- {$ifdef dsdebug}
- Writeln ('Calling internal open');
- {$endif}
- {$ifdef dsdebug}
- Writeln ('Calling RecalcBufListSize');
- {$endif}
- FRecordCount := 0;
- RecalcBufListSize;
- FBOF := True;
- FEOF := (FRecordCount = 0);
- if Assigned(DataProxy) then
- InitChangeList;
- end;
- procedure TDataSet.DoOnCalcFields;
- begin
- If Assigned(FOnCalcfields) then
- FOnCalcFields(Self);
- end;
- procedure TDataSet.DoOnNewRecord;
- begin
- If assigned(FOnNewRecord) then
- FOnNewRecord(Self);
- end;
- procedure TDataSet.DoBeforeLoad;
- begin
- If Assigned(FBeforeLoad) then
- FBeforeLoad(Self);
- end;
- procedure TDataSet.DoAfterLoad;
- begin
- if Assigned(FAfterLoad) then
- FAfterLoad(Self);
- end;
- procedure TDataSet.DoBeforeApplyUpdates;
- begin
- If Assigned(FBeforeApplyUpdates) then
- FBeforeApplyUpdates(Self);
- end;
- procedure TDataSet.DoAfterApplyUpdates(Const ResolveInfo : TResolveResults);
- begin
- If Assigned(FAfterApplyUpdates) then
- FAfterApplyUpdates(Self,ResolveInfo);
- end;
- function TDataSet.FieldByNumber(FieldNo: Longint): TField;
- begin
- Result:=FFieldList.FieldByNumber(FieldNo);
- end;
- function TDataSet.FindRecord(Restart, GoForward: Boolean): Boolean;
- begin
- //!! To be implemented
- Result:=false;
- end;
- function TDataSet.GetBookmarkStr: TBookmarkStr;
- Var
- B : TBookMark;
- begin
- Result:='';
- If BookMarkAvailable then
- begin
- GetBookMarkData(ActiveBuffer,B);
- Result:=TJSJSON.stringify(B);
- end
- end;
- function TDataSet.GetBuffer(Index: longint): TDataRecord;
- begin
- Result:=FBuffers[Index];
- end;
- function TDataSet.DoGetDataProxy: TDataProxy;
- begin
- Result:=nil;
- end;
- procedure TDataSet.InitChangeList;
- begin
- DoneChangeList;
- FChangeList:=TFPList.Create;
- end;
- procedure TDataSet.ClearChangeList;
- Var
- I : integer;
- begin
- If not Assigned(FChangeList) then
- exit;
- For I:=0 to FChangeList.Count-1 do
- begin
- TObject(FChangeList[i]).Destroy;
- FChangeList[i]:=Nil;
- end;
- end;
- Function TDataSet.IndexInChangeList(aBookmark : TBookmark) : Integer;
- begin
- Result:=-1;
- if Not assigned(FChangeList) then
- exit;
- Result:=FChangeList.Count-1;
- While (Result>=0) and (CompareBookmarks(aBookMark,TRecordUpdateDescriptor(FChangeList[Result]).Bookmark)<>0) do
- Dec(Result);
- end;
- Function TDataSet.AddToChangeList(aChange: TUpdateStatus) : TRecordUpdateDescriptor;
- Var
- B : TBookmark;
- I : Integer;
- begin
- Result:=Nil;
- if Not Assigned(FChangeList) then
- Exit;
- B:=GetBookmark;
- I:=IndexInChangeList(B);
- if (I=-1) then
- begin
- if Assigned(DataProxy) then
- Result:=DataProxy.GetUpdateDescriptor(Self,B,ActiveBuffer.data,aChange)
- else
- Result:=TRecordUpdateDescriptor.Create(Nil,Self,B,ActiveBuffer.data,aChange);
- FChangeList.Add(Result);
- end
- else
- begin
- Result:=TRecordUpdateDescriptor(FChangeList[i]);
- Case aChange of
- usDeleted : Result.FStatus:=usDeleted;
- usInserted : DatabaseError(SErrInsertingSameRecordtwice,Self);
- usModified : Result.FData:=ActiveBuffer.Data;
- end
- end;
- end;
- procedure TDataSet.RemoveFromChangeList(R: TRecordUpdateDescriptor);
- begin
- if Not (Assigned(R) and Assigned(FChangeList)) then
- Exit;
- end;
- Function TDataSet.GetRecordUpdates(AList: TRecordUpdateDescriptorList) : Integer;
- Var
- I,MinIndex : integer;
- begin
- MinIndex:=0; // Check batch list for minimal index ?
- For I:=MinIndex to FChangeList.Count-1 do
- Alist.Add(FChangeList[i]);
- Result:=FChangeList.Count;
- end;
- Function TDataSet.ResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor) : Boolean;
- // This must return true if the record may be removed from the list of 'modified' records.
- // If it returns false, the record is kept in the list of modified records.
- begin
- try
- Result:=DoResolveRecordUpdate(anUpdate);
- If not Result then
- anUpdate.FStatus:=usResolveFailed;
- except
- On E : Exception do
- begin
- anUpdate.ResolveFailed(E.Classname+': '+E.Message);
- Result:=False;
- end;
- end;
- DoOnRecordResolved(anUpdate);
- end;
- Function TDataSet.RecordUpdateDescriptorToResolveInfo(anUpdate: TRecordUpdateDescriptor) : TResolveInfo;
- begin
- Result.BookMark:=anUpdate.Bookmark;
- Result.Data:=anUpdate.Data;
- Result.Status:=anUpdate.Status;
- Result.Error:=anUpdate.ResolveError;
- end;
- procedure TDataSet.DoOnRecordResolved(anUpdate: TRecordUpdateDescriptor) ;
- Var
- Info : TResolveInfo;
- begin
- if Not Assigned(OnRecordResolved) then exit;
- Info:=RecordUpdateDescriptorToResolveInfo(anUpdate);
- OnRecordResolved(Self,Info);
- end;
- procedure TDataSet.ResolveUpdateBatch(Sender: TObject; aBatch : TRecordUpdateBatch);
- Var
- BI,RI,Idx: integer;
- RUD : TRecordUpdateDescriptor;
- doRemove : Boolean;
- Results : TResolveResults;
- begin
- if Assigned(FBatchList) and (aBatch.Dataset=Self) then
- BI:=FBatchList.IndexOf(aBatch)
- else
- BI:=-1;
- if (BI=-1) then
- Exit;
- FBatchList.Delete(Bi);
- SetLength(Results.Records, aBatch.List.Count);
- For RI:=0 to aBatch.List.Count-1 do
- begin
- RUD:=aBatch.List[RI];
- Results.Records[RI]:=RecordUpdateDescriptorToResolveInfo(RUD);
- aBatch.List.Items[RI]:=Nil;
- Idx:=IndexInChangeList(RUD.Bookmark);
- if (Idx<>-1) then
- begin
- doRemove:=False;
- if (RUD.Status=usResolved) then
- DoRemove:=ResolveRecordUpdate(RUD)
- else
- // What if not resolvable.. ?
- DoRemove:=(RUD.Status in [usUnmodified]);
- If DoRemove then
- begin
- RUD.Free;
- FChangeList.Delete(Idx);
- end
- else
- RUD.Reset; // So we try it again in next applyupdates.
- end;
- end;
- if (FBatchList.Count=0) then
- FreeAndNil(FBatchList);
- DoAfterApplyUpdates(Results);
- end;
- procedure TDataSet.DoApplyUpdates;
- Var
- B : TRecordUpdateBatch;
- l : TRecordUpdateDescriptorList;
- I : integer;
- begin
- if Not Assigned(DataProxy) then
- DatabaseError(SErrDoApplyUpdatesNeedsProxy,Self);
- if Not (Assigned(FChangeList) and (FChangeList.Count>0)) then
- Exit;
- L:=TRecordUpdateDescriptorList.Create;
- try
- I:=GetRecordUpdates(L);
- except
- L.Free;
- Raise;
- end;
- Inc(FUpdateBatchID);
- B:=DataProxy.GetRecordUpdateBatch(FUpdateBatchID,L,True);
- B.FDataset:=Self;
- B.FLastChangeIndex:=I;
- B.OnResolve:=@ResolveUpdateBatch;
- If not Assigned(FBatchlist) then
- FBatchlist:=TFPList.Create;
- FBatchList.Add(B);
- DataProxy.ProcessUpdateBatch(B);
- end;
- procedure TDataSet.DoneChangeList;
- begin
- ClearChangeList;
- FreeAndNil(FChangeList);
- end;
- function TDataSet.GetDataProxy: TDataProxy;
- begin
- If (FDataProxy=Nil) then
- DataProxy:=DoGetDataProxy;
- Result:=FDataProxy;
- end;
- function TDataSet.DataPacketReceived(ARequest: TDataRequest): Boolean;
- begin
- Result:=False;
- end;
- procedure TDataSet.HandleRequestresponse(ARequest: TDataRequest);
- Var
- DataAdded : Boolean;
- begin
- if Not Assigned(ARequest) then
- exit;
- Case ARequest.Success of
- rrFail:
- begin
- if Assigned(FOnLoadFail) then
- FOnLoadFail(Self,aRequest.RequestID,aRequest.ErrorMsg);
- end;
- rrEOF,
- rrOK :
- begin
- DataAdded:=False;
- // Notify caller
- if Assigned(ARequest.Event) then
- ARequest.Event(Self,aRequest.Data);
- // allow descendent to integrate data.
- // Must be done before user is notified or dataset is opened...
- if (ARequest.Success<>rrEOF) then
- DataAdded:=DataPacketReceived(aRequest);
- // Open if needed.
- if Not (Active or (loNoOpen in aRequest.LoadOptions)) then
- begin
- // Notify user
- if not (loNoEvents in aRequest.LoadOptions) then
- DoAfterLoad;
- Open
- end
- else
- begin
- if (loAtEOF in aRequest.LoadOptions) and DataAdded then
- FEOF:=False;
- if not (loNoEvents in aRequest.LoadOptions) then
- DoAfterLoad;
- end;
- end;
- end;
- aRequest.Destroy;
- end;
- function TDataSet.DoResolveRecordUpdate(anUpdate: TRecordUpdateDescriptor): Boolean;
- begin
- Result:=True;
- end;
- procedure TDataSet.GetCalcFields(var Buffer: TDataRecord);
- begin
- if (FCalcFieldsCount > 0) or FInternalCalcFields then
- CalculateFields(Buffer);
- end;
- function TDataSet.GetCanModify: Boolean;
- begin
- Result:= not FIsUnidirectional;
- end;
- procedure TDataSet.GetChildren(Proc: TGetChildProc; Root: TComponent);
- var
- I: Integer;
- Field: TField;
- begin
- for I := 0 to Fields.Count - 1 do begin
- Field := Fields[I];
- if (Field.Owner = Root) then
- Proc(Field);
- end;
- end;
- function TDataSet.GetDataSource: TDataSource;
- begin
- Result:=nil;
- end;
- function TDataSet.GetRecordSize: Word;
- begin
- Result := 0;
- end;
- procedure TDataSet.InternalAddRecord(Buffer: Pointer; AAppend: Boolean);
- begin
- // empty stub
- end;
- procedure TDataSet.InternalDelete;
- begin
- // empty stub
- end;
- procedure TDataSet.InternalFirst;
- begin
- // empty stub
- end;
- procedure TDataSet.InternalGotoBookmark(ABookmark: TBookMark);
- begin
- // empty stub
- end;
- function TDataset.GetFieldData(Field: TField; Buffer: TDatarecord): JSValue;
- begin
- Result:=TJSObject(buffer.data).Properties[Field.FieldName];
- end;
- procedure TDataSet.SetFieldData(Field: TField; var Buffer: TDataRecord; AValue : JSValue);
- begin
- TJSObject(buffer.data).Properties[Field.FieldName]:=AValue;
- end;
- function TDataSet.GetFieldClass(FieldType: TFieldType): TFieldClass;
- begin
- Result := DefaultFieldClasses[FieldType];
- end;
- function TDataSet.GetIsIndexField(Field: TField): Boolean;
- begin
- Result:=False;
- end;
- function TDataSet.GetIndexDefs(IndexDefs: TIndexDefs; IndexTypes: TIndexOptions
- ): TIndexDefs;
-
- var i,f : integer;
- IndexFields : TStrings;
-
- begin
- IndexDefs.Update;
- Result := TIndexDefs.Create(Self);
- Result.Assign(IndexDefs);
- i := 0;
- IndexFields := TStringList.Create;
- while i < result.Count do
- begin
- if (not ((IndexTypes = []) and (result[i].Options = []))) and
- ((IndexTypes * result[i].Options) = []) then
- begin
- result.Delete(i);
- dec(i);
- end
- else
- begin
- // ExtractStrings([';'],[' '],result[i].Fields,Indexfields);
- for f := 0 to IndexFields.Count-1 do
- if FindField(Indexfields[f]) = nil then
- begin
- result.Delete(i);
- dec(i);
- break;
- end;
- end;
- inc(i);
- end;
- IndexFields.Free;
- end;
- function TDataSet.GetNextRecord: Boolean;
- Var
- T : TDataRecord;
- begin
- {$ifdef dsdebug}
- Writeln ('Getting next record. Internal RecordCount : ',FRecordCount);
- Writeln ('Getting next record. Internal buffercount : ',FBufferCount);
- {$endif}
- If FRecordCount>0 Then
- SetCurrentRecord(FRecordCount-1);
- Result:=GetRecord(FBuffers[FBufferCount],gmNext,True)=grOK;
- if Result then
- begin
- If FRecordCount=0 then ActivateBuffers;
- if FRecordCount=FBufferCount then
- ShiftBuffersBackward
- else
- begin
- Inc(FRecordCount);
- FCurrentRecord:=FRecordCount - 1;
- T:=FBuffers[FCurrentRecord];
- FBuffers[FCurrentRecord]:=FBuffers[FBufferCount];
- FBuffers[FBufferCount]:=T;
- end;
- end
- else
- CursorPosChanged;
- {$ifdef dsdebug}
- Writeln ('Result getting next record : ',Result);
- {$endif}
- end;
- function TDataSet.GetNextRecords: Longint;
- begin
- Result:=0;
- {$ifdef dsdebug}
- Writeln ('Getting next record(s), need :',FBufferCount);
- {$endif}
- While (FRecordCount<FBufferCount) and GetNextRecord do
- Inc(Result);
- {$ifdef dsdebug}
- Writeln ('Result Getting next record(S), GOT :',RESULT);
- {$endif}
- end;
- function TDataSet.GetPriorRecord: Boolean;
- begin
- {$ifdef dsdebug}
- Writeln ('GetPriorRecord: Getting previous record');
- {$endif}
- CheckBiDirectional;
- If FRecordCount>0 Then SetCurrentRecord(0);
- Result:=GetRecord(FBuffers[FBufferCount],gmPrior,True)=grOK;
- if Result then
- begin
- If FRecordCount=0 then ActivateBuffers;
- ShiftBuffersForward;
- if FRecordCount<FBufferCount then
- Inc(FRecordCount);
- end
- else
- CursorPosChanged;
- {$ifdef dsdebug}
- Writeln ('Result getting prior record : ',Result);
- {$endif}
- end;
- function TDataSet.GetPriorRecords: Longint;
- begin
- Result:=0;
- {$ifdef dsdebug}
- Writeln ('Getting previous record(s), need :',FBufferCount);
- {$endif}
- While (FRecordCount<FBufferCount) and GetPriorRecord do
- Inc(Result);
- end;
- function TDataSet.GetRecNo: Longint;
- begin
- Result := -1;
- end;
- function TDataSet.GetRecordCount: Longint;
- begin
- Result := -1;
- end;
- procedure TDataSet.InitFieldDefs;
- begin
- if IsCursorOpen then
- InternalInitFieldDefs
- else
- begin
- try
- OpenCursor(True);
- finally
- CloseCursor;
- end;
- end;
- end;
- procedure TDataSet.SetBlockReadSize(AValue: Integer);
- begin
- // the state is changed even when setting the same BlockReadSize (follows Delphi behavior)
- // e.g., state is dsBrowse and BlockReadSize is 1. Setting BlockReadSize to 1 will change state to dsBlockRead
- FBlockReadSize := AValue;
- if AValue > 0 then
- begin
- CheckActive;
- SetState(dsBlockRead);
- end
- else
- begin
- //update state only when in dsBlockRead
- if FState = dsBlockRead then
- SetState(dsBrowse);
- end;
- end;
- procedure TDataSet.SetFieldDefs(AFieldDefs: TFieldDefs);
- begin
- Fields.ClearFieldDefs;
- FFieldDefs.Assign(AFieldDefs);
- end;
- procedure TDataSet.DoInsertAppendRecord(const Values: array of JSValue; DoAppend : boolean);
- var i : integer;
- ValuesSize : integer;
- begin
- ValuesSize:=Length(Values);
- if ValuesSize>FieldCount then DatabaseError(STooManyFields,self);
- if DoAppend then
- Append
- else
- Insert;
- for i := 0 to ValuesSize-1 do
- Fields[i].AssignValue(Values[i]);
- Post;
- end;
- procedure TDataSet.InitFieldDefsFromFields;
- var i : integer;
- begin
- if FieldDefs.Count = 0 then
- begin
- FieldDefs.BeginUpdate;
- try
- for i := 0 to Fields.Count-1 do with Fields[i] do
- if not (FieldKind in [fkCalculated,fkLookup]) then // Do not add fielddefs for calculated/lookup fields.
- begin
- FFieldDef:=FieldDefs.FieldDefClass.Create(FieldDefs,FieldName,DataType,Size,Required,FieldDefs.Count+1);
- with FFieldDef do
- begin
- if Required then Attributes := Attributes + [faRequired];
- if ReadOnly then Attributes := Attributes + [faReadOnly];
- end;
- end;
- finally
- FieldDefs.EndUpdate;
- end;
- end;
- end;
- procedure TDataSet.InitRecord(var Buffer: TDataRecord);
- begin
- InternalInitRecord(Buffer);
- ClearCalcFields(Buffer);
- end;
- procedure TDataSet.InternalCancel;
- begin
- //!! To be implemented
- end;
- procedure TDataSet.InternalEdit;
- begin
- //!! To be implemented
- end;
- procedure TDataSet.InternalRefresh;
- begin
- //!! To be implemented
- end;
- procedure TDataSet.OpenCursor(InfoQuery: Boolean);
- begin
- if InfoQuery then
- InternalInitFieldDefs
- else if State <> dsOpening then
- DoInternalOpen;
- end;
- procedure TDataSet.OpenCursorcomplete;
- begin
- try
- if FState = dsOpening then DoInternalOpen
- finally
- if FInternalOpenComplete then
- begin
- SetState(dsBrowse);
- DoAfterOpen;
- if not IsEmpty then
- DoAfterScroll;
- end
- else
- begin
- SetState(dsInactive);
- CloseCursor;
- end;
- end;
- end;
- procedure TDataSet.RefreshInternalCalcFields(Var Buffer: TDataRecord);
- begin
- //!! To be implemented
- end;
- function TDataSet.SetTempState(const Value: TDataSetState): TDataSetState;
- begin
- result := FState;
- FState := value;
- inc(FDisableControlsCount);
- end;
- procedure TDataSet.RestoreState(const Value: TDataSetState);
- begin
- FState := value;
- dec(FDisableControlsCount);
- end;
- function TDataSet.GetActive: boolean;
- begin
- result := (FState <> dsInactive) and (FState <> dsOpening);
- end;
- procedure TDataSet.InternalHandleException(E :Exception);
- begin
- ShowException(E,Nil);
- end;
- procedure TDataSet.InternalInitRecord(var Buffer: TDataRecord);
- begin
- // empty stub
- end;
- procedure TDataSet.InternalLast;
- begin
- // empty stub
- end;
- procedure TDataSet.InternalPost;
- Procedure CheckRequiredFields;
- Var I : longint;
- begin
- For I:=0 to FFieldList.Count-1 do
- With FFieldList[i] do
- // Required fields that are NOT autoinc !! Autoinc cannot be set !!
- if Required and not ReadOnly and
- (FieldKind=fkData) and Not (DataType=ftAutoInc) and IsNull then
- DatabaseErrorFmt(SNeedField,[DisplayName],Self);
- end;
- begin
- CheckRequiredFields;
- end;
- procedure TDataSet.InternalSetToRecord(Buffer: TDataRecord);
- begin
- // empty stub
- end;
- procedure TDataSet.SetBookmarkFlag(Var Buffer: TDataRecord; Value: TBookmarkFlag);
- begin
- // empty stub
- end;
- procedure TDataSet.SetBookmarkData(Var Buffer: TDataRecord; Data: TBookmark);
- begin
- // empty stub
- end;
- procedure TDataSet.SetUniDirectional(const Value: Boolean);
- begin
- FIsUniDirectional := Value;
- end;
- procedure TDataSet.Notification(AComponent: TComponent; Operation: TOperation);
- begin
- inherited Notification(AComponent, Operation);
- if (Operation=opRemove) and (AComponent=FDataProxy) then
- FDataProxy:=Nil;
- end;
- class function TDataSet.FieldDefsClass: TFieldDefsClass;
- begin
- Result:=TFieldDefs;
- end;
- class function TDataSet.FieldsClass: TFieldsClass;
- begin
- Result:=TFields;
- end;
- procedure TDataSet.SetActive(Value: Boolean);
- begin
- if value and (Fstate = dsInactive) then
- begin
- if csLoading in ComponentState then
- begin
- FOpenAfterRead := true;
- exit;
- end
- else
- begin
- DoBeforeOpen;
- FEnableControlsEvent:=deLayoutChange;
- FInternalCalcFields:=False;
- try
- FDefaultFields:=FieldCount=0;
- OpenCursor(False);
- finally
- if FState <> dsOpening then OpenCursorComplete;
- end;
- end;
- FModified:=False;
- end
- else if not value and (Fstate <> dsinactive) then
- begin
- DoBeforeClose;
- SetState(dsInactive);
- FDataRequestID:=0;
- DoneChangeList;
- CloseCursor;
- DoAfterClose;
- FModified:=False;
- end
- end;
- procedure TDataSet.Loaded;
- begin
- inherited;
- try
- if FOpenAfterRead then SetActive(true);
- except
- on E : Exception do
- if csDesigning in Componentstate then
- InternalHandleException(E);
- else
- raise;
- end;
- end;
- procedure TDataSet.RecalcBufListSize;
- var
- i, j, ABufferCount: Integer;
- DataLink: TDataLink;
- begin
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size - check cursor');
- {$endif}
- If Not IsCursorOpen Then
- Exit;
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size');
- {$endif}
- if IsUniDirectional then
- ABufferCount := 1
- else
- ABufferCount := DefaultBufferCount;
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size, start count: ',ABufferCount);
- {$endif}
- for i := 0 to FDataSources.Count - 1 do
- for j := 0 to TDataSource(FDataSources[i]).DataLinks.Count - 1 do
- begin
- DataLink:=TDataLink(TDataSource(FDataSources[i]).DataLinks[j]);
- if ABufferCount<DataLink.BufferCount then
- ABufferCount:=DataLink.BufferCount;
- end;
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size, end count: ',ABufferCount);
- {$endif}
- If (FBufferCount=ABufferCount) Then
- exit;
- {$ifdef dsdebug}
- Writeln('Setting buffer list size');
- {$endif}
- SetBufListSize(ABufferCount);
- {$ifdef dsdebug}
- Writeln('Getting next buffers');
- {$endif}
- GetNextRecords;
- if (FRecordCount < FBufferCount) and not IsUniDirectional then
- begin
- FActiveRecord := FActiveRecord + GetPriorRecords;
- CursorPosChanged;
- end;
- {$Ifdef dsDebug}
- WriteLn(
- 'SetBufferCount: FActiveRecord=',FActiveRecord,
- ' FCurrentRecord=',FCurrentRecord,
- ' FBufferCount= ',FBufferCount,
- ' FRecordCount=',FRecordCount);
- {$Endif}
- end;
- procedure TDataSet.SetBookmarkStr(const Value: TBookmarkStr);
- Var
- O: TJSObject;
- B : TBookmark;
- begin
- O:=TJSJSON.parseObject(Value);
- B.Flag:=TBookmarkFlag(O.Properties['flag']);
- B.Data:=O.Properties['Index'];
- GotoBookMark(B)
- end;
- procedure TDataSet.SetBufListSize(Value: Longint);
- Var
- I : Integer;
- begin
- if Value < 0 then Value := 0;
- If Value=FBufferCount Then
- exit;
- // Less buffers, shift buffers.
- if value>FBufferCount then
- begin
- SetLength(FBuffers,Value+1); // FBuffers[FBufferCount] is used as a temp buffer
- For I:=FBufferCount to Value do
- FBuffers[i]:=AllocRecordBuffer;
- end
- else if value<FBufferCount then
- if (value>=0) and (FActiveRecord>Value-1) then
- begin
- for i := 0 to (FActiveRecord-Value) do
- ShiftBuffersBackward;
- FActiveRecord := Value -1;
- end;
- SetLength(FBuffers,Value+1); // FBuffers[FBufferCount] is used as a temp buffer
- FBufferCount:=Value;
- if FRecordCount > FBufferCount then
- FRecordCount := FBufferCount;
- end;
- procedure TDataSet.SetChildOrder(Child: TComponent; Order: Longint);
- var
- Field: TField;
- begin
- Field := Child as TField;
- if Fields.IndexOf(Field) >= 0 then
- Field.Index := Order;
- end;
- procedure TDataSet.SetCurrentRecord(Index: Longint);
- begin
- If FCurrentRecord<>Index then
- begin
- {$ifdef DSdebug}
- Writeln ('Setting current record to: ',index);
- {$endif}
- if not FIsUniDirectional then Case GetBookMarkFlag(FBuffers[Index]) of
- bfCurrent : InternalSetToRecord(FBuffers[Index]);
- bfBOF : InternalFirst;
- bfEOF : InternalLast;
- end;
- FCurrentRecord:=Index;
- end;
- end;
- procedure TDataSet.SetDefaultFields(const Value: Boolean);
- begin
- FDefaultFields := Value;
- end;
- procedure TDataSet.CheckBiDirectional;
- begin
- if FIsUniDirectional then DataBaseError(SUniDirectional,Self);
- end;
- procedure TDataSet.SetFilterOptions(Value: TFilterOptions);
- begin
- CheckBiDirectional;
- FFilterOptions := Value;
- end;
- procedure TDataSet.SetFilterText(const Value: string);
- begin
- FFilterText := value;
- end;
- procedure TDataSet.SetFiltered(Value: Boolean);
- begin
- if Value then CheckBiDirectional;
- FFiltered := value;
- end;
- procedure TDataSet.SetFound(const Value: Boolean);
- begin
- FFound := Value;
- end;
- procedure TDataSet.SetModified(Value: Boolean);
- begin
- FModified := value;
- end;
- procedure TDataSet.SetName(const NewName: TComponentName);
- function CheckName(const FieldName: string): string;
- var i,j: integer;
- begin
- Result := FieldName;
- i := 0;
- j := 0;
- while (i < Fields.Count) do begin
- if Result = Fields[i].FieldName then begin
- inc(j);
- Result := FieldName + IntToStr(j);
- end else Inc(i);
- end;
- end;
- var
- i: integer;
- nm: string;
- old: string;
- begin
- if Self.Name = NewName then Exit;
- old := Self.Name;
- inherited SetName(NewName);
- if (csDesigning in ComponentState) then
- for i := 0 to Fields.Count - 1 do begin
- nm := old + Fields[i].FieldName;
- if Copy(Fields[i].Name, 1, Length(nm)) = nm then
- Fields[i].Name := CheckName(NewName + Fields[i].FieldName);
- end;
- end;
- procedure TDataSet.SetOnFilterRecord(const Value: TFilterRecordEvent);
- begin
- CheckBiDirectional;
- FOnFilterRecord := Value;
- end;
- procedure TDataSet.SetRecNo(Value: Longint);
- begin
- //!! To be implemented
- end;
- procedure TDataSet.SetState(Value: TDataSetState);
- begin
- If Value<>FState then
- begin
- FState:=Value;
- if Value=dsBrowse then
- FModified:=false;
- DataEvent(deUpdateState,0);
- end;
- end;
- function TDataSet.TempBuffer: TDataRecord;
- begin
- Result := FBuffers[FRecordCount];
- end;
- procedure TDataSet.UpdateIndexDefs;
- begin
- // Empty Abstract
- end;
- function TDataSet.AllocRecordBuffer: TDataRecord;
- begin
- Result.data:=Null;
- Result.state:=rsNew;
- // Result := nil;
- end;
- procedure TDataSet.FreeRecordBuffer(var Buffer: TDataRecord);
- begin
- // empty stub
- end;
- procedure TDataSet.GetBookmarkData(Buffer: TDataRecord; var Data: TBookmark);
- begin
- end;
- function TDataSet.GetBookmarkFlag(Buffer: TDataRecord): TBookmarkFlag;
- begin
- Result := bfCurrent;
- end;
- function TDataSet.ControlsDisabled: Boolean;
- begin
- Result := (FDisableControlsCount > 0);
- end;
- function TDataSet.ActiveBuffer: TDataRecord;
- begin
- {$ifdef dsdebug}
- Writeln ('Active buffer requested. Returning record number: ',ActiveRecord);
- {$endif}
- Result:=FBuffers[FActiveRecord];
- end;
- function TDataSet.GetFieldData(Field: TField): JSValue;
- begin
- Result:=GetFieldData(Field,ActiveBuffer);
- end;
- procedure TDataSet.SetFieldData(Field: TField; AValue: JSValue);
- begin
- SetFieldData(Field,FBuffers[FActiveRecord],AValue);
- end;
- procedure TDataSet.Append;
- begin
- DoInsertAppend(True);
- end;
- procedure TDataSet.InternalInsert;
- begin
- //!! To be implemented
- end;
- procedure TDataSet.AppendRecord(const Values: array of JSValue);
- begin
- DoInsertAppendRecord(Values,True);
- end;
- function TDataSet.BookmarkValid(ABookmark: TBookmark): Boolean;
- {
- Should be overridden by descendant objects.
- }
- begin
- Result:=False
- end;
- function TDataSet.ConvertToDateTime(aValue: JSValue; ARaiseException: Boolean): TDateTime;
- begin
- Result:=DefaultConvertToDateTime(aValue,ARaiseException);
- end;
- class function TDataSet.DefaultConvertToDateTime(aValue: JSValue; ARaiseException: Boolean): TDateTime;
- begin
- Result:=0;
- if IsString(aValue) then
- begin
- if not TryRFC3339ToDateTime(String(AValue),Result) then
- Raise EConvertError.CreateFmt(SErrInvalidDateTime,[String(aValue)])
- end
- else if IsNumber(aValue) then
- Result:=TDateTime(AValue)
- end;
- function TDataSet.ConvertDateTimeToNative(aValue : TDateTime) : JSValue;
- begin
- Result:=DefaultConvertDateTimeToNative(aValue);
- end;
- Class function TDataSet.DefaultConvertDateTimeToNative(aValue : TDateTime) : JSValue;
- begin
- Result:=DateTimeToRFC3339(aValue);
- end;
- function TDataSet.BlobDataToBytes(aValue: JSValue): TBytes;
- begin
- Result:=DefaultBlobDataToBytes(aValue);
- end;
- class function TDataSet.DefaultBlobDataToBytes(aValue: JSValue): TBytes;
- Var
- S : String;
- I,J,L : Integer;
- begin
- SetLength(Result,0);
- // We assume a string, hex-encoded.
- if isString(AValue) then
- begin
- S:=String(Avalue);
- L:=Length(S);
- SetLength(Result,(L+1) div 2);
- I:=1;
- J:=0;
- While (I<L) do
- begin
- Result[J]:=StrToInt('$'+Copy(S,I,2));
- Inc(I,2);
- Inc(J,1);
- end;
- end;
- end;
- Function TDataSet.BytesToBlobData(aValue : TBytes) : JSValue ;
- begin
- Result:=DefaultBytesToBlobData(aValue);
- end;
- Class Function TDataSet.DefaultBytesToBlobData(aValue : TBytes) : JSValue;
- Var
- S : String;
- I : Integer;
- begin
- if Length(AValue)=0 then
- Result:=Null
- else
- begin
- S:='';
- For I:=0 to Length(AValue) do
- TJSString(S).Concat(IntToHex(aValue[i],2));
- end;
- end;
- procedure TDataSet.Cancel;
- begin
- If State in [dsEdit,dsInsert] then
- begin
- DataEvent(deCheckBrowseMode,0);
- DoBeforeCancel;
- UpdateCursorPos;
- InternalCancel;
- if (State = dsInsert) and (FRecordCount = 1) then
- begin
- FEOF := true;
- FBOF := true;
- FRecordCount := 0;
- InitRecord(FBuffers[FActiveRecord]);
- SetState(dsBrowse);
- DataEvent(deDatasetChange,0);
- end
- else
- begin
- SetState(dsBrowse);
- SetCurrentRecord(FActiveRecord);
- resync([]);
- end;
- DoAfterCancel;
- end;
- end;
- procedure TDataSet.CheckBrowseMode;
- begin
- CheckActive;
- DataEvent(deCheckBrowseMode,0);
- Case State of
- dsEdit,dsInsert:
- begin
- UpdateRecord;
- If Modified then
- Post
- else
- Cancel;
- end;
- dsSetKey: Post;
- end;
- end;
- procedure TDataSet.ClearFields;
- begin
- DataEvent(deCheckBrowseMode, 0);
- InternalInitRecord(FBuffers[FActiveRecord]);
- if State <> dsSetKey then
- GetCalcFields(FBuffers[FActiveRecord]);
- DataEvent(deRecordChange, 0);
- end;
- procedure TDataSet.Close;
- begin
- Active:=False;
- end;
- procedure TDataSet.ApplyUpdates;
- begin
- DoBeforeApplyUpdates;
- DoApplyUpdates;
- end;
- function TDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
- begin
- Result:=0;
- end;
- procedure TDataSet.CursorPosChanged;
- begin
- FCurrentRecord:=-1;
- end;
- procedure TDataSet.Delete;
- Var
- R : TRecordUpdateDescriptor;
- begin
- If Not CanModify then
- DatabaseError(SDatasetReadOnly,Self);
- If IsEmpty then
- DatabaseError(SDatasetEmpty,Self);
- if State in [dsInsert] then
- begin
- Cancel;
- end else begin
- DataEvent(deCheckBrowseMode,0);
- {$ifdef dsdebug}
- writeln ('Delete: checking required fields');
- {$endif}
- DoBeforeDelete;
- DoBeforeScroll;
- R:=AddToChangeList(usDeleted);
- If Not TryDoing(@InternalDelete,OnDeleteError) then
- begin
- if Assigned(R) then
- RemoveFromChangeList(R);
- exit;
- end;
- {$ifdef dsdebug}
- writeln ('Delete: Internaldelete succeeded');
- {$endif}
- SetState(dsBrowse);
- {$ifdef dsdebug}
- writeln ('Delete: Browse mode set');
- {$endif}
- SetCurrentRecord(FActiveRecord);
- Resync([]);
- DoAfterDelete;
- DoAfterScroll;
- end;
- end;
- procedure TDataSet.DisableControls;
- begin
- If FDisableControlsCount=0 then
- begin
- { Save current state,
- needed to detect change of state when enabling controls.
- }
- FDisableControlsState:=FState;
- FEnableControlsEvent:=deDatasetChange;
- end;
- Inc(FDisableControlsCount);
- end;
- procedure TDataSet.DoInsertAppend(DoAppend: Boolean);
- procedure DoInsert(DoAppend : Boolean);
- Var
- BookBeforeInsert : TBookmark;
- TempBuf : TDataRecord;
- I : integer;
- begin
- // need to scroll up al buffers after current one,
- // but copy current bookmark to insert buffer.
- If FRecordCount > 0 then
- BookBeforeInsert:=Bookmark;
- if not DoAppend then
- begin
- if FRecordCount > 0 then
- begin
- TempBuf := FBuffers[FBufferCount];
- for I:=FBufferCount downto FActiveRecord+1 do
- FBuffers[I]:=FBuffers[I-1];
- FBuffers[FActiveRecord]:=TempBuf;
- end;
- end
- else if FRecordCount=FBufferCount then
- ShiftBuffersBackward
- else
- begin
- if FRecordCount>0 then
- inc(FActiveRecord);
- end;
- // Active buffer is now edit buffer. Initialize.
- InitRecord(FBuffers[FActiveRecord]);
- CursorPosChanged;
- // Put bookmark in edit buffer.
- if FRecordCount=0 then
- SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF)
- else
- begin
- fBOF := false;
- // 29:01:05, JvdS: Why is this here?!? It can result in records with the same bookmark-data?
- // I would say that the 'internalinsert' should do this. But I don't know how Tdbf handles it
- // 1-apr-06, JvdS: It just sets the bookmark of the newly inserted record to the place
- // where the record should be inserted. So it is ok.
- if FRecordCount > 0 then
- begin
- SetBookMarkData(FBuffers[FActiveRecord],BookBeforeInsert);
- FreeBookmark(BookBeforeInsert);
- end;
- end;
- InternalInsert;
- // update buffer count.
- If FRecordCount<FBufferCount then
- Inc(FRecordCount);
- end;
- begin
- CheckBrowseMode;
- If Not CanModify then
- DatabaseError(SDatasetReadOnly,Self);
- DoBeforeInsert;
- DoBeforeScroll;
- If Not DoAppend then
- begin
- {$ifdef dsdebug}
- Writeln ('going to insert mode');
- {$endif}
- DoInsert(false);
- end
- else
- begin
- {$ifdef dsdebug}
- Writeln ('going to append mode');
- {$endif}
- ClearBuffers;
- InternalLast;
- GetPriorRecords;
- if FRecordCount>0 then
- FActiveRecord:=FRecordCount-1;
- DoInsert(True);
- SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF);
- FBOF :=False;
- FEOF := true;
- end;
- SetState(dsInsert);
- try
- DoOnNewRecord;
- except
- SetCurrentRecord(FActiveRecord);
- resync([]);
- raise;
- end;
- // mark as not modified.
- FModified:=False;
- // Final events.
- DataEvent(deDatasetChange,0);
- DoAfterInsert;
- DoAfterScroll;
- {$ifdef dsdebug}
- Writeln ('Done with append');
- {$endif}
- end;
- procedure TDataSet.Edit;
- begin
- If State in [dsEdit,dsInsert] then exit;
- CheckBrowseMode;
- If Not CanModify then
- DatabaseError(SDatasetReadOnly,Self);
- If FRecordCount = 0 then
- begin
- Append;
- Exit;
- end;
- DoBeforeEdit;
- If Not TryDoing(@InternalEdit,OnEditError) then exit;
- GetCalcFields(FBuffers[FActiveRecord]);
- SetState(dsEdit);
- DataEvent(deRecordChange,0);
- DoAfterEdit;
- end;
- procedure TDataSet.EnableControls;
- begin
- if FDisableControlsCount > 0 then
- Dec(FDisableControlsCount);
- if FDisableControlsCount = 0 then begin
- if FState <> FDisableControlsState then
- DataEvent(deUpdateState, 0);
- if (FState <> dsInactive) and (FDisableControlsState <> dsInactive) then
- DataEvent(FEnableControlsEvent, 0);
- end;
- end;
- function TDataSet.FieldByName(const FieldName: string): TField;
- begin
- Result:=FindField(FieldName);
- If Result=Nil then
- DatabaseErrorFmt(SFieldNotFound,[FieldName],Self);
- end;
- function TDataSet.FindField(const FieldName: string): TField;
- begin
- Result:=FFieldList.FindField(FieldName);
- end;
- function TDataSet.FindFirst: Boolean;
- begin
- Result:=False;
- end;
- function TDataSet.FindLast: Boolean;
- begin
- Result:=False;
- end;
- function TDataSet.FindNext: Boolean;
- begin
- Result:=False;
- end;
- function TDataSet.FindPrior: Boolean;
- begin
- Result:=False;
- end;
- procedure TDataSet.First;
- begin
- CheckBrowseMode;
- DoBeforeScroll;
- if not FIsUniDirectional then
- ClearBuffers
- else if not FBof then
- begin
- Active := False;
- Active := True;
- end;
- try
- InternalFirst;
- if not FIsUniDirectional then GetNextRecords;
- finally
- FBOF:=True;
- DataEvent(deDatasetChange,0);
- DoAfterScroll;
- end;
- end;
- procedure TDataSet.FreeBookmark(ABookmark: TBookmark);
- begin
- {$ifdef noautomatedbookmark}
- FreeMem(ABookMark,FBookMarkSize);
- {$endif}
- end;
- function TDataSet.GetBookmark: TBookmark;
- begin
- if BookmarkAvailable then
- GetBookMarkdata(ActiveBuffer,Result)
- else
- Result.Data:=Null;
- end;
- function TDataSet.GetCurrentRecord(Buffer: TDataRecord): Boolean;
- begin
- Result:=False;
- end;
- procedure TDataSet.GetFieldList(List: TList; const FieldNames: string);
- var
- F: TField;
- N: String;
- StrPos: Integer;
- begin
- if (FieldNames = '') or (List = nil) then
- Exit;
- StrPos := 1;
- repeat
- N := ExtractFieldName(FieldNames, StrPos);
- F := FieldByName(N);
- List.Add(F);
- until StrPos > Length(FieldNames);
- end;
- procedure TDataSet.GetFieldList(List: TFPList; const FieldNames: string);
- var
- F: TField;
- N: String;
- StrPos: Integer;
- begin
- if (FieldNames = '') or (List = nil) then
- Exit;
- StrPos := 1;
- repeat
- N := ExtractFieldName(FieldNames, StrPos);
- F := FieldByName(N);
- List.Add(F);
- until StrPos > Length(FieldNames);
- end;
- procedure TDataSet.GetFieldNames(List: TStrings);
- begin
- FFieldList.GetFieldNames(List);
- end;
- procedure TDataSet.GotoBookmark(const ABookmark: TBookmark);
- begin
- If Assigned(ABookMark) then
- begin
- CheckBrowseMode;
- DoBeforeScroll;
- {$ifdef dsdebug}
- Writeln('Gotobookmark: ',ABookMark.Data);
- {$endif}
- InternalGotoBookMark(ABookMark);
- Resync([rmExact,rmCenter]);
- DoAfterScroll;
- end;
- end;
- procedure TDataSet.Insert;
- begin
- DoInsertAppend(False);
- end;
- procedure TDataSet.InsertRecord(const Values: array of JSValue);
- begin
- DoInsertAppendRecord(Values,False);
- end;
- function TDataSet.IsEmpty: Boolean;
- begin
- Result:=(fBof and fEof) and
- (not (State = dsInsert)); // After an insert on an empty dataset, both fBof and fEof are true
- end;
- function TDataSet.IsLinkedTo(ADataSource: TDataSource): Boolean;
- begin
- //!! Not tested, I never used nested DS
- if (ADataSource = nil) or (ADataSource.Dataset = nil) then begin
- Result := False
- end else if ADataSource.Dataset = Self then begin
- Result := True;
- end else begin
- Result := ADataSource.Dataset.IsLinkedTo(ADataSource.Dataset.DataSource);
- end;
- //!! DataSetField not implemented
- end;
- function TDataSet.IsSequenced: Boolean;
- begin
- Result := True;
- end;
- procedure TDataSet.Last;
- begin
- CheckBiDirectional;
- CheckBrowseMode;
- DoBeforeScroll;
- ClearBuffers;
- try
- // Writeln('FActiveRecord before last',FActiveRecord);
- InternalLast;
- // Writeln('FActiveRecord after last',FActiveRecord);
- GetPriorRecords;
- // Writeln('FRecordCount: ',FRecordCount);
- if FRecordCount>0 then
- FActiveRecord:=FRecordCount-1;
- // Writeln('FActiveRecord ',FActiveRecord);
- finally
- FEOF:=true;
- DataEvent(deDataSetChange, 0);
- DoAfterScroll;
- end;
- end;
- function TDataSet.DoLoad(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean;
- Var
- Request : TDataRequest;
- begin
- if not (loNoEvents in aOptions) then
- DoBeforeLoad;
- Result:=DataProxy<>Nil;
- if Not Result then
- Exit;
- Request:=DataProxy.GetDataRequest(aOptions,@HandleRequestResponse,aAfterLoad);
- Request.FDataset:=Self;
- If Active then
- Request.FBookmark:=GetBookmark;
- Inc(FDataRequestID);
- Request.FRequestID:=FDataRequestID;
- DataProxy.DoGetData(Request);
- end;
- function TDataSet.Load(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean;
- begin
- if loAtEOF in aOptions then
- DatabaseError(SatEOFInternalOnly,Self);
- Result:=DoLoad(aOptions,aAfterLoad);
- end;
- function TDataSet.MoveBy(Distance: Longint): Longint;
- Var
- TheResult: Integer;
- Function ScrollForward : Integer;
- begin
- Result:=0;
- {$ifdef dsdebug}
- Writeln('Scrolling forward : ',Distance);
- Writeln('Active buffer : ',FActiveRecord);
- Writeln('RecordCount : ',FRecordCount);
- WriteLn('BufferCount : ',FBufferCount);
- {$endif}
- FBOF:=False;
- While (Distance>0) and not FEOF do
- begin
- If FActiveRecord<FRecordCount-1 then
- begin
- Inc(FActiveRecord);
- Dec(Distance);
- Inc(TheResult); //Inc(Result);
- end
- else
- begin
- {$ifdef dsdebug}
- Writeln('Moveby : need next record');
- {$endif}
- If GetNextRecord then
- begin
- Dec(Distance);
- Dec(Result);
- Inc(TheResult); //Inc(Result);
- end
- else
- begin
- FEOF:=true;
- // Allow to load more records.
- DoLoad([loNoOpen,loAtEOF],Nil);
- end;
- end;
- end
- end;
- Function ScrollBackward : Integer;
- begin
- CheckBiDirectional;
- Result:=0;
- {$ifdef dsdebug}
- Writeln('Scrolling backward : ',Abs(Distance));
- Writeln('Active buffer : ',FActiveRecord);
- Writeln('RecordCunt : ',FRecordCount);
- WriteLn('BufferCount : ',FBufferCount);
- {$endif}
- FEOF:=False;
- While (Distance<0) and not FBOF do
- begin
- If FActiveRecord>0 then
- begin
- Dec(FActiveRecord);
- Inc(Distance);
- Dec(TheResult); //Dec(Result);
- end
- else
- begin
- {$ifdef dsdebug}
- Writeln('Moveby : need next record');
- {$endif}
- If GetPriorRecord then
- begin
- Inc(Distance);
- Inc(Result);
- Dec(TheResult); //Dec(Result);
- end
- else
- FBOF:=true;
- end;
- end
- end;
- Var
- Scrolled : Integer;
- begin
- CheckBrowseMode;
- Result:=0; TheResult:=0;
- DoBeforeScroll;
- If (Distance = 0) or
- ((Distance>0) and FEOF) or
- ((Distance<0) and FBOF) then
- exit;
- Try
- Scrolled := 0;
- If Distance>0 then
- Scrolled:=ScrollForward
- else
- Scrolled:=ScrollBackward;
- finally
- {$ifdef dsdebug}
- WriteLn('ActiveRecord=', FActiveRecord,' FEOF=',FEOF,' FBOF=',FBOF);
- {$Endif}
- DataEvent(deDatasetScroll,Scrolled);
- DoAfterScroll;
- Result:=TheResult;
- end;
- end;
- procedure TDataSet.Next;
- begin
- if BlockReadSize>0 then
- BlockReadNext
- else
- MoveBy(1);
- end;
- procedure TDataSet.BlockReadNext;
- begin
- MoveBy(1);
- end;
- procedure TDataSet.Open;
- begin
- Active:=True;
- end;
- procedure TDataSet.Post;
- Const
- UpdateStates : Array[Boolean] of TUpdateStatus = (usModified,usInserted);
- Var
- R : TRecordUpdateDescriptor;
- WasInsert : Boolean;
- begin
- UpdateRecord;
- if State in [dsEdit,dsInsert] then
- begin
- DataEvent(deCheckBrowseMode,0);
- {$ifdef dsdebug}
- writeln ('Post: checking required fields');
- {$endif}
- DoBeforePost;
- WasInsert:=State=dsInsert;
- If Not TryDoing(@InternalPost,OnPostError) then exit;
- CursorPosChanged;
- {$ifdef dsdebug}
- writeln ('Post: Internalpost succeeded');
- {$endif}
- // First set the state to dsBrowse, then the Resync, to prevent the calling of
- // the deDatasetChange event, while the state is still 'editable', while the db isn't
- SetState(dsBrowse);
- Resync([]);
- // We get the new values here, since the bookmark should now be correct to find the record later on when doing applyupdates.
- R:=AddToChangeList(UpdateStates[wasInsert]);
- if Assigned(R) then
- R.FBookmark:=BookMark;
- {$ifdef dsdebug}
- writeln ('Post: Browse mode set');
- {$endif}
- DoAfterPost;
- end
- else if State<>dsSetKey then
- DatabaseErrorFmt(SNotEditing, [Name], Self);
- end;
- procedure TDataSet.Prior;
- begin
- MoveBy(-1);
- end;
- procedure TDataSet.Refresh;
- begin
- CheckbrowseMode;
- DoBeforeRefresh;
- UpdateCursorPos;
- InternalRefresh;
- { SetCurrentRecord is called by UpdateCursorPos already, so as long as
- InternalRefresh doesn't do strange things this should be ok. }
- // SetCurrentRecord(FActiveRecord);
- Resync([]);
- DoAfterRefresh;
- end;
- procedure TDataSet.RegisterDataSource(ADataSource: TDataSource);
- begin
- FDataSources.Add(ADataSource);
- RecalcBufListSize;
- end;
- procedure TDataSet.Resync(Mode: TResyncMode);
- var i,count : integer;
- begin
- // See if we can find the requested record.
- {$ifdef dsdebug}
- Writeln ('Resync called');
- {$endif}
- if FIsUnidirectional then Exit;
- // place the cursor of the underlying dataset to the active record
- // SetCurrentRecord(FActiveRecord);
- // Now look if the data on the current cursor of the underlying dataset is still available
- If GetRecord(FBuffers[0],gmCurrent,False)<>grOk Then
- // If that fails and rmExact is set, then raise an exception
- If rmExact in Mode then
- DatabaseError(SNoSuchRecord,Self)
- // else, if rmexact is not set, try to fetch the next or prior record in the underlying dataset
- else if (GetRecord(FBuffers[0],gmNext,True)<>grOk) and
- (GetRecord(FBuffers[0],gmPrior,True)<>grOk) then
- begin
- {$ifdef dsdebug}
- Writeln ('Resync: fuzzy resync');
- {$endif}
- // nothing found, invalidate buffer and bail out.
- ClearBuffers;
- // Make sure that the active record is 'empty', ie: that all fields are null
- InternalInitRecord(FBuffers[FActiveRecord]);
- DataEvent(deDatasetChange,0);
- exit;
- end;
- FCurrentRecord := 0;
- FEOF := false;
- FBOF := false;
- // If we've arrived here, FBuffer[0] is the current record
- If (rmCenter in Mode) then
- count := (FRecordCount div 2)
- else
- count := FActiveRecord;
- i := 0;
- FRecordCount := 1;
- FActiveRecord := 0;
- // Fill the buffers before the active record
- while (i < count) and GetPriorRecord do
- inc(i);
- FActiveRecord := i;
- // Fill the rest of the buffer
- GetNextRecords;
- // If the buffer is not full yet, try to fetch some more prior records
- if FRecordCount < FBufferCount then FActiveRecord:=FActiveRecord+getpriorrecords;
- // That's all folks!
- DataEvent(deDatasetChange,0);
- end;
- procedure TDataSet.SetFields(const Values: array of JSValue);
- Var I : longint;
- begin
- For I:=0 to high(Values) do
- Fields[I].AssignValue(Values[I]);
- end;
- function TDataSet.TryDoing(P: TDataOperation; Ev: TDatasetErrorEvent): Boolean;
- Var Retry : TDataAction;
- begin
- {$ifdef dsdebug}
- Writeln ('Trying to do');
- If P=Nil then writeln ('Procedure to call is nil !!!');
- {$endif dsdebug}
- Result:=True;
- Retry:=daRetry;
- while Retry=daRetry do
- Try
- {$ifdef dsdebug}
- Writeln ('Trying : updatecursorpos');
- {$endif dsdebug}
- UpdateCursorPos;
- {$ifdef dsdebug}
- Writeln ('Trying to do it');
- {$endif dsdebug}
- P();
- exit;
- except
- On E : EDatabaseError do
- begin
- retry:=daFail;
- If Assigned(Ev) then
- Ev(Self,E,Retry);
- Case Retry of
- daFail : Raise;
- daAbort : Abort;
- end;
- end;
- else
- Raise;
- end;
- {$ifdef dsdebug}
- Writeln ('Exit Trying to do');
- {$endif dsdebug}
- end;
- procedure TDataSet.UpdateCursorPos;
- begin
- If FRecordCount>0 then
- SetCurrentRecord(FActiveRecord);
- end;
- procedure TDataSet.UpdateRecord;
- begin
- if not (State in dsEditModes) then
- DatabaseErrorFmt(SNotEditing, [Name], Self);
- DataEvent(deUpdateRecord, 0);
- end;
- function TDataSet.GetPendingUpdates: TResolveInfoArray;
- Var
- L : TRecordUpdateDescriptorList;
- I : integer;
- begin
- L:=TRecordUpdateDescriptorList.Create;
- try
- SetLength(Result,GetRecordUpdates(L));
- For I:=0 to L.Count-1 do
- Result[i]:=RecordUpdateDescriptorToResolveInfo(L[i]);
- finally
- L.Free;
- end;
- end;
- function TDataSet.UpdateStatus: TUpdateStatus;
- begin
- Result:=usUnmodified;
- end;
- procedure TDataSet.SetConstraints(Value: TCheckConstraints);
- begin
- FConstraints.Assign(Value);
- end;
- procedure TDataSet.SetDataProxy(AValue: TDataProxy);
- begin
- If AValue=FDataProxy then
- exit;
- if Assigned(FDataProxy) then
- FDataProxy.RemoveFreeNotification(Self);
- FDataProxy:=AValue;
- if Assigned(FDataProxy) then
- FDataProxy.FreeNotification(Self)
- end;
- function TDataSet.GetfieldCount: Integer;
- begin
- Result:=FFieldList.Count;
- end;
- procedure TDataSet.ShiftBuffersBackward;
- var
- TempBuf : TDataRecord;
- I : Integer;
- begin
- TempBuf := FBuffers[0];
- For I:=1 to FBufferCount do
- FBuffers[I-1]:=FBuffers[i];
- FBuffers[FBufferCount]:=TempBuf;
- end;
- procedure TDataSet.ShiftBuffersForward;
- var
- TempBuf : TDataRecord;
- I : Integer;
- begin
- TempBuf := FBuffers[FBufferCount];
- For I:=FBufferCount downto 1 do
- FBuffers[I]:=FBuffers[i-1];
- FBuffers[0]:=TempBuf;
- end;
- function TDataSet.GetFieldValues(const FieldName: string): JSValue;
- var
- i: Integer;
- FieldList: TList;
- A : TJSValueDynArray;
- begin
- FieldList := TList.Create;
- try
- GetFieldList(FieldList, FieldName);
- if FieldList.Count>1 then
- begin
- SetLength(A,FieldList.Count);
- for i := 0 to FieldList.Count - 1 do
- A[i] := TField(FieldList[i]).Value;
- Result:=A;
- end
- else
- Result := FieldByName(FieldName).Value;
- finally
- FieldList.Free;
- end;
- end;
- procedure TDataSet.SetFieldValues(const FieldName: string; Value: JSValue);
- var
- i : Integer;
- FieldList: TList;
- A : TJSValueDynArray;
- begin
- if IsArray(Value) then
- begin
- FieldList := TList.Create;
- try
- GetFieldList(FieldList, FieldName);
- A:=TJSValueDynArray(Value);
- if (FieldList.Count = 1) and (Length(A)>0) then
- // Allow for a field type that can deal with an array
- FieldByName(FieldName).Value := Value
- else
- for i := 0 to FieldList.Count - 1 do
- TField(FieldList[i]).Value := A[i];
- finally
- FieldList.Free;
- end;
- end
- else
- FieldByName(FieldName).Value := Value;
- end;
- function TDataSet.Locate(const KeyFields: string; const KeyValues: JSValue;
- Options: TLocateOptions): boolean;
- begin
- CheckBiDirectional;
- Result := False;
- end;
- function TDataSet.Lookup(const KeyFields: string; const KeyValues: JSValue;
- const ResultFields: string): JSValue;
- begin
- CheckBiDirectional;
- Result := Null;
- end;
- procedure TDataSet.UnRegisterDataSource(ADataSource: TDataSource);
- begin
- FDataSources.Remove(ADataSource);
- end;
- { ---------------------------------------------------------------------
- TFieldDef
- ---------------------------------------------------------------------}
- constructor TFieldDef.Create(ACollection: TCollection);
- begin
- Inherited Create(ACollection);
- FFieldNo:=Index+1;
- end;
- constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType; ASize: Integer; ARequired: Boolean;
- AFieldNo: Longint);
- begin
- {$ifdef dsdebug }
- Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
- {$endif}
- Inherited Create(AOwner);
- Name:=Aname;
- FDatatype:=ADatatype;
- FSize:=ASize;
- FRequired:=ARequired;
- FPrecision:=-1;
- FFieldNo:=AFieldNo;
- end;
- destructor TFieldDef.Destroy;
- begin
- Inherited destroy;
- end;
- procedure TFieldDef.Assign(Source: TPersistent);
- var fd: TFieldDef;
- begin
- fd := nil;
- if Source is TFieldDef then
- fd := Source as TFieldDef;
- if Assigned(fd) then begin
- Collection.BeginUpdate;
- try
- Name := fd.Name;
- DataType := fd.DataType;
- Size := fd.Size;
- Precision := fd.Precision;
- FRequired := fd.Required;
- finally
- Collection.EndUpdate;
- end;
- end
- else
- inherited Assign(Source);
- end;
- function TFieldDef.CreateField(AOwner: TComponent): TField;
- var TheField : TFieldClass;
- begin
- {$ifdef dsdebug}
- Writeln ('Creating field '+FNAME);
- {$endif dsdebug}
- TheField:=GetFieldClass;
- if TheField=Nil then
- DatabaseErrorFmt(SUnknownFieldType,[FName]);
- Result:=TheField.Create(AOwner);
- Try
- Result.FFieldDef:=Self;
- Result.Size:=FSize;
- Result.Required:=FRequired;
- Result.FFieldName:=FName;
- Result.FDisplayLabel:=DisplayName;
- Result.FFieldNo:=Self.FieldNo;
- Result.SetFieldType(DataType);
- Result.FReadOnly:=(faReadOnly in Attributes);
- {$ifdef dsdebug}
- Writeln ('TFieldDef.CreateField : Result Fieldno : ',Result.FieldNo,'; Self : ',FieldNo);
- Writeln ('TFieldDef.CreateField : Trying to set dataset');
- {$endif dsdebug}
- Result.Dataset:=TFieldDefs(Collection).Dataset;
- if (Result is TFloatField) then
- TFloatField(Result).Precision := FPrecision;
- except
- Result.Free;
- Raise;
- end;
- end;
- procedure TFieldDef.SetAttributes(AValue: TFieldAttributes);
- begin
- FAttributes := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetDataType(AValue: TFieldType);
- begin
- FDataType := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetPrecision(const AValue: Longint);
- begin
- FPrecision := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetSize(const AValue: Integer);
- begin
- FSize := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetRequired(const AValue: Boolean);
- begin
- FRequired := AValue;
- Changed(False);
- end;
- function TFieldDef.GetFieldClass: TFieldClass;
- begin
- //!! Should be owner as tdataset but that doesn't work ??
- If Assigned(Collection) And
- (Collection is TFieldDefs) And
- Assigned(TFieldDefs(Collection).Dataset) then
- Result:=TFieldDefs(Collection).Dataset.GetFieldClass(FDataType)
- else
- Result:=Nil;
- end;
- { ---------------------------------------------------------------------
- TFieldDefs
- ---------------------------------------------------------------------}
- {
- destructor TFieldDefs.Destroy;
- begin
- FItems.Free;
- // This will destroy all fielddefs since we own them...
- Inherited Destroy;
- end;
- }
- procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType);
- begin
- Add(AName,ADatatype,0,False);
- end;
- procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize : Word);
- begin
- Add(AName,ADatatype,ASize,False);
- end;
- procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word;
- ARequired: Boolean);
- begin
- If Length(AName)=0 Then
- DatabaseError(SNeedFieldName,Dataset);
- // the fielddef will register itself here as an owned component.
- // fieldno is 1 based !
- BeginUpdate;
- try
- Add(AName,ADataType,ASize,ARequired,Count+1);
- finally
- EndUpdate;
- end;
- end;
- function TFieldDefs.GetItem(Index: Longint): TFieldDef;
- begin
- Result := TFieldDef(inherited Items[Index]);
- end;
- procedure TFieldDefs.SetItem(Index: Longint; const AValue: TFieldDef);
- begin
- inherited Items[Index] := AValue;
- end;
- class function TFieldDefs.FieldDefClass: TFieldDefClass;
- begin
- Result:=TFieldDef;
- end;
- constructor TFieldDefs.Create(ADataSet: TDataSet);
- begin
- Inherited Create(ADataset, Owner, FieldDefClass);
- end;
- function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize, APrecision: Integer;
- ARequired, AReadOnly: Boolean; AFieldNo: Integer): TFieldDef;
- begin
- Result:=FieldDefClass.Create(Self, MakeNameUnique(AName), ADataType, ASize, ARequired, AFieldNo);
- if AReadOnly then
- Result.Attributes := Result.Attributes + [faReadOnly];
- end;
- function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Integer): TFieldDef;
- begin
- Result:=FieldDefClass.Create(Self,AName,ADataType,ASize,ARequired,AFieldNo);
- end;
- procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
- var I : longint;
- begin
- Clear;
- For i:=0 to FieldDefs.Count-1 do
- With FieldDefs[i] do
- Add(Name,DataType,Size,Required);
- end;
- function TFieldDefs.Find(const AName: string): TFieldDef;
- begin
- Result := (Inherited Find(AName)) as TFieldDef;
- if Result=nil then DatabaseErrorFmt(SFieldNotFound,[AName],FDataset);
- end;
- {
- procedure TFieldDefs.Clear;
- var I : longint;
- begin
- For I:=FItems.Count-1 downto 0 do
- TFieldDef(Fitems[i]).Free;
- FItems.Clear;
- end;
- }
- procedure TFieldDefs.Update;
- begin
- if not Updated then
- begin
- If Assigned(Dataset) then
- DataSet.InitFieldDefs;
- Updated := True;
- end;
- end;
- function TFieldDefs.MakeNameUnique(const AName: String): string;
- var DblFieldCount : integer;
- begin
- DblFieldCount := 0;
- Result := AName;
- while assigned(inherited Find(Result)) do
- begin
- inc(DblFieldCount);
- Result := AName + '_' + IntToStr(DblFieldCount);
- end;
- end;
- function TFieldDefs.AddFieldDef: TFieldDef;
- begin
- Result:=FieldDefClass.Create(Self,'',ftUnknown,0,False,Count+1);
- end;
- { ---------------------------------------------------------------------
- TField
- ---------------------------------------------------------------------}
- Const
- // SBCD = 'BCD';
- SBoolean = 'Boolean';
- SDateTime = 'TDateTime';
- SFloat = 'Float';
- SInteger = 'Integer';
- SLargeInt = 'NativeInt';
- SJSValue = 'JSValue';
- SString = 'String';
- SBytes = 'Bytes';
- constructor TField.Create(AOwner: TComponent);
- //Var
- // I : Integer;
- begin
- Inherited Create(AOwner);
- FVisible:=True;
- SetLength(FValidChars,255);
- // For I:=0 to 255 do
- // FValidChars[i]:=Char(i);
- FProviderFlags := [pfInUpdate,pfInWhere];
- end;
- destructor TField.Destroy;
- begin
- IF Assigned(FDataSet) then
- begin
- FDataSet.Active:=False;
- if Assigned(FFields) then
- FFields.Remove(Self);
- end;
- FLookupList.Free;
- Inherited Destroy;
- end;
- Procedure TField.RaiseAccessError(const TypeName: string);
- Var
- E : EDatabaseError;
- begin
- E:=AccessError(TypeName);
- Raise E;
- end;
- function TField.AccessError(const TypeName: string): EDatabaseError;
- begin
- Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
- end;
- procedure TField.Assign(Source: TPersistent);
- begin
- if Source = nil then Clear
- else if Source is TField then begin
- Value := TField(Source).Value;
- end else
- inherited Assign(Source);
- end;
- procedure TField.AssignValue(const AValue: JSValue);
- procedure Error;
- begin
- DatabaseErrorFmt(SFieldValueError, [DisplayName]);
- end;
- begin
- Case GetValueType(AValue) of
- jvtNull : Clear;
- jvtBoolean : AsBoolean:=Boolean(AValue);
- jvtInteger : AsLargeInt:=NativeInt(AValue);
- jvtFloat : AsFloat:=Double(AValue);
- jvtString : AsString:=String(AValue);
- jvtArray : SetAsBytes(TBytes(AValue));
- else
- Error;
- end;
- end;
- procedure TField.Bind(Binding: Boolean);
- begin
- if Binding and (FieldKind=fkLookup) then
- begin
- if ((FLookupDataSet = nil) or (FLookupKeyFields = '') or
- (FLookupResultField = '') or (FKeyFields = '')) then
- DatabaseErrorFmt(SLookupInfoError, [DisplayName]);
- FFields.CheckFieldNames(FKeyFields);
- FLookupDataSet.Open;
- FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
- FLookupDataSet.FieldByName(FLookupResultField);
- if FLookupCache then
- RefreshLookupList;
- end;
- end;
- procedure TField.Change;
- begin
- If Assigned(FOnChange) Then
- FOnChange(Self);
- end;
- procedure TField.CheckInactive;
- begin
- If Assigned(FDataSet) then
- FDataset.CheckInactive;
- end;
- procedure TField.Clear;
- begin
- SetData(Nil);
- end;
- procedure TField.DataChanged;
- begin
- FDataset.DataEvent(deFieldChange,self);
- end;
- procedure TField.FocusControl;
- var
- Field1: TField;
- begin
- Field1 := Self;
- FDataSet.DataEvent(deFocusControl,Field1);
- end;
- function TField.GetAsBoolean: Boolean;
- begin
- raiseAccessError(SBoolean);
- Result:=false;
- end;
- function TField.GetAsBytes: TBytes;
- begin
- raiseAccessError(SBytes);
- Result:=nil;
- end;
- function TField.GetAsDateTime: TDateTime;
- begin
- raiseAccessError(SdateTime);
- Result:=0.0;
- end;
- function TField.GetAsFloat: Double;
- begin
- raiseAccessError(SDateTime);
- Result:=0.0;
- end;
- function TField.GetAsLargeInt: NativeInt;
- begin
- RaiseAccessError(SLargeInt);
- Result:=0;
- end;
- function TField.GetAsLongint: Longint;
- begin
- Result:=GetAsInteger;
- end;
- function TField.GetAsInteger: Longint;
- begin
- RaiseAccessError(SInteger);
- Result:=0;
- end;
- function TField.GetAsJSValue: JSValue;
- begin
- Result:=GetData
- end;
- function TField.GetAsString: string;
- begin
- Result := GetClassDesc
- end;
- function TField.GetOldValue: JSValue;
- var SaveState : TDatasetState;
- begin
- SaveState := FDataset.State;
- try
- FDataset.SetTempState(dsOldValue);
- Result := GetAsJSValue;
- finally
- FDataset.RestoreState(SaveState);
- end;
- end;
- function TField.GetNewValue: JSValue;
- var SaveState : TDatasetState;
- begin
- SaveState := FDataset.State;
- try
- FDataset.SetTempState(dsNewValue);
- Result := GetAsJSValue;
- finally
- FDataset.RestoreState(SaveState);
- end;
- end;
- procedure TField.SetNewValue(const AValue: JSValue);
- var SaveState : TDatasetState;
- begin
- SaveState := FDataset.State;
- try
- FDataset.SetTempState(dsNewValue);
- SetAsJSValue(AValue);
- finally
- FDataset.RestoreState(SaveState);
- end;
- end;
- function TField.GetCurValue: JSValue;
- var SaveState : TDatasetState;
- begin
- SaveState := FDataset.State;
- try
- FDataset.SetTempState(dsCurValue);
- Result := GetAsJSValue;
- finally
- FDataset.RestoreState(SaveState);
- end;
- end;
- function TField.GetCanModify: Boolean;
- begin
- Result:=Not ReadOnly;
- If Result then
- begin
- Result := FieldKind in [fkData, fkInternalCalc];
- if Result then
- begin
- Result:=Assigned(DataSet) and Dataset.Active;
- If Result then
- Result:= DataSet.CanModify;
- end;
- end;
- end;
- function TField.GetClassDesc: String;
- var ClassN : string;
- begin
- ClassN := copy(ClassName,2,pos('Field',ClassName)-2);
- if isNull then
- result := '(' + LowerCase(ClassN) + ')'
- else
- result := '(' + UpperCase(ClassN) + ')';
- end;
- function TField.GetData : JSValue;
- begin
- IF FDataset=Nil then
- DatabaseErrorFmt(SNoDataset,[FieldName]);
- If FValidating then
- result:=FValueBuffer
- else
- Result:=FDataset.GetFieldData(Self);
- end;
- function TField.GetDataSize: Integer;
- begin
- Result:=0;
- end;
- function TField.GetDefaultWidth: Longint;
- begin
- Result:=10;
- end;
- function TField.GetDisplayName : String;
- begin
- If FDisplayLabel<>'' then
- result:=FDisplayLabel
- else
- Result:=FFieldName;
- end;
- function TField.IsDisplayLabelStored: Boolean;
- begin
- Result:=(DisplayLabel<>FieldName);
- end;
- function TField.IsDisplayWidthStored: Boolean;
- begin
- Result:=(FDisplayWidth<>0);
- end;
- function TField.GetLookupList: TLookupList;
- begin
- if not Assigned(FLookupList) then
- FLookupList := TLookupList.Create;
- Result := FLookupList;
- end;
- procedure TField.CalcLookupValue;
- begin
- // MVC: TODO
- // if FLookupCache then
- // Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
- // else if
- if Assigned(FLookupDataSet) and FDataSet.Active then
- Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField)
- else
- Value:=Null;
- end;
- function TField.GetIndex: longint;
- begin
- If Assigned(FDataset) then
- Result:=FDataset.FFieldList.IndexOf(Self)
- else
- Result:=-1;
- end;
- function TField.GetLookup: Boolean;
- begin
- Result := FieldKind = fkLookup;
- end;
- procedure TField.SetAlignment(const AValue: TAlignMent);
- begin
- if FAlignment <> AValue then
- begin
- FAlignment := AValue;
- PropertyChanged(false);
- end;
- end;
- procedure TField.SetIndex(const AValue: Longint);
- begin
- if FFields <> nil then FFields.SetFieldIndex(Self, AValue)
- end;
- function TField.GetIsNull: Boolean;
- begin
- Result:=js.IsNull(GetData);
- end;
- function TField.GetParentComponent: TComponent;
- begin
- Result := DataSet;
- end;
- procedure TField.GetText(var AText: string; ADisplayText: Boolean);
- begin
- AText:=GetAsString;
- end;
- function TField.HasParent: Boolean;
- begin
- HasParent:=True;
- end;
- function TField.IsValidChar(InputChar: Char): Boolean;
- begin
- // FValidChars must be set in Create.
- Result:=CharInset(InputChar,FValidChars);
- end;
- procedure TField.RefreshLookupList;
- var
- tmpActive: Boolean;
- begin
- if not Assigned(FLookupDataSet) or (Length(FLookupKeyfields) = 0)
- or (Length(FLookupresultField) = 0) or (Length(FKeyFields) = 0) then
- Exit;
-
- tmpActive := FLookupDataSet.Active;
- try
- FLookupDataSet.Active := True;
- FFields.CheckFieldNames(FKeyFields);
- FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
- FLookupDataset.FieldByName(FLookupResultField); // I presume that if it doesn't exist it throws exception, and that a field with null value is still valid
- LookupList.Clear; // have to be F-less because we might be creating it here with getter!
- FLookupDataSet.DisableControls;
- try
- FLookupDataSet.First;
- while not FLookupDataSet.Eof do
- begin
- // FLookupList.Add(FLookupDataSet.FieldValues[FLookupKeyfields], FLookupDataSet.FieldValues[FLookupResultField]);
- FLookupDataSet.Next;
- end;
- finally
- FLookupDataSet.EnableControls;
- end;
- finally
- FLookupDataSet.Active := tmpActive;
- end;
- end;
- procedure TField.Notification(AComponent: TComponent; Operation: TOperation);
- begin
- Inherited Notification(AComponent,Operation);
- if (Operation = opRemove) and (AComponent = FLookupDataSet) then
- FLookupDataSet := nil;
- end;
- procedure TField.PropertyChanged(LayoutAffected: Boolean);
- begin
- If (FDataset<>Nil) and (FDataset.Active) then
- If LayoutAffected then
- FDataset.DataEvent(deLayoutChange,0)
- else
- FDataset.DataEvent(deDatasetchange,0);
- end;
- procedure TField.SetAsBytes(const AValue: TBytes);
- begin
- RaiseAccessError(SBytes);
- end;
- procedure TField.SetAsBoolean(AValue: Boolean);
- begin
- RaiseAccessError(SBoolean);
- end;
- procedure TField.SetAsDateTime(AValue: TDateTime);
- begin
- RaiseAccessError(SDateTime);
- end;
- procedure TField.SetAsFloat(AValue: Double);
- begin
- RaiseAccessError(SFloat);
- end;
- procedure TField.SetAsJSValue(const AValue: JSValue);
- begin
- if js.IsNull(AValue) then
- Clear
- else
- try
- SetVarValue(AValue);
- except
- on EVariantError do
- DatabaseErrorFmt(SFieldValueError, [DisplayName]);
- end;
- end;
- procedure TField.SetAsLongint(AValue: Longint);
- begin
- SetAsInteger(AValue);
- end;
- procedure TField.SetAsInteger(AValue: Longint);
- begin
- RaiseAccessError(SInteger);
- end;
- procedure TField.SetAsLargeInt(AValue: NativeInt);
- begin
- RaiseAccessError(SLargeInt);
- end;
- procedure TField.SetAsString(const AValue: string);
- begin
- RaiseAccessError(SString);
- end;
- procedure TField.SetData(Buffer: JSValue);
- begin
- If Not Assigned(FDataset) then
- DatabaseErrorFmt(SNoDataset,[FieldName]);
- FDataSet.SetFieldData(Self,Buffer);
- end;
- procedure TField.SetDataset(AValue: TDataset);
- begin
- {$ifdef dsdebug}
- Writeln ('Setting dataset');
- {$endif}
- If AValue=FDataset then exit;
- If Assigned(FDataset) Then
- begin
- FDataset.CheckInactive;
- FDataset.FFieldList.Remove(Self);
- end;
- If Assigned(AValue) then
- begin
- AValue.CheckInactive;
- AValue.FFieldList.Add(Self);
- end;
- FDataset:=AValue;
- end;
- procedure TField.SetDataType(AValue: TFieldType);
- begin
- FDataType := AValue;
- end;
- procedure TField.SetFieldType(AValue: TFieldType);
- begin
- { empty }
- end;
- procedure TField.SetParentComponent(Value: TComponent);
- begin
- if not (csLoading in ComponentState) then
- DataSet := Value as TDataSet;
- end;
- procedure TField.SetSize(AValue: Integer);
- begin
- CheckInactive;
- CheckTypeSize(AValue);
- FSize:=AValue;
- end;
- procedure TField.SetText(const AValue: string);
- begin
- SetAsString(AValue);
- end;
- procedure TField.SetVarValue(const AValue: JSValue);
- begin
- RaiseAccessError(SJSValue);
- end;
- procedure TField.Validate(Buffer: Pointer);
- begin
- If assigned(OnValidate) Then
- begin
- FValueBuffer:=Buffer;
- FValidating:=True;
- Try
- OnValidate(Self);
- finally
- FValidating:=False;
- end;
- end;
- end;
- class function TField.IsBlob: Boolean;
- begin
- Result:=False;
- end;
- class procedure TField.CheckTypeSize(AValue: Longint);
- begin
- If (AValue<>0) and Not IsBlob Then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
- end;
- // TField private methods
- procedure TField.SetEditText(const AValue: string);
- begin
- if Assigned(OnSetText) then
- OnSetText(Self, AValue)
- else
- SetText(AValue);
- end;
- function TField.GetEditText: String;
- begin
- SetLength(Result, 0);
- if Assigned(OnGetText) then
- OnGetText(Self, Result, False)
- else
- GetText(Result, False);
- end;
- function TField.GetDisplayText: String;
- begin
- SetLength(Result, 0);
- if Assigned(OnGetText) then
- OnGetText(Self, Result, True)
- else
- GetText(Result, True);
- end;
- procedure TField.SetDisplayLabel(const AValue: string);
- begin
- if FDisplayLabel<>AValue then
- begin
- FDisplayLabel:=AValue;
- PropertyChanged(true);
- end;
- end;
- procedure TField.SetDisplayWidth(const AValue: Longint);
- begin
- if FDisplayWidth<>AValue then
- begin
- FDisplayWidth:=AValue;
- PropertyChanged(True);
- end;
- end;
- function TField.GetDisplayWidth: integer;
- begin
- if FDisplayWidth=0 then
- result:=GetDefaultWidth
- else
- result:=FDisplayWidth;
- end;
- procedure TField.SetLookup(const AValue: Boolean);
- const
- ValueToLookupMap: array[Boolean] of TFieldKind = (fkData, fkLookup);
- begin
- FieldKind := ValueToLookupMap[AValue];
- end;
- procedure TField.SetReadOnly(const AValue: Boolean);
- begin
- if (FReadOnly<>AValue) then
- begin
- FReadOnly:=AValue;
- PropertyChanged(True);
- end;
- end;
- procedure TField.SetVisible(const AValue: Boolean);
- begin
- if FVisible<>AValue then
- begin
- FVisible:=AValue;
- PropertyChanged(True);
- end;
- end;
- { ---------------------------------------------------------------------
- TStringField
- ---------------------------------------------------------------------}
- constructor TStringField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftString);
- FFixedChar := False;
- FTransliterate := False;
- FSize := 20;
- end;
- procedure TStringField.SetFieldType(AValue: TFieldType);
- begin
- if AValue in [ftString, ftFixedChar] then
- SetDataType(AValue);
- end;
- class procedure TStringField.CheckTypeSize(AValue: Longint);
- begin
- // A size of 0 is allowed, since for example Firebird allows
- // a query like: 'select '' as fieldname from table' which
- // results in a string with size 0.
- If (AValue<0) Then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue])
- end;
- function TStringField.GetAsBoolean: Boolean;
- var S : String;
- begin
- S:=GetAsString;
- result := (Length(S)>0) and (Upcase(S[1]) in ['T',YesNoChars[True]]);
- end;
- function TStringField.GetAsDateTime: TDateTime;
- begin
- Result:=StrToDateTime(GetAsString);
- end;
- function TStringField.GetAsFloat: Double;
- begin
- Result:=StrToFloat(GetAsString);
- end;
- function TStringField.GetAsInteger: Longint;
- begin
- Result:=StrToInt(GetAsString);
- end;
- function TStringField.GetAsLargeInt: NativeInt;
- begin
- Result:=StrToInt64(GetAsString);
- end;
- function TStringField.GetAsString: String;
- Var
- V : JSValue;
- begin
- V:=GetData;
- if isString(V) then
- Result := String(V)
- else
- Result:='';
- end;
- function TStringField.GetAsJSValue: JSValue;
- begin
- Result:=GetData
- end;
- function TStringField.GetDefaultWidth: Longint;
- begin
- result:=Size;
- end;
- procedure TStringField.GetText(var AText: string; ADisplayText: Boolean);
- begin
- AText:=GetAsString;
- end;
- procedure TStringField.SetAsBoolean(AValue: Boolean);
- begin
- If AValue Then
- SetAsString('T')
- else
- SetAsString('F');
- end;
- procedure TStringField.SetAsDateTime(AValue: TDateTime);
- begin
- SetAsString(DateTimeToStr(AValue));
- end;
- procedure TStringField.SetAsFloat(AValue: Double);
- begin
- SetAsString(FloatToStr(AValue));
- end;
- procedure TStringField.SetAsInteger(AValue: Longint);
- begin
- SetAsString(IntToStr(AValue));
- end;
- procedure TStringField.SetAsLargeInt(AValue: NativeInt);
- begin
- SetAsString(IntToStr(AValue));
- end;
- procedure TStringField.SetAsString(const AValue: String);
- begin
- SetData(AValue);
- end;
- procedure TStringField.SetVarValue(const AValue: JSValue);
- begin
- if isString(AVAlue) then
- SetAsString(String(AValue))
- else
- RaiseAccessError(SFieldValueError);
- end;
- { ---------------------------------------------------------------------
- TNumericField
- ---------------------------------------------------------------------}
- constructor TNumericField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- AlignMent:=taRightJustify;
- end;
- class procedure TNumericField.CheckTypeSize(AValue: Longint);
- begin
- // This procedure is only added because some TDataset descendents have the
- // but that they set the Size property as if it is the DataSize property.
- // To avoid problems with those descendents, allow values <= 16.
- If (AValue>16) Then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
- end;
- procedure TNumericField.RangeError(AValue, Min, Max: Double);
- begin
- DatabaseErrorFmt(SRangeError,[AValue,Min,Max,FieldName]);
- end;
- procedure TNumericField.SetDisplayFormat(const AValue: string);
- begin
- If FDisplayFormat<>AValue then
- begin
- FDisplayFormat:=AValue;
- PropertyChanged(True);
- end;
- end;
- procedure TNumericField.SetEditFormat(const AValue: string);
- begin
- If FEditFormat<>AValue then
- begin
- FEditFormat:=AValue;
- PropertyChanged(True);
- end;
- end;
- function TNumericField.GetAsBoolean: Boolean;
- begin
- Result:=GetAsInteger<>0;
- end;
- procedure TNumericField.SetAsBoolean(AValue: Boolean);
- begin
- SetAsInteger(ord(AValue));
- end;
- { ---------------------------------------------------------------------
- TIntegerField
- ---------------------------------------------------------------------}
- constructor TIntegerField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftInteger);
- FMinRange:=Low(LongInt);
- FMaxRange:=High(LongInt);
- // MVC : Todo
- // FValidchars:=['+','-','0'..'9'];
- end;
- function TIntegerField.GetAsFloat: Double;
- begin
- Result:=GetAsInteger;
- end;
- function TIntegerField.GetAsLargeInt: NativeInt;
- begin
- Result:=GetAsInteger;
- end;
- function TIntegerField.GetAsInteger: Longint;
- begin
- If Not GetValue(Result) then
- Result:=0;
- end;
- function TIntegerField.GetAsJSValue: JSValue;
- var L : Longint;
- begin
- If GetValue(L) then
- Result:=L
- else
- Result:=Null;
- end;
- function TIntegerField.GetAsString: string;
- var L : Longint;
- begin
- If GetValue(L) then
- Result:=IntTostr(L)
- else
- Result:='';
- end;
- procedure TIntegerField.GetText(var AText: string; ADisplayText: Boolean);
- var l : longint;
- fmt : string;
- begin
- Atext:='';
- If Not GetValue(l) then exit;
- If ADisplayText or (FEditFormat='') then
- fmt:=FDisplayFormat
- else
- fmt:=FEditFormat;
- If length(fmt)<>0 then
- AText:=FormatFloat(fmt,L)
- else
- Str(L,AText);
- end;
- function TIntegerField.GetValue(var AValue: Longint): Boolean;
- var
- V : JSValue;
- begin
- V:=GetData;
- Result:=isInteger(V);
- if Result then
- AValue:=Longint(V);
- end;
- procedure TIntegerField.SetAsLargeInt(AValue: NativeInt);
- begin
- if (AValue>=FMinRange) and (AValue<=FMaxRange) then
- SetAsInteger(AValue)
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- procedure TIntegerField.SetAsFloat(AValue: Double);
- begin
- SetAsInteger(Round(AValue));
- end;
- procedure TIntegerField.SetAsInteger(AValue: Longint);
- begin
- If CheckRange(AValue) then
- SetData(AValue)
- else
- if (FMinValue<>0) or (FMaxValue<>0) then
- RangeError(AValue,FMinValue,FMaxValue)
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- procedure TIntegerField.SetVarValue(const AValue: JSValue);
- begin
- if IsInteger(aValue) then
- SetAsInteger(Integer(AValue))
- else
- RaiseAccessError(SInteger);
- end;
- procedure TIntegerField.SetAsString(const AValue: string);
- var L,Code : longint;
- begin
- If length(AValue)=0 then
- Clear
- else
- begin
- Val(AValue,L,Code);
- If Code=0 then
- SetAsInteger(L)
- else
- DatabaseErrorFmt(SNotAnInteger,[AValue]);
- end;
- end;
- Function TIntegerField.CheckRange(AValue : longint) : Boolean;
- begin
- if (FMinValue<>0) or (FMaxValue<>0) then
- Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
- else
- Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
- end;
- Procedure TIntegerField.SetMaxValue (AValue : longint);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMaxValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- Procedure TIntegerField.SetMinValue (AValue : longint);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMinValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- { ---------------------------------------------------------------------
- TLargeintField
- ---------------------------------------------------------------------}
- constructor TLargeintField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftLargeint);
- FMinRange:=Low(NativeInt);
- FMaxRange:=High(NativeInt);
- // MVC : Todo
- // FValidchars:=['+','-','0'..'9'];
- end;
- function TLargeintField.GetAsFloat: Double;
- begin
- Result:=GetAsLargeInt;
- end;
- function TLargeintField.GetAsLargeInt: NativeInt;
- begin
- If Not GetValue(Result) then
- Result:=0;
- end;
- function TLargeIntField.GetAsJSValue: JSValue;
- var L : NativeInt;
- begin
- If GetValue(L) then
- Result:=L
- else
- Result:=Null;
- end;
- function TLargeintField.GetAsInteger: Longint;
- begin
- Result:=GetAsLargeInt;
- end;
- function TLargeintField.GetAsString: string;
- var L : NativeInt;
- begin
- If GetValue(L) then
- Result:=IntTostr(L)
- else
- Result:='';
- end;
- procedure TLargeintField.GetText(var AText: string; ADisplayText: Boolean);
- var l : NativeInt;
- fmt : string;
- begin
- Atext:='';
- If Not GetValue(l) then exit;
- If ADisplayText or (FEditFormat='') then
- fmt:=FDisplayFormat
- else
- fmt:=FEditFormat;
- If length(fmt)<>0 then
- AText:=FormatFloat(fmt,L)
- else
- Str(L,AText);
- end;
- function TLargeintField.GetValue(var AValue: NativeInt): Boolean;
- var
- P : JSValue;
- begin
- P:=GetData;
- Result:=isInteger(P);
- if Result then
- AValue:=NativeInt(P);
- end;
- procedure TLargeintField.SetAsFloat(AValue: Double);
- begin
- SetAsLargeInt(Round(AValue));
- end;
- procedure TLargeintField.SetAsLargeInt(AValue: NativeInt);
- begin
- If CheckRange(AValue) then
- SetData(AValue)
- else
- RangeError(AValue,FMinValue,FMaxValue);
- end;
- procedure TLargeintField.SetAsInteger(AValue: Longint);
- begin
- SetAsLargeInt(AValue);
- end;
- procedure TLargeintField.SetAsString(const AValue: string);
- var L : NativeInt;
- code : Longint;
- begin
- If length(AValue)=0 then
- Clear
- else
- begin
- Val(AValue,L,Code);
- If Code=0 then
- SetAsLargeInt(L)
- else
- DatabaseErrorFmt(SNotAnInteger,[AValue]);
- end;
- end;
- procedure TLargeintField.SetVarValue(const AValue: JSValue);
- begin
- if IsInteger(Avalue) then
- SetAsLargeInt(NativeInt(AValue))
- else
- RaiseAccessError(SLargeInt);
- end;
- Function TLargeintField.CheckRange(AValue : NativeInt) : Boolean;
- begin
- if (FMinValue<>0) or (FMaxValue<>0) then
- Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
- else
- Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
- end;
- Procedure TLargeintField.SetMaxValue (AValue : NativeInt);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMaxValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- Procedure TLargeintField.SetMinValue (AValue : NativeInt);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMinValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- { TAutoIncField }
- constructor TAutoIncField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOWner);
- SetDataType(ftAutoInc);
- end;
- Procedure TAutoIncField.SetAsInteger(AValue: Longint);
- begin
- // Some databases allows insertion of explicit values into identity columns
- // (some of them also allows (some not) updating identity columns)
- // So allow it at client side and leave check for server side
- //if not(FDataSet.State in [dsFilter,dsSetKey,dsInsert]) then
- // DataBaseError(SCantSetAutoIncFields);
- inherited;
- end;
- { TFloatField }
- procedure TFloatField.SetCurrency(const AValue: Boolean);
- begin
- if FCurrency=AValue then exit;
- FCurrency:=AValue;
- end;
- procedure TFloatField.SetPrecision(const AValue: Longint);
- begin
- if (AValue = -1) or (AValue > 1) then
- FPrecision := AValue
- else
- FPrecision := 2;
- end;
- function TFloatField.GetAsFloat: Double;
- Var
- P : JSValue;
- begin
- P:=GetData;
- If IsNumber(P) then
- Result:=Double(P)
- else
- Result:=0.0;
- end;
- function TFloatField.GetAsJSValue: JSValue;
- var
- P : JSValue;
- begin
- P:=GetData;
- if IsNumber(P) then
- Result:=P
- else
- Result:=Null;
- end;
- function TFloatField.GetAsLargeInt: NativeInt;
- begin
- Result:=Round(GetAsFloat);
- end;
- function TFloatField.GetAsInteger: Longint;
- begin
- Result:=Round(GetAsFloat);
- end;
- function TFloatField.GetAsString: string;
- var
- P : JSValue;
- begin
- P:=GetData;
- if IsNumber(P) then
- Result:=FloatToStr(Double(P))
- else
- Result:='';
- end;
- procedure TFloatField.GetText(var AText: string; ADisplayText: Boolean);
- Var
- fmt : string;
- E : Double;
- Digits : integer;
- ff: TFloatFormat;
- P : JSValue;
- begin
- AText:='';
- P:=GetData;
- if Not IsNumber(P) then
- exit;
- E:=Double(P);
- If ADisplayText or (Length(FEditFormat) = 0) Then
- Fmt:=FDisplayFormat
- else
- Fmt:=FEditFormat;
-
- Digits := 0;
- if not FCurrency then
- ff := ffGeneral
- else
- begin
- Digits := 2;
- ff := ffFixed;
- end;
- If fmt<>'' then
- AText:=FormatFloat(fmt,E)
- else
- AText:=FloatToStrF(E,ff,FPrecision,Digits);
- end;
- procedure TFloatField.SetAsFloat(AValue: Double);
- begin
- If CheckRange(AValue) then
- SetData(AValue)
- else
- RangeError(AValue,FMinValue,FMaxValue);
- end;
- procedure TFloatField.SetAsLargeInt(AValue: NativeInt);
- begin
- SetAsFloat(AValue);
- end;
- procedure TFloatField.SetAsInteger(AValue: Longint);
- begin
- SetAsFloat(AValue);
- end;
- procedure TFloatField.SetAsString(const AValue: string);
- var f : Double;
- begin
- If (AValue='') then
- Clear
- else
- begin
- If not TryStrToFloat(AValue,F) then
- DatabaseErrorFmt(SNotAFloat, [AValue]);
- SetAsFloat(f);
- end;
- end;
- procedure TFloatField.SetVarValue(const AValue: JSValue);
- begin
- if IsNumber(aValue) then
- SetAsFloat(Double(AValue))
- else
- RaiseAccessError('Float');
- end;
- constructor TFloatField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftFloat);
- FPrecision:=15;
- // MVC
- // FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
- end;
- Function TFloatField.CheckRange(AValue : Double) : Boolean;
- begin
- If (FMinValue<>0) or (FMaxValue<>0) then
- Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
- else
- Result:=True;
- end;
- { TBooleanField }
- function TBooleanField.GetAsBoolean: Boolean;
- var
- P : JSValue;
- begin
- P:=GetData;
- if isBoolean(P) then
- Result:=Boolean(P)
- else
- Result:=False;
- end;
- function TBooleanField.GetAsJSValue: JSValue;
- var
- P : JSValue;
- begin
- P:=GetData;
- if isBoolean(P) then
- Result:=Boolean(P)
- else
- Result:=Null;
- end;
- function TBooleanField.GetAsString: string;
- var
- P : JSValue;
- begin
- P:=GetData;
- if isBoolean(P) then
- Result:=FDisplays[False,Boolean(P)]
- else
- result:='';
- end;
- function TBooleanField.GetDefaultWidth: Longint;
- begin
- Result:=Length(FDisplays[false,false]);
- If Result<Length(FDisplays[false,True]) then
- Result:=Length(FDisplays[false,True]);
- end;
- function TBooleanField.GetAsInteger: Longint;
- begin
- Result := ord(GetAsBoolean);
- end;
- procedure TBooleanField.SetAsInteger(AValue: Longint);
- begin
- SetAsBoolean(AValue<>0);
- end;
- procedure TBooleanField.SetAsBoolean(AValue: Boolean);
- begin
- SetData(AValue);
- end;
- procedure TBooleanField.SetAsString(const AValue: string);
- var Temp : string;
- begin
- Temp:=UpperCase(AValue);
- if Temp='' then
- Clear
- else if pos(Temp, FDisplays[True,True])=1 then
- SetAsBoolean(True)
- else if pos(Temp, FDisplays[True,False])=1 then
- SetAsBoolean(False)
- else
- DatabaseErrorFmt(SNotABoolean,[AValue]);
- end;
- procedure TBooleanField.SetVarValue(const AValue: JSValue);
- begin
- if isBoolean(aValue) then
- SetAsBoolean(Boolean(AValue))
- else if isNumber(aValue) then
- SetAsBoolean(Double(AValue)<>0)
- end;
- constructor TBooleanField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftBoolean);
- DisplayValues:='True;False';
- end;
- Procedure TBooleanField.SetDisplayValues(const AValue : String);
- var I : longint;
- begin
- If FDisplayValues<>AValue then
- begin
- I:=Pos(';',AValue);
- If (I<2) or (I=Length(AValue)) then
- DatabaseErrorFmt(SInvalidDisplayValues,[AValue]);
- FdisplayValues:=AValue;
- // Store display values and their uppercase equivalents;
- FDisplays[False,True]:=Copy(AValue,1,I-1);
- FDisplays[True,True]:=UpperCase(FDisplays[False,True]);
- FDisplays[False,False]:=Copy(AValue,I+1,Length(AValue)-i);
- FDisplays[True,False]:=UpperCase(FDisplays[False,False]);
- PropertyChanged(True);
- end;
- end;
- { TDateTimeField }
- procedure TDateTimeField.SetDisplayFormat(const AValue: string);
- begin
- if FDisplayFormat<>AValue then begin
- FDisplayFormat:=AValue;
- PropertyChanged(True);
- end;
- end;
- function TDateTimeField.ConvertToDateTime(aValue: JSValue; aRaiseError: Boolean): TDateTime;
- begin
- if Assigned(Dataset) then
- Result:=Dataset.ConvertToDateTime(aValue,aRaiseError)
- else
- Result:=TDataset.DefaultConvertToDateTime(aValue,aRaiseError);
- end;
- function TDateTimeField.DateTimeToNativeDateTime(aValue: TDateTime): JSValue;
- begin
- if Assigned(Dataset) then
- Result:=Dataset.ConvertDateTimeToNative(aValue)
- else
- Result:=TDataset.DefaultConvertDateTimeToNative(aValue);
- end;
- function TDateTimeField.GetAsDateTime: TDateTime;
- begin
- Result:=ConvertToDateTime(GetData,False);
- end;
- procedure TDateTimeField.SetVarValue(const AValue: JSValue);
- begin
- SetAsDateTime(ConvertToDateTime(aValue,True));
- end;
- function TDateTimeField.GetAsJSValue: JSValue;
- begin
- Result:=GetData;
- if Not isString(Result) then
- Result:=Null;
- end;
- function TDateTimeField.GetDataSize: Integer;
- begin
- Result:=inherited GetDataSize;
- end;
- function TDateTimeField.GetAsFloat: Double;
- begin
- Result:=GetAsdateTime;
- end;
- function TDateTimeField.GetAsString: string;
- begin
- GetText(Result,False);
- end;
- Procedure TDateTimeField.GetText(var AText: string; ADisplayText: Boolean);
- var
- R : TDateTime;
- F : String;
- begin
- R:=ConvertToDateTime(GetData,false);
- If (R=0) then
- AText:=''
- else
- begin
- If (ADisplayText) and (Length(FDisplayFormat)<>0) then
- F:=FDisplayFormat
- else
- Case DataType of
- ftTime : F:=LongTimeFormat;
- ftDate : F:=ShortDateFormat;
- else
- F:='c'
- end;
- AText:=FormatDateTime(F,R);
- end;
- end;
- procedure TDateTimeField.SetAsDateTime(AValue: TDateTime);
- begin
- SetData(DateTimeToNativeDateTime(aValue));
- end;
- procedure TDateTimeField.SetAsFloat(AValue: Double);
- begin
- SetAsDateTime(AValue);
- end;
- procedure TDateTimeField.SetAsString(const AValue: string);
- var R : TDateTime;
- begin
- if AValue<>'' then
- begin
- R:=StrToDateTime(AValue);
- SetData(DateTimeToNativeDateTime(R));
- end
- else
- SetData(Null);
- end;
- constructor TDateTimeField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftDateTime);
- end;
- { TDateField }
- constructor TDateField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftDate);
- end;
- { TTimeField }
- constructor TTimeField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftTime);
- end;
- procedure TTimeField.SetAsString(const AValue: string);
- var
- R : TDateTime;
- begin
- if AValue<>'' then
- begin
- R:=StrToTime(AValue);
- SetData(DateTimeToNativeDateTime(R));
- end
- else
- SetData(Null);
- end;
- { TBinaryField }
- class procedure TBinaryField.CheckTypeSize(AValue: Longint);
- begin
- // Just check for really invalid stuff; actual size is
- // dependent on the record...
- If AValue<1 then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
- end;
- Function TBinaryField.BlobToBytes(aValue : JSValue) : TBytes;
- begin
- if Assigned(Dataset) then
- Result:=DataSet.BlobDataToBytes(aValue)
- else
- Result:=TDataSet.DefaultBlobDataToBytes(aValue)
- end;
- Function TBinaryField.BytesToBlob(aValue : TBytes) : JSValue;
- begin
- if Assigned(Dataset) then
- Result:=DataSet.BytesToBlobData(aValue)
- else
- Result:=TDataSet.DefaultBytesToBlobData(aValue)
- end;
- function TBinaryField.GetAsString: string;
- var
- V : JSValue;
- S : TBytes;
- I : Integer;
- begin
- Result := '';
- V:=GetData;
- if V<>Null then
- begin
- S:=BlobToBytes(V);
- For I:=0 to Length(S) do
- TJSString(Result).Concat(TJSString.fromCharCode(S[I]));
- end;
- end;
- function TBinaryField.GetAsJSValue: JSValue;
- begin
- Result:=GetData;
- end;
- function TBinaryField.GetValue(var AValue: TBytes): Boolean;
- var
- V : JSValue;
- begin
- V:=GetData;
- Result:=(V<>Null);
- if Result then
- AValue:=BlobToBytes(V)
- else
- SetLength(AValue,0);
- end;
- procedure TBinaryField.SetAsString(const AValue: string);
- var
- B : TBytes;
- i : Integer;
- begin
- SetLength(B, Length(aValue));
- For I:=1 to Length(aValue) do
- B[i-1]:=Ord(aValue[i]);
- SetAsBytes(B);
- end;
- procedure TBinaryField.SetVarValue(const AValue: JSValue);
- var
- B: TBytes;
- I,Len: integer;
- begin
- if IsArray(AValue) then
- begin
- Len:=Length(TJSValueDynArray(AValue));
- SetLength(B, Len);
- For I:=1 to Len-1 do
- B[i]:=TBytes(AValue)[i];
- SetAsBytes(B);
- end
- else if IsString(AValue) then
- SetAsString(String(AValue))
- else
- RaiseAccessError('Blob');
- end;
- constructor TBinaryField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- end;
- { TBlobField }
- constructor TBlobField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftBlob);
- end;
- procedure TBlobField.Clear;
- begin
- SetData(Null);
- end;
- (*
- function TBlobField.GetBlobType: TBlobType;
- begin
- Result:=ftBlob;
- end;
- procedure TBlobField.SetBlobType(AValue: TBlobType);
- begin
- SetFieldType(TFieldType(AValue));
- end;
- *)
- class procedure TBlobField.CheckTypeSize(AValue: Longint);
- begin
- If AValue<0 then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
- end;
- function TBlobField.GetBlobSize: Longint;
- var
- B : TBytes;
- begin
- B:=GetAsBytes;
- Result:=Length(B);
- end;
- function TBlobField.GetIsNull: Boolean;
- begin
- if Not Modified then
- Result:= inherited GetIsNull
- else
- Result:=GetBlobSize=0;
- end;
- procedure TBlobField.GetText(var AText: string; ADisplayText: Boolean);
- begin
- AText := inherited GetAsString;
- end;
- class function TBlobField.IsBlob: Boolean;
- begin
- Result:=True;
- end;
- procedure TBlobField.SetFieldType(AValue: TFieldType);
- begin
- if AValue in ftBlobTypes then
- SetDataType(AValue);
- end;
- { TMemoField }
- constructor TMemoField.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- SetDataType(ftMemo);
- end;
- { TVariantField }
- constructor TVariantField.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- SetDataType(ftVariant);
- end;
- class procedure TVariantField.CheckTypeSize(aValue: Integer);
- begin
- { empty }
- end;
- function TVariantField.GetAsBoolean: Boolean;
- begin
- Result :=GetAsJSValue=True;
- end;
- function TVariantField.GetAsDateTime: TDateTime;
- Var
- V : JSValue;
- begin
- V:=GetData;
- if Assigned(Dataset) then
- Result:=Dataset.ConvertToDateTime(V,True)
- else
- Result:=TDataset.DefaultConvertToDateTime(V,True)
- end;
- function TVariantField.GetAsFloat: Double;
- Var
- V : JSValue;
- begin
- V:=GetData;
- if isNumber(V) then
- Result:=Double(V)
- else if isString(V) then
- Result:=parsefloat(String(V))
- else
- RaiseAccessError('Variant');
- end;
- function TVariantField.GetAsInteger: Longint;
- Var
- V : JSValue;
- begin
- V:=GetData;
- if isInteger(V) then
- Result:=Integer(V)
- else if isString(V) then
- Result:=parseInt(String(V))
- else
- RaiseAccessError('Variant');
- end;
- function TVariantField.GetAsString: string;
- Var
- V : JSValue;
- begin
- V:=GetData;
- if isInteger(V) then
- Result:=IntToStr(Integer(V))
- else if isNumber(V) then
- Result:=FloatToStr(Double(V))
- else if isString(V) then
- Result:=String(V)
- else
- RaiseAccessError('Variant');
- end;
- function TVariantField.GetAsJSValue: JSValue;
- begin
- Result:=GetData;
- end;
- procedure TVariantField.SetAsBoolean(aValue: Boolean);
- begin
- SetVarValue(aValue);
- end;
- procedure TVariantField.SetAsDateTime(aValue: TDateTime);
- begin
- SetVarValue(aValue);
- end;
- procedure TVariantField.SetAsFloat(aValue: Double);
- begin
- SetVarValue(aValue);
- end;
- procedure TVariantField.SetAsInteger(AValue: Longint);
- begin
- SetVarValue(aValue);
- end;
- procedure TVariantField.SetAsString(const aValue: string);
- begin
- SetVarValue(aValue);
- end;
- procedure TVariantField.SetVarValue(const aValue: JSValue);
- begin
- SetData(aValue);
- end;
- { TFieldsEnumerator }
- function TFieldsEnumerator.GetCurrent: TField;
- begin
- Result := FFields[FPosition];
- end;
- constructor TFieldsEnumerator.Create(AFields: TFields);
- begin
- inherited Create;
- FFields := AFields;
- FPosition := -1;
- end;
- function TFieldsEnumerator.MoveNext: Boolean;
- begin
- inc(FPosition);
- Result := FPosition < FFields.Count;
- end;
- { TFields }
- constructor TFields.Create(ADataset: TDataset);
- begin
- FDataSet:=ADataset;
- FFieldList:=TFpList.Create;
- FValidFieldKinds:=[fkData..fkInternalcalc];
- end;
- destructor TFields.Destroy;
- begin
- if Assigned(FFieldList) then
- Clear;
- FreeAndNil(FFieldList);
- inherited Destroy;
- end;
- procedure TFields.ClearFieldDefs;
- Var
- i : Integer;
- begin
- For I:=0 to Count-1 do
- Fields[i].FFieldDef:=Nil;
- end;
- procedure TFields.Changed;
- begin
- // Removed FDataSet.Active check, needed for Persistent fields (see bug ID 30954)
- if (FDataSet <> nil) and not (csDestroying in FDataSet.ComponentState) then
- FDataSet.DataEvent(deFieldListChange, 0);
- If Assigned(FOnChange) then
- FOnChange(Self);
- end;
- procedure TFields.CheckfieldKind(Fieldkind: TFieldKind; Field: TField);
- begin
- If Not (FieldKind in ValidFieldKinds) Then
- DatabaseErrorFmt(SInvalidFieldKind,[Field.FieldName]);
- end;
- function TFields.GetCount: Longint;
- begin
- Result:=FFieldList.Count;
- end;
- function TFields.GetField(Index: Integer): TField;
- begin
- Result:=Tfield(FFieldList[Index]);
- end;
- procedure TFields.SetField(Index: Integer; Value: TField);
- begin
- Fields[Index].Assign(Value);
- end;
- procedure TFields.SetFieldIndex(Field: TField; Value: Integer);
- var Old : Longint;
- begin
- Old := FFieldList.indexOf(Field);
- If Old=-1 then
- Exit;
- // Check value
- If Value<0 Then Value:=0;
- If Value>=Count then Value:=Count-1;
- If Value<>Old then
- begin
- FFieldList.Delete(Old);
- FFieldList.Insert(Value,Field);
- Field.PropertyChanged(True);
- Changed;
- end;
- end;
- procedure TFields.Add(Field: TField);
- begin
- CheckFieldName(Field.FieldName);
- FFieldList.Add(Field);
- Field.FFields:=Self;
- Changed;
- end;
- procedure TFields.CheckFieldName(const Value: String);
- begin
- If FindField(Value)<>Nil then
- DataBaseErrorFmt(SDuplicateFieldName,[Value],FDataset);
- end;
- procedure TFields.CheckFieldNames(const Value: String);
- var
- N: String;
- StrPos: Integer;
- begin
- if Value = '' then
- Exit;
- StrPos := 1;
- repeat
- N := ExtractFieldName(Value, StrPos);
- // Will raise an error if no such field...
- FieldByName(N);
- until StrPos > Length(Value);
- end;
- procedure TFields.Clear;
- var
- AField: TField;
- begin
- while FFieldList.Count > 0 do
- begin
- AField := TField(FFieldList.Last);
- AField.FDataSet := Nil;
- AField.Free;
- FFieldList.Delete(FFieldList.Count - 1);
- end;
- Changed;
- end;
- function TFields.FindField(const Value: String): TField;
- var S : String;
- I : longint;
- begin
- S:=UpperCase(Value);
- For I:=0 To FFieldList.Count-1 do
- begin
- Result:=TField(FFieldList[I]);
- if S=UpperCase(Result.FieldName) then
- begin
- {$ifdef dsdebug}
- Writeln ('Found field ',Value);
- {$endif}
- Exit;
- end;
- end;
- Result:=Nil;
- end;
- function TFields.FieldByName(const Value: String): TField;
- begin
- Result:=FindField(Value);
- If result=Nil then
- DatabaseErrorFmt(SFieldNotFound,[Value],FDataset);
- end;
- function TFields.FieldByNumber(FieldNo: Integer): TField;
- var i : Longint;
- begin
- For I:=0 to FFieldList.Count-1 do
- begin
- Result:=TField(FFieldList[I]);
- if FieldNo=Result.FieldNo then
- Exit;
- end;
- Result:=Nil;
- end;
- function TFields.GetEnumerator: TFieldsEnumerator;
- begin
- Result:=TFieldsEnumerator.Create(Self);
- end;
- procedure TFields.GetFieldNames(Values: TStrings);
- var i : longint;
- begin
- Values.Clear;
- For I:=0 to FFieldList.Count-1 do
- Values.Add(Tfield(FFieldList[I]).FieldName);
- end;
- function TFields.IndexOf(Field: TField): Longint;
- begin
- Result:=FFieldList.IndexOf(Field);
- end;
- procedure TFields.Remove(Value : TField);
- begin
- FFieldList.Remove(Value);
- Value.FFields := nil;
- Changed;
- end;
- { ---------------------------------------------------------------------
- TDatalink
- ---------------------------------------------------------------------}
- Constructor TDataLink.Create;
- begin
- Inherited Create;
- FBufferCount:=1;
- FFirstRecord := 0;
- FDataSource := nil;
- FDatasourceFixed:=False;
- end;
- Destructor TDataLink.Destroy;
- begin
- Factive:=False;
- FEditing:=False;
- FDataSourceFixed:=False;
- DataSource:=Nil;
- Inherited Destroy;
- end;
- Procedure TDataLink.ActiveChanged;
- begin
- FFirstRecord := 0;
- end;
- Procedure TDataLink.CheckActiveAndEditing;
- Var
- B : Boolean;
- begin
- B:=Assigned(DataSource) and Not (DataSource.State in [dsInactive,dsOpening]);
- If B<>FActive then
- begin
- FActive:=B;
- ActiveChanged;
- end;
- B:=Assigned(DataSource) and (DataSource.State in dsEditModes) and Not FReadOnly;
- If B<>FEditing Then
- begin
- FEditing:=B;
- EditingChanged;
- end;
- end;
- Procedure TDataLink.CheckBrowseMode;
- begin
- end;
- Function TDataLink.CalcFirstRecord(Index : Integer) : Integer;
- begin
- if DataSource.DataSet.FActiveRecord > FFirstRecord + Index + FBufferCount - 1 then
- Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index + FBufferCount - 1)
- else if DataSource.DataSet.FActiveRecord < FFirstRecord + Index then
- Result := DataSource.DataSet.FActiveRecord - (FFirstRecord + Index)
- else Result := 0;
-
- Inc(FFirstRecord, Index + Result);
- end;
- Procedure TDataLink.CalcRange;
- var
- aMax, aMin: integer;
- begin
- aMin:= DataSet.FActiveRecord - FBufferCount + 1;
- If aMin < 0 Then aMin:= 0;
- aMax:= Dataset.FBufferCount - FBufferCount;
- If aMax < 0 then aMax:= 0;
- If aMax>DataSet.FActiveRecord Then aMax:=DataSet.FActiveRecord;
- If FFirstRecord < aMin Then FFirstRecord:= aMin;
- If FFirstrecord > aMax Then FFirstRecord:= aMax;
- If (FfirstRecord<>0) And
- (DataSet.FActiveRecord - FFirstRecord < FBufferCount -1) Then
- Dec(FFirstRecord, 1);
- end;
- Procedure TDataLink.DataEvent(Event: TDataEvent; Info: JSValue);
- begin
- Case Event of
- deFieldChange, deRecordChange:
- If Not FUpdatingRecord then
- RecordChanged(TField(Info));
- deDataSetChange: begin
- SetActive(DataSource.DataSet.Active);
- CalcRange;
- CalcFirstRecord(Integer(Info));
- DatasetChanged;
- end;
- deDataSetScroll: DatasetScrolled(CalcFirstRecord(Integer(Info)));
- deLayoutChange: begin
- CalcFirstRecord(Integer(Info));
- LayoutChanged;
- end;
- deUpdateRecord: UpdateRecord;
- deUpdateState: CheckActiveAndEditing;
- deCheckBrowseMode: CheckBrowseMode;
- deFocusControl:
- FocusControl(Info);
- end;
- end;
- Procedure TDataLink.DataSetChanged;
- begin
- RecordChanged(Nil);
- end;
- Procedure TDataLink.DataSetScrolled(Distance: Integer);
- begin
- DataSetChanged;
- end;
- Procedure TDataLink.EditingChanged;
- begin
- end;
- Procedure TDataLink.FocusControl(Field: JSValue);
- begin
- end;
- Function TDataLink.GetActiveRecord: Integer;
- begin
- Result:=Dataset.FActiveRecord - FFirstRecord;
- end;
- Function TDatalink.GetDataSet : TDataset;
- begin
- If Assigned(Datasource) then
- Result:=DataSource.DataSet
- else
- Result:=Nil;
- end;
- Function TDataLink.GetBOF: Boolean;
- begin
- Result:=DataSet.BOF
- end;
- Function TDataLink.GetBufferCount: Integer;
- begin
- Result:=FBufferCount;
- end;
- Function TDataLink.GetEOF: Boolean;
- begin
- Result:=DataSet.EOF
- end;
- Function TDataLink.GetRecordCount: Integer;
- begin
- Result:=Dataset.FRecordCount;
- If Result>BufferCount then
- Result:=BufferCount;
- end;
- Procedure TDataLink.LayoutChanged;
- begin
- DataSetChanged;
- end;
- Function TDataLink.MoveBy(Distance: Integer): Integer;
- begin
- Result:=DataSet.MoveBy(Distance);
- end;
- Procedure TDataLink.RecordChanged(Field: TField);
- begin
- end;
- Procedure TDataLink.SetActiveRecord(Value: Integer);
- begin
- {$ifdef dsdebug}
- Writeln('Datalink. Setting active record to ',Value,' with firstrecord ',ffirstrecord);
- {$endif}
- Dataset.FActiveRecord:=Value + FFirstRecord;
- end;
- Procedure TDataLink.SetBufferCount(Value: Integer);
- begin
- If FBufferCount<>Value then
- begin
- FBufferCount:=Value;
- if Active then begin
- DataSet.RecalcBufListSize;
- CalcRange;
- end;
- end;
- end;
- procedure TDataLink.SetActive(AActive: Boolean);
- begin
- if Active <> AActive then
- begin
- FActive := AActive;
- // !!!: Set internal state
- ActiveChanged;
- end;
- end;
- Procedure TDataLink.SetDataSource(Value : TDatasource);
- begin
- if FDataSource = Value then
- Exit;
- if not FDataSourceFixed then
- begin
- if Assigned(DataSource) then
- Begin
- DataSource.UnregisterDatalink(Self);
- FDataSource := nil;
- CheckActiveAndEditing;
- End;
- FDataSource := Value;
- if Assigned(DataSource) then
- begin
- DataSource.RegisterDatalink(Self);
- CheckActiveAndEditing;
- End;
- end;
- end;
- Procedure TDatalink.SetReadOnly(Value : Boolean);
- begin
- If FReadOnly<>Value then
- begin
- FReadOnly:=Value;
- CheckActiveAndEditing;
- end;
- end;
- Procedure TDataLink.UpdateData;
- begin
- end;
- Function TDataLink.Edit: Boolean;
- begin
- If Not FReadOnly then
- DataSource.Edit;
- // Triggered event will set FEditing
- Result:=FEditing;
- end;
- Procedure TDataLink.UpdateRecord;
- begin
- FUpdatingRecord:=True;
- Try
- UpdateData;
- finally
- FUpdatingRecord:=False;
- end;
- end;
- { ---------------------------------------------------------------------
- TDetailDataLink
- ---------------------------------------------------------------------}
- Function TDetailDataLink.GetDetailDataSet: TDataSet;
- begin
- Result := nil;
- end;
- { ---------------------------------------------------------------------
- TMasterDataLink
- ---------------------------------------------------------------------}
- constructor TMasterDataLink.Create(ADataSet: TDataSet);
- begin
- inherited Create;
- FDetailDataSet:=ADataSet;
- FFields:=TList.Create;
- end;
- destructor TMasterDataLink.Destroy;
- begin
- FFields.Free;
- inherited Destroy;
- end;
- Procedure TMasterDataLink.ActiveChanged;
- begin
- FFields.Clear;
- if Active then
- try
- DataSet.GetFieldList(FFields, FFieldNames);
- except
- FFields.Clear;
- raise;
- end;
- if FDetailDataSet.Active and not (csDestroying in FDetailDataSet.ComponentState) then
- if Active and (FFields.Count > 0) then
- DoMasterChange
- else
- DoMasterDisable;
- end;
- Procedure TMasterDataLink.CheckBrowseMode;
- begin
- if FDetailDataSet.Active then FDetailDataSet.CheckBrowseMode;
- end;
- Function TMasterDataLink.GetDetailDataSet: TDataSet;
- begin
- Result := FDetailDataSet;
- end;
- Procedure TMasterDataLink.LayoutChanged;
- begin
- ActiveChanged;
- end;
- Procedure TMasterDataLink.RecordChanged(Field: TField);
- begin
- if (DataSource.State <> dsSetKey) and FDetailDataSet.Active and
- (FFields.Count > 0) and ((Field = nil) or
- (FFields.IndexOf(Field) >= 0)) then
- DoMasterChange;
- end;
- procedure TMasterDatalink.SetFieldNames(const Value: string);
- begin
- if FFieldNames <> Value then
- begin
- FFieldNames := Value;
- ActiveChanged;
- end;
- end;
- Procedure TMasterDataLink.DoMasterDisable;
- begin
- if Assigned(FOnMasterDisable) then
- FOnMasterDisable(Self);
- end;
- Procedure TMasterDataLink.DoMasterChange;
- begin
- If Assigned(FOnMasterChange) then
- FOnMasterChange(Self);
- end;
- { ---------------------------------------------------------------------
- TMasterParamsDataLink
- ---------------------------------------------------------------------}
- constructor TMasterParamsDataLink.Create(ADataSet: TDataSet);
- Var
- P : TParams;
- begin
- inherited Create(ADataset);
- If (ADataset<>Nil) then
- begin
- P:=TParams(GetObjectProp(ADataset,'Params',TParams));
- if (P<>Nil) then
- Params:=P;
- end;
- end;
- Procedure TMasterParamsDataLink.SetParams(AValue : TParams);
- begin
- FParams:=AValue;
- If (AValue<>Nil) then
- RefreshParamNames;
- end;
- Procedure TMasterParamsDataLink.RefreshParamNames;
- Var
- FN : String;
- DS : TDataset;
- F : TField;
- I : Integer;
- P : TParam;
- begin
- FN:='';
- DS:=Dataset;
- If Assigned(FParams) then
- begin
- F:=Nil;
- For I:=0 to FParams.Count-1 do
- begin
- P:=FParams[i];
- if not P.Bound then
- begin
- If Assigned(DS) then
- F:=DS.FindField(P.Name);
- If (Not Assigned(DS)) or (not DS.Active) or (F<>Nil) then
- begin
- If (FN<>'') then
- FN:=FN+';';
- FN:=FN+P.Name;
- end;
- end;
- end;
- end;
- FieldNames:=FN;
- end;
- Procedure TMasterParamsDataLink.CopyParamsFromMaster(CopyBound : Boolean);
- begin
- if Assigned(FParams) then
- FParams.CopyParamValuesFromDataset(Dataset,CopyBound);
- end;
- Procedure TMasterParamsDataLink.DoMasterDisable;
- begin
- Inherited;
- // If master dataset is closing, leave detail dataset intact (Delphi compatible behavior)
- // If master dataset is reopened, relationship will be reestablished
- end;
- Procedure TMasterParamsDataLink.DoMasterChange;
- begin
- Inherited;
- if Assigned(Params) and Assigned(DetailDataset) and DetailDataset.Active then
- begin
- DetailDataSet.CheckBrowseMode;
- DetailDataset.Close;
- DetailDataset.Open;
- end;
- end;
- { ---------------------------------------------------------------------
- TDatasource
- ---------------------------------------------------------------------}
- Constructor TDataSource.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- FDatalinks := TList.Create;
- FEnabled := True;
- FAutoEdit := True;
- end;
- Destructor TDataSource.Destroy;
- begin
- FOnStateCHange:=Nil;
- Dataset:=Nil;
- With FDataLinks do
- While Count>0 do
- TDatalink(Items[Count - 1]).DataSource:=Nil;
- FDatalinks.Free;
- inherited Destroy;
- end;
- Procedure TDatasource.Edit;
- begin
- If (State=dsBrowse) and AutoEdit Then
- Dataset.Edit;
- end;
- Function TDataSource.IsLinkedTo(ADataSet: TDataSet): Boolean;
- begin
- Result:=False;
- end;
- procedure TDatasource.DistributeEvent(Event: TDataEvent; Info: JSValue);
- Var
- i : Longint;
- begin
- With FDatalinks do
- begin
- For I:=0 to Count-1 do
- With TDatalink(Items[i]) do
- If Not VisualControl Then
- DataEvent(Event,Info);
- For I:=0 to Count-1 do
- With TDatalink(Items[i]) do
- If VisualControl Then
- DataEvent(Event,Info);
- end;
- end;
- procedure TDatasource.RegisterDataLink(DataLink: TDataLink);
- begin
- FDatalinks.Add(DataLink);
- if Assigned(DataSet) then
- DataSet.RecalcBufListSize;
- end;
- procedure TDatasource.SetDataSet(ADataSet: TDataSet);
- begin
- If FDataset<>Nil Then
- Begin
- FDataset.UnRegisterDataSource(Self);
- FDataSet:=nil;
- ProcessEvent(deUpdateState,0);
- End;
- If ADataset<>Nil Then
- begin
- ADataset.RegisterDatasource(Self);
- FDataSet:=ADataset;
- ProcessEvent(deUpdateState,0);
- End;
- end;
- procedure TDatasource.SetEnabled(Value: Boolean);
- begin
- FEnabled:=Value;
- end;
- Procedure TDatasource.DoDataChange (Info : Pointer);
- begin
- If Assigned(OnDataChange) Then
- OnDataChange(Self,TField(Info));
- end;
- Procedure TDatasource.DoStateChange;
- begin
- If Assigned(OnStateChange) Then
- OnStateChange(Self);
- end;
- Procedure TDatasource.DoUpdateData;
- begin
- If Assigned(OnUpdateData) Then
- OnUpdateData(Self);
- end;
- procedure TDatasource.UnregisterDataLink(DataLink: TDataLink);
- begin
- FDatalinks.Remove(Datalink);
- If Dataset<>Nil then
- DataSet.RecalcBufListSize;
- //Dataset.SetBufListSize(DataLink.BufferCount);
- end;
- procedure TDataSource.ProcessEvent(Event : TDataEvent; Info : JSValue);
- Const
- OnDataChangeEvents = [deRecordChange, deDataSetChange, deDataSetScroll,
- deLayoutChange,deUpdateState];
- Var
- NeedDataChange : Boolean;
- FLastState : TdataSetState;
- begin
- // Special UpdateState handling.
- If Event=deUpdateState then
- begin
- NeedDataChange:=(FState=dsInactive);
- FLastState:=FState;
- If Assigned(Dataset) then
- FState:=Dataset.State
- else
- FState:=dsInactive;
- // Don't do events if nothing changed.
- If FState=FLastState then
- exit;
- end
- else
- NeedDataChange:=True;
- DistributeEvent(Event,Info);
- // Extra handlers
- If Not (csDestroying in ComponentState) then
- begin
- If (Event=deUpdateState) then
- DoStateChange;
- If (Event in OnDataChangeEvents) and
- NeedDataChange Then
- DoDataChange(Nil);
- If (Event = deFieldChange) Then
- DoDataCHange(Pointer(Info));
- If (Event=deUpdateRecord) then
- DoUpdateData;
- end;
- end;
- procedure SkipQuotesString(S : String; var p : integer; QuoteChar : char; EscapeSlash, EscapeRepeat : Boolean);
- var notRepeatEscaped : boolean;
- begin
- Inc(p);
- repeat
- notRepeatEscaped := True;
- while not CharInSet(S[p],[#0, QuoteChar]) do
- begin
- if EscapeSlash and (S[p]='\') and (P<Length(S)) then
- Inc(p,2) // make sure we handle \' and \\ correct
- else
- Inc(p);
- end;
- if S[p]=QuoteChar then
- begin
- Inc(p); // skip final '
- if (S[p]=QuoteChar) and EscapeRepeat then // Handle escaping by ''
- begin
- notRepeatEscaped := False;
- inc(p);
- end
- end;
- until notRepeatEscaped;
- end;
- { TParams }
- Function TParams.GetItem(Index: Integer): TParam;
- begin
- Result:=(Inherited GetItem(Index)) as TParam;
- end;
- Function TParams.GetParamValue(const ParamName: string): JSValue;
- begin
- Result:=ParamByName(ParamName).Value;
- end;
- Procedure TParams.SetItem(Index: Integer; Value: TParam);
- begin
- Inherited SetItem(Index,Value);
- end;
- Procedure TParams.SetParamValue(const ParamName: string; const Value: JSValue);
- begin
- ParamByName(ParamName).Value:=Value;
- end;
- Procedure TParams.AssignTo(Dest: TPersistent);
- begin
- if (Dest is TParams) then
- TParams(Dest).Assign(Self)
- else
- inherited AssignTo(Dest);
- end;
- Function TParams.GetDataSet: TDataSet;
- begin
- If (FOwner is TDataset) Then
- Result:=TDataset(FOwner)
- else
- Result:=Nil;
- end;
- Function TParams.GetOwner: TPersistent;
- begin
- Result:=FOwner;
- end;
- Class Function TParams.ParamClass: TParamClass;
- begin
- Result:=TParam;
- end;
- Constructor TParams.Create(AOwner: TPersistent; AItemClass: TCollectionItemClass
- );
- begin
- Inherited Create(AItemClass);
- FOwner:=AOwner;
- end;
- Constructor TParams.Create(AOwner: TPersistent);
- begin
- Create(AOwner,ParamClass);
- end;
- Constructor TParams.Create;
- begin
- Create(Nil);
- end;
- Procedure TParams.AddParam(Value: TParam);
- begin
- Value.Collection:=Self;
- end;
- Procedure TParams.AssignValues(Value: TParams);
- Var
- I : Integer;
- P,PS : TParam;
- begin
- For I:=0 to Value.Count-1 do
- begin
- PS:=Value[i];
- P:=FindParam(PS.Name);
- If Assigned(P) then
- P.Assign(PS);
- end;
- end;
- Function TParams.CreateParam(FldType: TFieldType; const ParamName: string;
- ParamType: TParamType): TParam;
- begin
- Result:=Add as TParam;
- Result.Name:=ParamName;
- Result.DataType:=FldType;
- Result.ParamType:=ParamType;
- end;
- Function TParams.FindParam(const Value: string): TParam;
- Var
- I : Integer;
- begin
- Result:=Nil;
- I:=Count-1;
- While (Result=Nil) and (I>=0) do
- If (CompareText(Value,Items[i].Name)=0) then
- Result:=Items[i]
- else
- Dec(i);
- end;
- Procedure TParams.GetParamList(List: TList; const ParamNames: string);
- Var
- P: TParam;
- N: String;
- StrPos: Integer;
- begin
- if (ParamNames = '') or (List = nil) then
- Exit;
- StrPos := 1;
- repeat
- N := ExtractFieldName(ParamNames, StrPos);
- P := ParamByName(N);
- List.Add(P);
- until StrPos > Length(ParamNames);
- end;
- Function TParams.IsEqual(Value: TParams): Boolean;
- Var
- I : Integer;
- begin
- Result:=(Value.Count=Count);
- I:=Count-1;
- While Result and (I>=0) do
- begin
- Result:=Items[I].IsEqual(Value[i]);
- Dec(I);
- end;
- end;
- Function TParams.ParamByName(const Value: string): TParam;
- begin
- Result:=FindParam(Value);
- If (Result=Nil) then
- DatabaseErrorFmt(SParameterNotFound,[Value],Dataset);
- end;
- Function TParams.ParseSQL(SQL: String; DoCreate: Boolean): String;
- var pb : TParamBinding;
- rs : string;
- begin
- Result := ParseSQL(SQL,DoCreate,True,True,psInterbase, pb, rs);
- end;
- Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
- EscapeRepeat: Boolean; ParameterStyle: TParamStyle): String;
- var pb : TParamBinding;
- rs : string;
- begin
- Result := ParseSQL(SQL,DoCreate,EscapeSlash,EscapeRepeat,ParameterStyle,pb, rs);
- end;
- Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
- EscapeRepeat: Boolean; ParameterStyle: TParamStyle; out
- ParamBinding: TParambinding): String;
- var rs : string;
- begin
- Result := ParseSQL(SQL,DoCreate,EscapeSlash, EscapeRepeat, ParameterStyle,ParamBinding, rs);
- end;
- function SkipComments(S : String; Var p: Integer; EscapeSlash, EscapeRepeat : Boolean) : Boolean;
- begin
- Result := False;
- case S[P] of
- '''', '"', '`':
- begin
- Result := True;
- // single quote, double quote or backtick delimited string
- SkipQuotesString(S,p, S[p], EscapeSlash, EscapeRepeat);
- end;
- '-': // possible start of -- comment
- begin
- Inc(p);
- if S[p]='-' then // -- comment
- begin
- Result := True;
- repeat // skip until at end of line
- Inc(p);
- until CharInset(S[p],[#10, #13, #0]);
- while CharInSet(S[p],[#10, #13]) do
- Inc(p); // newline is part of comment
- end;
- end;
- '/': // possible start of /* */ comment
- begin
- Inc(p);
- if S[p]='*' then // /* */ comment
- begin
- Result := True;
- Inc(p);
- while p<=Length(S) do
- begin
- if S[p]='*' then // possible end of comment
- begin
- Inc(p);
- if S[p]='/' then Break; // end of comment
- end
- else
- Inc(p);
- end;
- if (P<=Length(s)) and (S[p]='/') then
- Inc(p); // skip final /
- end;
- end;
- end; {case}
- end;
- Function TParams.ParseSQL(SQL: String; DoCreate, EscapeSlash,
- EscapeRepeat: Boolean; ParameterStyle: TParamStyle; out
- ParamBinding: TParambinding; out ReplaceString: string): String;
- type
- // used for ParamPart
- TStringPart = record
- Start,Stop:integer;
- end;
- const
- ParamAllocStepSize = 8;
- PAramDelimiters : Array of char = (';',',',' ','(',')',#13,#10,#9,#0,'=','+','-','*','\','/','[',']','|');
- var
- IgnorePart:boolean;
- p,ParamNameStart,BufStart:Integer;
- ParamName:string;
- QuestionMarkParamCount,ParameterIndex,NewLength:integer;
- ParamCount:integer; // actual number of parameters encountered so far;
- // always <= Length(ParamPart) = Length(Parambinding)
- // Parambinding will have length ParamCount in the end
- ParamPart:array of TStringPart; // describe which parts of buf are parameters
- NewQueryLength:integer;
- NewQuery:string;
- NewQueryIndex,BufIndex,CopyLen,i:integer; // Parambinding will have length ParamCount in the end
- tmpParam:TParam;
- begin
- if DoCreate then Clear;
- // Parse the SQL and build ParamBinding
- ParamCount:=0;
- NewQueryLength:=Length(SQL);
- SetLength(ParamPart,ParamAllocStepSize);
- SetLength(ParamBinding,ParamAllocStepSize);
- QuestionMarkParamCount:=0; // number of ? params found in query so far
- ReplaceString := '$';
- if ParameterStyle = psSimulated then
- while pos(ReplaceString,SQL) > 0 do ReplaceString := ReplaceString+'$';
- p:=1;
- BufStart:=p; // used to calculate ParamPart.Start values
- repeat
- while SkipComments(SQL,p,EscapeSlash,EscapeRepeat) do ;
- case SQL[p] of
- ':','?': // parameter
- begin
- IgnorePart := False;
- if SQL[p]=':' then
- begin // find parameter name
- Inc(p);
- if charInSet(SQL[p],[':','=',' ']) then // ignore ::, since some databases uses this as a cast (wb 4813)
- begin
- IgnorePart := True;
- Inc(p);
- end
- else
- begin
- if (SQL[p]='"') then // Check if the parameter-name is between quotes
- begin
- ParamNameStart:=p;
- SkipQuotesString(SQL,p,'"',EscapeSlash,EscapeRepeat);
- // Do not include the quotes in ParamName, but they must be included
- // when the parameter is replaced by some place-holder.
- ParamName:=Copy(SQL,ParamNameStart+1,p-ParamNameStart-2);
- end
- else
- begin
- ParamNameStart:=p;
- while not CharInSet(SQL[p], ParamDelimiters) do
- Inc(p);
- ParamName:=Copy(SQL,ParamNameStart,p-ParamNameStart);
- end;
- end;
- end
- else
- begin
- Inc(p);
- ParamNameStart:=p;
- ParamName:='';
- end;
- if not IgnorePart then
- begin
- Inc(ParamCount);
- if ParamCount>Length(ParamPart) then
- begin
- NewLength:=Length(ParamPart)+ParamAllocStepSize;
- SetLength(ParamPart,NewLength);
- SetLength(ParamBinding,NewLength);
- end;
- if DoCreate then
- begin
- // Check if this is the first occurance of the parameter
- tmpParam := FindParam(ParamName);
- // If so, create the parameter and assign the Parameterindex
- if not assigned(tmpParam) then
- ParameterIndex := CreateParam(ftUnknown, ParamName, ptInput).Index
- else // else only assign the ParameterIndex
- ParameterIndex := tmpParam.Index;
- end
- // else find ParameterIndex
- else
- begin
- if ParamName<>'' then
- ParameterIndex:=ParamByName(ParamName).Index
- else
- begin
- ParameterIndex:=QuestionMarkParamCount;
- Inc(QuestionMarkParamCount);
- end;
- end;
- if ParameterStyle in [psPostgreSQL,psSimulated] then
- begin
- i:=ParameterIndex+1;
- repeat
- inc(NewQueryLength);
- i:=i div 10;
- until i=0;
- end;
- // store ParameterIndex in FParamIndex, ParamPart data
- ParamBinding[ParamCount-1]:=ParameterIndex;
- ParamPart[ParamCount-1].Start:=ParamNameStart-BufStart;
- ParamPart[ParamCount-1].Stop:=p-BufStart+1;
- // update NewQueryLength
- Dec(NewQueryLength,p-ParamNameStart);
- end;
- end;
- #0:
- Break; // end of SQL
- else
- Inc(p);
- end;
- until false;
- SetLength(ParamPart,ParamCount);
- SetLength(ParamBinding,ParamCount);
- if ParamCount<=0 then
- NewQuery:=SQL
- else
- begin
- // replace :ParamName by ? for interbase and by $x for postgresql/psSimulated
- // (using ParamPart array and NewQueryLength)
- if (ParameterStyle = psSimulated) and (length(ReplaceString) > 1) then
- inc(NewQueryLength,(paramcount)*(length(ReplaceString)-1));
- SetLength(NewQuery,NewQueryLength);
- NewQueryIndex:=1;
- BufIndex:=1;
- for i:=0 to High(ParamPart) do
- begin
- CopyLen:=ParamPart[i].Start-BufIndex;
- NewQuery:=NewQuery+Copy(SQL,BufIndex,CopyLen);
- Inc(NewQueryIndex,CopyLen);
- case ParameterStyle of
- psInterbase : begin
- NewQuery:=NewQuery+'?';
- Inc(NewQueryIndex);
- end;
- psPostgreSQL,
- psSimulated : begin
- ParamName := IntToStr(ParamBinding[i]+1);
- NewQuery:=StringOfChar('$',Length(ReplaceString));
- NewQuery:=NewQuery+ParamName;
- end;
- end;
- BufIndex:=ParamPart[i].Stop;
- end;
- CopyLen:=Length(SQL)+1-BufIndex;
- if (CopyLen>0) then
- NewQuery:=NewQuery+Copy(SQL,BufIndex,CopyLen);
- end;
- Result:=NewQuery;
- end;
- Procedure TParams.RemoveParam(Value: TParam);
- begin
- Value.Collection:=Nil;
- end;
- { TParam }
- Function TParam.GetDataSet: TDataSet;
- begin
- If Assigned(Collection) and (Collection is TParams) then
- Result:=TParams(Collection).GetDataset
- else
- Result:=Nil;
- end;
- Function TParam.IsParamStored: Boolean;
- begin
- Result:=Bound;
- end;
- Procedure TParam.AssignParam(Param: TParam);
- begin
- if Not Assigned(Param) then
- begin
- Clear;
- FDataType:=ftunknown;
- FParamType:=ptUnknown;
- Name:='';
- Size:=0;
- Precision:=0;
- NumericScale:=0;
- end
- else
- begin
- FDataType:=Param.DataType;
- if Param.IsNull then
- Clear
- else
- FValue:=Param.FValue;
- FBound:=Param.Bound;
- Name:=Param.Name;
- if (ParamType=ptUnknown) then
- ParamType:=Param.ParamType;
- Size:=Param.Size;
- Precision:=Param.Precision;
- NumericScale:=Param.NumericScale;
- end;
- end;
- Procedure TParam.AssignTo(Dest: TPersistent);
- begin
- if (Dest is TField) then
- AssignToField(TField(Dest))
- else
- inherited AssignTo(Dest);
- end;
- Function TParam.GetAsBoolean: Boolean;
- begin
- If IsNull then
- Result:=False
- else
- Result:=FValue=true;
- end;
- Function TParam.GetAsBytes: TBytes;
- begin
- if IsNull then
- Result:=nil
- else if isArray(FValue) then
- Result:=TBytes(FValue)
- end;
- Function TParam.GetAsDateTime: TDateTime;
- begin
- If IsNull then
- Result:=0.0
- else
- Result:=TDateTime(FValue);
- end;
- Function TParam.GetAsFloat: Double;
- begin
- If IsNull then
- Result:=0.0
- else
- Result:=Double(FValue);
- end;
- Function TParam.GetAsInteger: Longint;
- begin
- If IsNull or not IsInteger(FValue) then
- Result:=0
- else
- Result:=Integer(FValue);
- end;
- Function TParam.GetAsLargeInt: NativeInt;
- begin
- If IsNull or not IsInteger(FValue) then
- Result:=0
- else
- Result:=NativeInt(FValue);
- end;
- Function TParam.GetAsMemo: string;
- begin
- If IsNull or not IsString(FValue) then
- Result:=''
- else
- Result:=String(FValue);
- end;
- Function TParam.GetAsString: string;
- begin
- If IsNull or not IsString(FValue) then
- Result:=''
- else
- Result:=String(FValue);
- end;
- Function TParam.GetAsJSValue: JSValue;
- begin
- if IsNull then
- Result:=Null
- else
- Result:=FValue;
- end;
- Function TParam.GetDisplayName: string;
- begin
- if (FName<>'') then
- Result:=FName
- else
- Result:=inherited GetDisplayName
- end;
- Function TParam.GetIsNull: Boolean;
- begin
- Result:= JS.IsNull(FValue);
- end;
- Function TParam.IsEqual(AValue: TParam): Boolean;
- begin
- Result:=(Name=AValue.Name)
- and (IsNull=AValue.IsNull)
- and (Bound=AValue.Bound)
- and (DataType=AValue.DataType)
- and (ParamType=AValue.ParamType)
- and (GetValueType(FValue)=GetValueType(AValue.FValue))
- and (FValue=AValue.FValue);
- end;
- Procedure TParam.SetAsBlob(const AValue: TBlobData);
- begin
- FDataType:=ftBlob;
- Value:=AValue;
- end;
- Procedure TParam.SetAsBoolean(AValue: Boolean);
- begin
- FDataType:=ftBoolean;
- Value:=AValue;
- end;
- procedure TParam.SetAsBytes(const AValue: TBytes);
- begin
- end;
- Procedure TParam.SetAsDate(const AValue: TDateTime);
- begin
- FDataType:=ftDate;
- Value:=AValue;
- end;
- Procedure TParam.SetAsDateTime(const AValue: TDateTime);
- begin
- FDataType:=ftDateTime;
- Value:=AValue;
- end;
- Procedure TParam.SetAsFloat(const AValue: Double);
- begin
- FDataType:=ftFloat;
- Value:=AValue;
- end;
- Procedure TParam.SetAsInteger(AValue: Longint);
- begin
- FDataType:=ftInteger;
- Value:=AValue;
- end;
- Procedure TParam.SetAsLargeInt(AValue: NativeInt);
- begin
- FDataType:=ftLargeint;
- Value:=AValue;
- end;
- Procedure TParam.SetAsMemo(const AValue: string);
- begin
- FDataType:=ftMemo;
- Value:=AValue;
- end;
- Procedure TParam.SetAsString(const AValue: string);
- begin
- if FDataType <> ftFixedChar then
- FDataType := ftString;
- Value:=AValue;
- end;
- Procedure TParam.SetAsTime(const AValue: TDateTime);
- begin
- FDataType:=ftTime;
- Value:=AValue;
- end;
- Procedure TParam.SetAsJSValue(const AValue: JSValue);
- begin
- FValue:=AValue;
- FBound:=not JS.IsNull(AValue);
- if FBound then
- case GetValueType(aValue) of
- jvtBoolean : FDataType:=ftBoolean;
- jvtInteger : FDataType:=ftInteger;
- jvtFloat : FDataType:=ftFloat;
- jvtObject,jvtArray : FDataType:=ftBlob;
- end;
- end;
- Procedure TParam.SetDataType(AValue: TFieldType);
- begin
- FDataType:=AValue;
- end;
- Procedure TParam.SetText(const AValue: string);
- begin
- Value:=AValue;
- end;
- constructor TParam.Create(ACollection: TCollection);
- begin
- inherited Create(ACollection);
- ParamType:=ptUnknown;
- DataType:=ftUnknown;
- FValue:=Null;
- end;
- constructor TParam.Create(AParams: TParams; AParamType: TParamType);
- begin
- Create(AParams);
- ParamType:=AParamType;
- end;
- Procedure TParam.Assign(Source: TPersistent);
- begin
- if (Source is TParam) then
- AssignParam(TParam(Source))
- else if (Source is TField) then
- AssignField(TField(Source))
- else if (source is TStrings) then
- AsMemo:=TStrings(Source).Text
- else
- inherited Assign(Source);
- end;
- Procedure TParam.AssignField(Field: TField);
- begin
- if Assigned(Field) then
- begin
- // Need TField.Value
- AssignFieldValue(Field,Field.Value);
- Name:=Field.FieldName;
- end
- else
- begin
- Clear;
- Name:='';
- end
- end;
- Procedure TParam.AssignToField(Field : TField);
- begin
- if Assigned(Field) then
- case FDataType of
- ftUnknown : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
- // Need TField.AsSmallInt
- // Need TField.AsWord
- ftInteger,
- ftAutoInc : Field.AsInteger:=AsInteger;
- ftFloat : Field.AsFloat:=AsFloat;
- ftBoolean : Field.AsBoolean:=AsBoolean;
- ftBlob,
- ftString,
- ftMemo,
- ftFixedChar: Field.AsString:=AsString;
- ftTime,
- ftDate,
- ftDateTime : Field.AsDateTime:=AsDateTime;
- end;
- end;
- Procedure TParam.AssignFromField(Field : TField);
- begin
- if Assigned(Field) then
- begin
- FDataType:=Field.DataType;
- case Field.DataType of
- ftUnknown : DatabaseErrorFmt(SUnknownParamFieldType,[Name],DataSet);
- ftInteger,
- ftAutoInc : AsInteger:=Field.AsInteger;
- ftFloat : AsFloat:=Field.AsFloat;
- ftBoolean : AsBoolean:=Field.AsBoolean;
- ftBlob,
- ftString,
- ftMemo,
- ftFixedChar: AsString:=Field.AsString;
- ftTime,
- ftDate,
- ftDateTime : AsDateTime:=Field.AsDateTime;
- end;
- end;
- end;
- Procedure TParam.AssignFieldValue(Field: TField; const AValue: JSValue);
- begin
- If Assigned(Field) then
- begin
- if (Field.DataType = ftString) and TStringField(Field).FixedChar then
- FDataType := ftFixedChar
- else if (Field.DataType = ftMemo) and (Field.Size > 255) then
- FDataType := ftString
- else
- FDataType := Field.DataType;
- if JS.IsNull(AValue) then
- Clear
- else
- Value:=AValue;
- Size:=Field.DataSize;
- FBound:=True;
- end;
- end;
- Procedure TParam.Clear;
- begin
- FValue:=Null;
- end;
- Procedure TParams.CopyParamValuesFromDataset(ADataSet: TDataSet;
- CopyBound: Boolean);
- Var
- I : Integer;
- P : TParam;
- F : TField;
- begin
- If assigned(ADataSet) then
- For I:=0 to Count-1 do
- begin
- P:=Items[i];
- if CopyBound or (not P.Bound) then
- begin
- // Master dataset must be active and unbound parameters must have fields
- // with same names in master dataset (Delphi compatible behavior)
- F:=ADataSet.FieldByName(P.Name);
- P.AssignField(F);
- If Not CopyBound then
- P.Bound:=False;
- end;
- end;
- end;
- initialization
- end.
|