12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785378637873788378937903791379237933794379537963797379837993800380138023803380438053806380738083809381038113812381338143815381638173818381938203821382238233824382538263827382838293830383138323833383438353836383738383839384038413842384338443845384638473848384938503851385238533854385538563857385838593860386138623863386438653866386738683869387038713872387338743875387638773878387938803881388238833884388538863887388838893890389138923893389438953896389738983899390039013902390339043905390639073908390939103911391239133914391539163917391839193920392139223923392439253926392739283929393039313932393339343935393639373938393939403941394239433944394539463947394839493950395139523953395439553956395739583959396039613962396339643965396639673968396939703971397239733974397539763977397839793980398139823983398439853986398739883989399039913992399339943995399639973998399940004001400240034004400540064007400840094010401140124013401440154016401740184019402040214022402340244025402640274028402940304031403240334034403540364037403840394040404140424043404440454046404740484049405040514052405340544055405640574058405940604061406240634064406540664067406840694070407140724073407440754076407740784079408040814082408340844085408640874088408940904091409240934094409540964097409840994100410141024103410441054106410741084109411041114112411341144115411641174118411941204121412241234124412541264127412841294130413141324133413441354136413741384139414041414142414341444145414641474148414941504151415241534154415541564157415841594160416141624163416441654166416741684169417041714172417341744175417641774178417941804181418241834184418541864187418841894190419141924193419441954196419741984199420042014202420342044205420642074208420942104211421242134214421542164217421842194220422142224223422442254226422742284229423042314232423342344235423642374238423942404241424242434244424542464247424842494250425142524253425442554256425742584259426042614262426342644265426642674268426942704271427242734274427542764277427842794280428142824283428442854286428742884289429042914292429342944295429642974298429943004301430243034304430543064307430843094310431143124313431443154316431743184319432043214322432343244325432643274328432943304331433243334334433543364337433843394340434143424343434443454346434743484349435043514352435343544355435643574358435943604361436243634364436543664367436843694370437143724373437443754376437743784379438043814382438343844385438643874388438943904391439243934394439543964397439843994400440144024403440444054406440744084409441044114412441344144415441644174418441944204421442244234424442544264427442844294430443144324433443444354436443744384439444044414442444344444445444644474448444944504451445244534454445544564457445844594460446144624463446444654466446744684469447044714472447344744475447644774478447944804481448244834484448544864487448844894490449144924493449444954496449744984499450045014502450345044505450645074508450945104511451245134514451545164517451845194520452145224523452445254526452745284529453045314532453345344535453645374538453945404541454245434544454545464547454845494550455145524553455445554556455745584559456045614562456345644565456645674568456945704571457245734574457545764577457845794580458145824583458445854586458745884589459045914592459345944595459645974598459946004601460246034604460546064607460846094610461146124613461446154616461746184619462046214622462346244625462646274628462946304631463246334634463546364637463846394640464146424643464446454646464746484649465046514652465346544655465646574658465946604661466246634664466546664667466846694670467146724673467446754676467746784679468046814682468346844685468646874688468946904691469246934694469546964697469846994700470147024703470447054706470747084709471047114712471347144715471647174718471947204721472247234724472547264727472847294730473147324733473447354736473747384739474047414742474347444745474647474748474947504751475247534754475547564757475847594760476147624763476447654766476747684769477047714772477347744775477647774778477947804781478247834784478547864787478847894790479147924793479447954796479747984799480048014802480348044805480648074808480948104811481248134814481548164817481848194820482148224823482448254826482748284829483048314832483348344835483648374838483948404841484248434844484548464847484848494850485148524853485448554856485748584859486048614862486348644865486648674868486948704871487248734874487548764877487848794880488148824883488448854886488748884889489048914892489348944895489648974898489949004901490249034904490549064907490849094910491149124913491449154916491749184919492049214922492349244925492649274928492949304931493249334934493549364937493849394940494149424943494449454946494749484949495049514952495349544955495649574958495949604961496249634964496549664967496849694970497149724973497449754976497749784979498049814982498349844985498649874988498949904991499249934994499549964997499849995000500150025003500450055006500750085009501050115012501350145015501650175018501950205021502250235024502550265027502850295030503150325033503450355036503750385039504050415042504350445045504650475048504950505051505250535054505550565057505850595060506150625063506450655066506750685069507050715072507350745075507650775078507950805081508250835084508550865087508850895090509150925093509450955096509750985099510051015102510351045105510651075108510951105111511251135114511551165117511851195120512151225123512451255126512751285129513051315132513351345135513651375138513951405141514251435144514551465147514851495150515151525153515451555156515751585159516051615162516351645165516651675168516951705171517251735174517551765177517851795180518151825183518451855186518751885189519051915192519351945195519651975198519952005201520252035204520552065207520852095210521152125213521452155216521752185219522052215222522352245225522652275228522952305231523252335234523552365237523852395240524152425243524452455246524752485249525052515252525352545255525652575258525952605261526252635264526552665267526852695270527152725273527452755276527752785279528052815282528352845285528652875288528952905291529252935294529552965297529852995300530153025303530453055306530753085309531053115312531353145315531653175318531953205321532253235324532553265327532853295330533153325333533453355336533753385339534053415342534353445345534653475348534953505351535253535354535553565357535853595360536153625363536453655366536753685369537053715372537353745375537653775378537953805381538253835384538553865387538853895390539153925393539453955396539753985399540054015402540354045405540654075408540954105411541254135414541554165417541854195420542154225423542454255426542754285429543054315432543354345435543654375438543954405441544254435444544554465447544854495450545154525453545454555456545754585459546054615462546354645465546654675468546954705471547254735474547554765477547854795480548154825483548454855486548754885489549054915492549354945495549654975498549955005501550255035504550555065507550855095510551155125513551455155516551755185519552055215522552355245525552655275528552955305531553255335534553555365537553855395540554155425543554455455546554755485549555055515552555355545555555655575558555955605561556255635564556555665567556855695570557155725573557455755576557755785579558055815582558355845585558655875588558955905591559255935594559555965597559855995600560156025603560456055606560756085609561056115612561356145615561656175618561956205621562256235624562556265627562856295630563156325633563456355636563756385639564056415642564356445645564656475648564956505651565256535654565556565657565856595660566156625663566456655666566756685669567056715672567356745675567656775678567956805681568256835684568556865687568856895690569156925693569456955696569756985699570057015702570357045705570657075708570957105711571257135714571557165717571857195720572157225723572457255726572757285729573057315732573357345735573657375738573957405741574257435744574557465747574857495750575157525753575457555756575757585759576057615762576357645765576657675768576957705771577257735774577557765777577857795780578157825783578457855786578757885789579057915792579357945795579657975798579958005801580258035804580558065807580858095810581158125813581458155816581758185819582058215822582358245825582658275828582958305831583258335834583558365837583858395840584158425843584458455846584758485849585058515852585358545855585658575858585958605861586258635864586558665867586858695870587158725873587458755876587758785879588058815882588358845885588658875888588958905891589258935894589558965897589858995900590159025903590459055906590759085909591059115912591359145915591659175918591959205921592259235924592559265927592859295930593159325933593459355936593759385939594059415942594359445945594659475948594959505951595259535954595559565957595859595960596159625963596459655966596759685969597059715972597359745975597659775978597959805981598259835984598559865987598859895990599159925993599459955996599759985999600060016002600360046005600660076008600960106011601260136014601560166017601860196020602160226023602460256026602760286029603060316032603360346035603660376038603960406041604260436044604560466047604860496050605160526053605460556056605760586059606060616062606360646065606660676068606960706071607260736074607560766077607860796080608160826083608460856086608760886089609060916092609360946095609660976098609961006101610261036104610561066107610861096110611161126113611461156116611761186119612061216122612361246125612661276128612961306131613261336134613561366137613861396140614161426143614461456146614761486149615061516152615361546155615661576158615961606161616261636164616561666167616861696170617161726173617461756176617761786179618061816182618361846185618661876188618961906191619261936194619561966197619861996200620162026203620462056206620762086209621062116212621362146215621662176218621962206221622262236224622562266227622862296230623162326233623462356236623762386239624062416242624362446245624662476248624962506251625262536254625562566257625862596260626162626263626462656266626762686269627062716272627362746275627662776278627962806281628262836284628562866287628862896290629162926293629462956296629762986299630063016302630363046305630663076308630963106311631263136314631563166317631863196320632163226323632463256326632763286329633063316332633363346335633663376338633963406341634263436344634563466347634863496350635163526353635463556356635763586359636063616362636363646365636663676368636963706371637263736374637563766377637863796380638163826383638463856386638763886389639063916392639363946395639663976398639964006401640264036404640564066407640864096410641164126413641464156416641764186419642064216422642364246425642664276428642964306431643264336434643564366437643864396440644164426443644464456446644764486449645064516452645364546455645664576458645964606461646264636464646564666467646864696470647164726473647464756476647764786479648064816482648364846485648664876488648964906491649264936494649564966497649864996500650165026503650465056506650765086509651065116512651365146515651665176518651965206521652265236524652565266527652865296530653165326533653465356536653765386539654065416542654365446545654665476548654965506551655265536554655565566557655865596560656165626563656465656566656765686569657065716572657365746575657665776578657965806581658265836584658565866587658865896590659165926593659465956596659765986599660066016602660366046605660666076608660966106611661266136614661566166617661866196620662166226623662466256626662766286629663066316632663366346635663666376638663966406641664266436644664566466647664866496650665166526653665466556656665766586659666066616662666366646665666666676668666966706671667266736674667566766677667866796680668166826683668466856686668766886689669066916692669366946695669666976698669967006701670267036704670567066707670867096710671167126713671467156716671767186719672067216722672367246725672667276728672967306731673267336734673567366737673867396740674167426743674467456746674767486749675067516752675367546755675667576758675967606761676267636764676567666767676867696770677167726773677467756776677767786779678067816782678367846785678667876788678967906791679267936794679567966797679867996800680168026803680468056806680768086809681068116812681368146815681668176818681968206821682268236824682568266827682868296830683168326833683468356836683768386839684068416842684368446845684668476848684968506851685268536854685568566857685868596860686168626863686468656866686768686869687068716872687368746875687668776878687968806881688268836884688568866887688868896890689168926893689468956896689768986899690069016902690369046905690669076908690969106911691269136914691569166917691869196920692169226923692469256926692769286929693069316932693369346935693669376938693969406941694269436944694569466947694869496950695169526953695469556956695769586959696069616962696369646965696669676968696969706971697269736974697569766977697869796980698169826983698469856986698769886989699069916992699369946995699669976998699970007001700270037004700570067007700870097010701170127013701470157016701770187019702070217022702370247025702670277028702970307031703270337034703570367037703870397040704170427043704470457046704770487049705070517052705370547055705670577058705970607061706270637064706570667067706870697070707170727073707470757076707770787079708070817082708370847085708670877088708970907091709270937094709570967097709870997100710171027103710471057106710771087109711071117112711371147115711671177118711971207121712271237124712571267127712871297130713171327133713471357136713771387139714071417142714371447145714671477148714971507151715271537154715571567157715871597160716171627163716471657166716771687169717071717172717371747175717671777178717971807181718271837184718571867187718871897190719171927193719471957196719771987199720072017202720372047205720672077208720972107211721272137214721572167217721872197220722172227223722472257226722772287229723072317232723372347235723672377238723972407241724272437244724572467247724872497250725172527253725472557256725772587259726072617262726372647265726672677268726972707271727272737274727572767277727872797280728172827283728472857286728772887289729072917292729372947295729672977298729973007301730273037304730573067307730873097310731173127313731473157316731773187319732073217322732373247325732673277328732973307331733273337334733573367337733873397340734173427343734473457346734773487349735073517352735373547355735673577358735973607361736273637364736573667367736873697370737173727373737473757376737773787379738073817382738373847385738673877388738973907391739273937394739573967397739873997400740174027403740474057406740774087409741074117412741374147415741674177418741974207421742274237424742574267427742874297430743174327433743474357436743774387439744074417442744374447445744674477448744974507451745274537454745574567457745874597460746174627463746474657466746774687469747074717472747374747475747674777478747974807481748274837484748574867487748874897490749174927493749474957496749774987499750075017502750375047505750675077508750975107511751275137514751575167517751875197520752175227523752475257526752775287529753075317532753375347535753675377538753975407541754275437544754575467547754875497550755175527553755475557556755775587559756075617562756375647565756675677568756975707571757275737574757575767577757875797580758175827583758475857586758775887589759075917592759375947595759675977598759976007601760276037604760576067607760876097610761176127613761476157616761776187619762076217622762376247625762676277628762976307631763276337634763576367637763876397640764176427643764476457646764776487649765076517652765376547655765676577658765976607661766276637664766576667667766876697670767176727673767476757676767776787679768076817682768376847685768676877688768976907691769276937694769576967697769876997700770177027703770477057706770777087709771077117712771377147715771677177718771977207721772277237724772577267727772877297730773177327733773477357736773777387739774077417742774377447745774677477748774977507751775277537754775577567757775877597760776177627763776477657766776777687769777077717772777377747775777677777778777977807781778277837784778577867787778877897790779177927793779477957796779777987799780078017802780378047805780678077808780978107811781278137814781578167817781878197820782178227823782478257826782778287829783078317832783378347835783678377838783978407841784278437844784578467847784878497850785178527853785478557856785778587859786078617862786378647865786678677868786978707871787278737874787578767877787878797880788178827883788478857886788778887889789078917892789378947895789678977898789979007901790279037904790579067907790879097910791179127913791479157916791779187919792079217922792379247925792679277928792979307931793279337934793579367937793879397940794179427943794479457946794779487949795079517952795379547955795679577958795979607961796279637964796579667967796879697970797179727973797479757976797779787979798079817982798379847985798679877988798979907991799279937994799579967997799879998000800180028003800480058006800780088009801080118012801380148015801680178018801980208021802280238024802580268027802880298030803180328033803480358036803780388039804080418042804380448045804680478048804980508051805280538054805580568057805880598060806180628063806480658066806780688069807080718072807380748075807680778078807980808081808280838084808580868087808880898090809180928093809480958096809780988099810081018102810381048105810681078108810981108111811281138114811581168117811881198120812181228123812481258126812781288129813081318132813381348135813681378138813981408141814281438144814581468147814881498150815181528153815481558156815781588159816081618162816381648165816681678168816981708171817281738174817581768177817881798180818181828183818481858186818781888189819081918192819381948195819681978198819982008201820282038204820582068207820882098210821182128213821482158216821782188219822082218222822382248225822682278228822982308231823282338234823582368237823882398240824182428243824482458246824782488249825082518252825382548255825682578258825982608261826282638264826582668267826882698270827182728273827482758276827782788279828082818282828382848285828682878288828982908291829282938294829582968297829882998300830183028303830483058306830783088309831083118312831383148315831683178318831983208321832283238324832583268327832883298330833183328333833483358336833783388339834083418342834383448345834683478348834983508351835283538354835583568357835883598360836183628363836483658366836783688369837083718372837383748375837683778378837983808381838283838384838583868387838883898390839183928393839483958396839783988399840084018402840384048405840684078408840984108411841284138414841584168417841884198420842184228423842484258426842784288429843084318432843384348435843684378438843984408441844284438444844584468447844884498450845184528453845484558456845784588459846084618462846384648465846684678468846984708471847284738474847584768477847884798480848184828483848484858486848784888489849084918492849384948495849684978498849985008501850285038504850585068507850885098510851185128513851485158516851785188519852085218522852385248525852685278528852985308531853285338534853585368537853885398540854185428543854485458546854785488549855085518552855385548555855685578558855985608561856285638564856585668567856885698570857185728573857485758576857785788579858085818582858385848585858685878588858985908591859285938594859585968597859885998600860186028603860486058606860786088609861086118612861386148615861686178618861986208621862286238624862586268627862886298630863186328633863486358636863786388639864086418642864386448645864686478648864986508651865286538654865586568657865886598660866186628663866486658666866786688669867086718672867386748675867686778678867986808681868286838684868586868687868886898690869186928693869486958696869786988699870087018702870387048705870687078708870987108711871287138714871587168717871887198720872187228723872487258726872787288729873087318732873387348735873687378738873987408741874287438744874587468747874887498750875187528753875487558756875787588759876087618762876387648765876687678768876987708771877287738774877587768777877887798780878187828783878487858786878787888789879087918792879387948795879687978798879988008801880288038804880588068807880888098810881188128813881488158816881788188819882088218822882388248825882688278828882988308831883288338834883588368837883888398840884188428843884488458846884788488849885088518852885388548855885688578858885988608861886288638864886588668867886888698870887188728873887488758876887788788879888088818882 |
- {
- 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
- 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;
- { 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;
- 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 GetBufferCount: Longint;
- 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 GetBufferCount;
- 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);
- 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:=TIndexDef.Create(Self,'','',[]);
- end;
- procedure TIndexDefs.Add(const Name, Fields: string; Options: TIndexOptions);
- begin
- TIndexDef.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.GetBufferCount: Longint;
- begin
- Result:=Length(FBuffers);
- 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>BufferCount then
- begin
- For I:=FBufferCount to Value do
- FBuffers[i]:=AllocRecordBuffer;
- end
- else if value<BufferCount 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.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[BufferCount]:=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 Assigned(FLookupDataSet) and FDataSet.Active then
- Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField);
- }
- 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;
- *)
- 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.
|