1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673367436753676367736783679368036813682368336843685368636873688368936903691369236933694369536963697369836993700370137023703370437053706370737083709371037113712371337143715371637173718371937203721372237233724372537263727372837293730373137323733373437353736373737383739374037413742374337443745374637473748374937503751375237533754375537563757375837593760376137623763376437653766376737683769377037713772377337743775377637773778377937803781378237833784378537863787378837893790379137923793379437953796379737983799380038013802380338043805380638073808380938103811381238133814381538163817381838193820382138223823382438253826382738283829383038313832383338343835383638373838383938403841384238433844384538463847384838493850385138523853385438553856385738583859386038613862386338643865386638673868386938703871387238733874387538763877387838793880388138823883388438853886388738883889389038913892389338943895389638973898389939003901390239033904390539063907390839093910391139123913391439153916391739183919392039213922392339243925392639273928392939303931393239333934393539363937393839393940394139423943394439453946394739483949395039513952395339543955395639573958395939603961396239633964396539663967396839693970397139723973397439753976397739783979398039813982398339843985398639873988398939903991399239933994399539963997399839994000400140024003400440054006400740084009401040114012401340144015401640174018401940204021402240234024402540264027402840294030403140324033403440354036403740384039404040414042404340444045404640474048404940504051405240534054405540564057405840594060406140624063406440654066406740684069407040714072407340744075407640774078407940804081408240834084408540864087408840894090409140924093409440954096409740984099410041014102410341044105410641074108410941104111411241134114411541164117411841194120412141224123412441254126412741284129413041314132413341344135413641374138413941404141414241434144414541464147414841494150415141524153415441554156415741584159416041614162416341644165416641674168416941704171417241734174417541764177417841794180418141824183418441854186418741884189419041914192419341944195419641974198419942004201420242034204420542064207420842094210421142124213421442154216421742184219422042214222422342244225422642274228422942304231423242334234423542364237423842394240424142424243424442454246424742484249425042514252425342544255425642574258425942604261426242634264426542664267426842694270427142724273427442754276427742784279428042814282428342844285428642874288428942904291429242934294429542964297429842994300430143024303430443054306430743084309431043114312431343144315431643174318431943204321432243234324432543264327432843294330433143324333433443354336433743384339434043414342434343444345434643474348434943504351435243534354435543564357435843594360436143624363436443654366436743684369437043714372437343744375437643774378437943804381438243834384438543864387438843894390439143924393439443954396439743984399440044014402440344044405440644074408440944104411441244134414441544164417441844194420442144224423442444254426442744284429443044314432443344344435443644374438443944404441444244434444444544464447444844494450445144524453445444554456445744584459446044614462446344644465446644674468446944704471447244734474447544764477447844794480448144824483448444854486448744884489449044914492449344944495449644974498449945004501450245034504450545064507450845094510451145124513451445154516451745184519452045214522452345244525452645274528452945304531453245334534453545364537453845394540454145424543454445454546454745484549455045514552455345544555455645574558455945604561456245634564456545664567456845694570457145724573457445754576457745784579458045814582458345844585458645874588458945904591459245934594459545964597459845994600460146024603460446054606460746084609461046114612461346144615461646174618461946204621462246234624462546264627462846294630463146324633463446354636463746384639464046414642464346444645464646474648464946504651465246534654465546564657465846594660466146624663466446654666466746684669467046714672467346744675467646774678467946804681468246834684468546864687468846894690469146924693469446954696469746984699470047014702470347044705470647074708470947104711471247134714471547164717471847194720472147224723472447254726472747284729473047314732473347344735473647374738473947404741474247434744474547464747474847494750475147524753475447554756475747584759476047614762476347644765476647674768476947704771477247734774477547764777477847794780478147824783478447854786478747884789479047914792479347944795479647974798479948004801480248034804480548064807480848094810481148124813481448154816481748184819482048214822482348244825482648274828482948304831483248334834483548364837483848394840484148424843484448454846484748484849485048514852485348544855485648574858485948604861486248634864486548664867486848694870487148724873487448754876487748784879488048814882488348844885488648874888488948904891489248934894489548964897489848994900490149024903490449054906490749084909491049114912491349144915491649174918491949204921492249234924492549264927492849294930493149324933493449354936493749384939494049414942494349444945494649474948494949504951495249534954495549564957495849594960496149624963496449654966496749684969497049714972497349744975497649774978497949804981498249834984498549864987498849894990499149924993499449954996499749984999500050015002500350045005500650075008500950105011501250135014501550165017501850195020502150225023502450255026502750285029503050315032503350345035503650375038503950405041504250435044504550465047504850495050505150525053505450555056505750585059506050615062506350645065506650675068506950705071507250735074507550765077507850795080508150825083508450855086508750885089509050915092509350945095509650975098509951005101510251035104510551065107510851095110511151125113511451155116511751185119512051215122512351245125512651275128512951305131513251335134513551365137513851395140514151425143514451455146514751485149515051515152515351545155515651575158515951605161516251635164516551665167516851695170517151725173517451755176517751785179518051815182518351845185518651875188518951905191519251935194519551965197519851995200520152025203520452055206520752085209521052115212521352145215521652175218521952205221522252235224522552265227522852295230523152325233523452355236523752385239524052415242524352445245524652475248524952505251525252535254525552565257525852595260526152625263526452655266526752685269527052715272527352745275527652775278527952805281528252835284528552865287528852895290529152925293529452955296529752985299530053015302530353045305530653075308530953105311531253135314531553165317531853195320532153225323532453255326532753285329533053315332533353345335533653375338533953405341534253435344534553465347534853495350535153525353535453555356535753585359536053615362536353645365536653675368536953705371537253735374537553765377537853795380538153825383538453855386538753885389539053915392539353945395539653975398539954005401540254035404540554065407540854095410541154125413541454155416541754185419542054215422542354245425542654275428542954305431543254335434543554365437543854395440544154425443544454455446544754485449545054515452545354545455545654575458545954605461546254635464546554665467546854695470547154725473547454755476547754785479548054815482548354845485548654875488548954905491549254935494549554965497549854995500550155025503550455055506550755085509551055115512551355145515551655175518551955205521552255235524552555265527552855295530553155325533553455355536553755385539554055415542554355445545554655475548554955505551555255535554555555565557555855595560556155625563556455655566556755685569557055715572557355745575557655775578557955805581558255835584558555865587558855895590559155925593559455955596559755985599560056015602560356045605560656075608560956105611561256135614561556165617561856195620562156225623562456255626562756285629563056315632563356345635563656375638563956405641564256435644564556465647564856495650565156525653565456555656565756585659566056615662566356645665566656675668566956705671567256735674567556765677567856795680568156825683568456855686568756885689569056915692569356945695569656975698569957005701570257035704570557065707570857095710571157125713571457155716571757185719572057215722572357245725572657275728572957305731573257335734573557365737573857395740574157425743574457455746574757485749575057515752575357545755575657575758575957605761576257635764576557665767576857695770577157725773577457755776577757785779578057815782578357845785578657875788578957905791579257935794579557965797579857995800580158025803580458055806580758085809581058115812581358145815581658175818581958205821582258235824582558265827582858295830583158325833583458355836583758385839584058415842584358445845584658475848584958505851585258535854585558565857585858595860586158625863586458655866586758685869587058715872587358745875587658775878587958805881588258835884588558865887588858895890589158925893589458955896589758985899590059015902590359045905590659075908590959105911591259135914591559165917591859195920592159225923592459255926592759285929593059315932593359345935593659375938593959405941594259435944594559465947594859495950595159525953595459555956595759585959596059615962596359645965596659675968596959705971597259735974597559765977597859795980598159825983598459855986598759885989599059915992599359945995599659975998599960006001600260036004600560066007600860096010601160126013601460156016601760186019602060216022602360246025602660276028602960306031603260336034603560366037603860396040604160426043604460456046604760486049605060516052605360546055605660576058605960606061606260636064606560666067606860696070607160726073607460756076607760786079608060816082608360846085608660876088608960906091609260936094609560966097609860996100610161026103610461056106610761086109611061116112611361146115611661176118611961206121612261236124612561266127612861296130613161326133613461356136613761386139614061416142614361446145614661476148614961506151615261536154615561566157615861596160616161626163616461656166616761686169617061716172617361746175617661776178617961806181618261836184618561866187618861896190619161926193619461956196619761986199620062016202620362046205620662076208620962106211621262136214621562166217621862196220622162226223622462256226622762286229623062316232623362346235623662376238623962406241624262436244624562466247624862496250625162526253625462556256625762586259626062616262626362646265626662676268626962706271627262736274627562766277627862796280628162826283628462856286628762886289629062916292629362946295629662976298629963006301630263036304630563066307630863096310631163126313631463156316631763186319632063216322632363246325632663276328632963306331633263336334633563366337633863396340634163426343634463456346634763486349635063516352635363546355635663576358635963606361636263636364636563666367636863696370637163726373637463756376637763786379638063816382638363846385638663876388638963906391639263936394639563966397639863996400640164026403640464056406640764086409641064116412641364146415641664176418641964206421642264236424642564266427642864296430643164326433643464356436643764386439644064416442644364446445644664476448644964506451645264536454645564566457645864596460646164626463646464656466646764686469647064716472647364746475647664776478647964806481648264836484648564866487648864896490649164926493649464956496649764986499650065016502650365046505650665076508650965106511651265136514651565166517651865196520652165226523652465256526652765286529653065316532653365346535653665376538653965406541654265436544654565466547654865496550655165526553655465556556655765586559656065616562656365646565656665676568656965706571657265736574657565766577657865796580658165826583658465856586658765886589659065916592659365946595659665976598659966006601660266036604660566066607660866096610661166126613661466156616661766186619662066216622662366246625662666276628662966306631663266336634663566366637663866396640664166426643664466456646664766486649665066516652665366546655665666576658665966606661666266636664666566666667666866696670667166726673667466756676667766786679668066816682668366846685668666876688668966906691669266936694669566966697669866996700670167026703670467056706670767086709671067116712671367146715671667176718671967206721672267236724672567266727672867296730673167326733673467356736673767386739674067416742674367446745674667476748674967506751675267536754675567566757675867596760676167626763676467656766676767686769677067716772677367746775677667776778677967806781678267836784678567866787678867896790679167926793679467956796679767986799680068016802680368046805680668076808680968106811681268136814681568166817681868196820682168226823682468256826682768286829683068316832683368346835683668376838683968406841684268436844684568466847684868496850685168526853685468556856685768586859686068616862686368646865686668676868686968706871687268736874687568766877687868796880688168826883688468856886688768886889689068916892689368946895689668976898689969006901690269036904690569066907690869096910691169126913691469156916691769186919692069216922692369246925692669276928692969306931693269336934693569366937693869396940694169426943694469456946694769486949695069516952695369546955695669576958695969606961696269636964696569666967696869696970697169726973697469756976697769786979698069816982698369846985698669876988698969906991699269936994699569966997699869997000700170027003700470057006700770087009701070117012701370147015701670177018701970207021702270237024702570267027702870297030703170327033703470357036703770387039704070417042704370447045704670477048704970507051705270537054705570567057705870597060706170627063706470657066706770687069707070717072707370747075707670777078707970807081708270837084708570867087708870897090709170927093709470957096709770987099710071017102710371047105710671077108710971107111711271137114711571167117711871197120712171227123712471257126712771287129713071317132713371347135713671377138713971407141714271437144714571467147714871497150715171527153715471557156715771587159716071617162716371647165716671677168716971707171717271737174717571767177717871797180718171827183718471857186718771887189719071917192719371947195719671977198719972007201720272037204720572067207720872097210721172127213721472157216721772187219722072217222722372247225722672277228722972307231723272337234723572367237723872397240724172427243724472457246724772487249725072517252725372547255725672577258725972607261726272637264726572667267726872697270727172727273727472757276727772787279728072817282728372847285728672877288728972907291729272937294729572967297729872997300730173027303730473057306730773087309731073117312731373147315731673177318731973207321732273237324732573267327732873297330733173327333733473357336733773387339734073417342734373447345734673477348734973507351735273537354735573567357735873597360736173627363736473657366736773687369737073717372737373747375737673777378737973807381738273837384738573867387738873897390739173927393739473957396739773987399740074017402740374047405740674077408740974107411741274137414741574167417741874197420742174227423742474257426742774287429743074317432743374347435743674377438743974407441744274437444744574467447744874497450745174527453745474557456745774587459746074617462746374647465746674677468746974707471747274737474747574767477747874797480748174827483748474857486748774887489749074917492749374947495749674977498749975007501750275037504750575067507750875097510751175127513751475157516751775187519752075217522752375247525752675277528752975307531753275337534753575367537753875397540754175427543754475457546754775487549755075517552755375547555755675577558755975607561756275637564756575667567756875697570757175727573757475757576757775787579758075817582758375847585758675877588758975907591759275937594759575967597759875997600760176027603760476057606760776087609761076117612761376147615761676177618761976207621762276237624762576267627762876297630763176327633763476357636763776387639764076417642764376447645764676477648764976507651765276537654765576567657765876597660766176627663766476657666766776687669767076717672767376747675767676777678767976807681768276837684768576867687768876897690769176927693769476957696769776987699770077017702770377047705770677077708770977107711771277137714771577167717771877197720772177227723772477257726772777287729773077317732773377347735773677377738773977407741774277437744774577467747774877497750775177527753775477557756775777587759776077617762776377647765776677677768776977707771777277737774777577767777777877797780778177827783778477857786778777887789779077917792779377947795779677977798779978007801780278037804780578067807780878097810781178127813781478157816781778187819782078217822782378247825782678277828782978307831783278337834783578367837783878397840784178427843784478457846784778487849785078517852785378547855785678577858785978607861786278637864786578667867786878697870787178727873787478757876787778787879788078817882788378847885788678877888788978907891789278937894789578967897789878997900790179027903790479057906790779087909791079117912791379147915791679177918791979207921792279237924792579267927792879297930793179327933793479357936793779387939794079417942794379447945794679477948794979507951795279537954795579567957795879597960796179627963796479657966796779687969797079717972797379747975797679777978797979807981798279837984798579867987798879897990799179927993799479957996799779987999800080018002800380048005800680078008800980108011801280138014801580168017801880198020802180228023802480258026802780288029803080318032803380348035803680378038803980408041804280438044804580468047804880498050805180528053805480558056805780588059806080618062806380648065806680678068806980708071807280738074807580768077807880798080808180828083808480858086808780888089809080918092809380948095809680978098809981008101810281038104810581068107810881098110811181128113811481158116811781188119812081218122812381248125812681278128812981308131813281338134813581368137813881398140814181428143814481458146814781488149815081518152815381548155815681578158815981608161816281638164816581668167816881698170817181728173817481758176817781788179818081818182818381848185818681878188818981908191819281938194819581968197819881998200820182028203820482058206820782088209821082118212821382148215821682178218821982208221822282238224822582268227822882298230823182328233823482358236823782388239824082418242824382448245824682478248824982508251825282538254825582568257825882598260826182628263826482658266826782688269827082718272827382748275827682778278827982808281828282838284828582868287828882898290829182928293829482958296829782988299830083018302830383048305830683078308830983108311831283138314831583168317831883198320832183228323832483258326832783288329833083318332833383348335833683378338833983408341834283438344834583468347834883498350835183528353835483558356835783588359836083618362836383648365836683678368836983708371837283738374837583768377837883798380838183828383838483858386838783888389839083918392839383948395839683978398839984008401840284038404840584068407840884098410841184128413841484158416841784188419842084218422842384248425842684278428842984308431843284338434843584368437843884398440844184428443844484458446844784488449845084518452845384548455845684578458845984608461846284638464846584668467846884698470847184728473847484758476847784788479848084818482848384848485848684878488848984908491849284938494849584968497849884998500850185028503850485058506850785088509851085118512851385148515851685178518851985208521852285238524852585268527852885298530853185328533853485358536853785388539854085418542854385448545854685478548854985508551855285538554855585568557855885598560856185628563856485658566856785688569857085718572857385748575857685778578857985808581858285838584858585868587858885898590859185928593859485958596859785988599860086018602860386048605860686078608860986108611861286138614861586168617861886198620862186228623862486258626862786288629863086318632863386348635863686378638863986408641864286438644864586468647864886498650865186528653865486558656865786588659866086618662866386648665866686678668866986708671867286738674867586768677867886798680868186828683868486858686868786888689869086918692869386948695869686978698869987008701870287038704870587068707870887098710871187128713871487158716871787188719872087218722872387248725872687278728872987308731873287338734873587368737873887398740874187428743874487458746874787488749875087518752875387548755875687578758875987608761876287638764876587668767876887698770877187728773877487758776877787788779878087818782878387848785878687878788878987908791879287938794879587968797879887998800880188028803880488058806880788088809881088118812881388148815881688178818881988208821882288238824882588268827882888298830883188328833883488358836883788388839884088418842884388448845884688478848884988508851885288538854885588568857885888598860886188628863886488658866886788688869887088718872887388748875887688778878887988808881888288838884888588868887888888898890889188928893889488958896889788988899890089018902890389048905890689078908890989108911891289138914891589168917891889198920892189228923892489258926892789288929893089318932893389348935893689378938893989408941894289438944894589468947894889498950895189528953895489558956895789588959896089618962896389648965896689678968896989708971897289738974897589768977897889798980898189828983898489858986898789888989899089918992899389948995899689978998899990009001900290039004900590069007900890099010901190129013901490159016901790189019902090219022902390249025902690279028902990309031903290339034903590369037903890399040904190429043904490459046904790489049905090519052905390549055905690579058905990609061906290639064906590669067906890699070907190729073907490759076907790789079908090819082908390849085908690879088908990909091909290939094909590969097909890999100910191029103910491059106910791089109911091119112911391149115911691179118911991209121912291239124912591269127912891299130913191329133913491359136913791389139914091419142914391449145914691479148914991509151915291539154915591569157915891599160916191629163916491659166916791689169917091719172917391749175917691779178 |
- {
- 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 = (usModified, usInserted, usDeleted);
- TUpdateStatusSet = Set of TUpdateStatus;
- TResolveStatus = (rsUnresolved, rsResolving, rsResolved, rsResolveFailed);
- TResolveStatusSet = Set of TResolveStatus;
- 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;
- procedure DefineProperties(Filer: TFiler); override;
- 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;
- Function GetAsBytes: TBytes; override;
- Procedure SetAsBytes(const aValue: TBytes); override;
- public
- constructor Create(AOwner: TComponent); override;
- published
- property Size default 16;
- end;
- { TBytesField }
- { TBlobField }
- TBlobDisplayValue = (dvClass, dvFull, dvClip, dvFit);
- TBlobStreamMode = (bmRead, bmWrite, bmReadWrite);
- TBlobType = ftBlob..ftMemo;
- TBlobField = class(TBinaryField)
- private
- FDisplayValue: TBlobDisplayValue;
- FModified : Boolean;
- // Wrapper that retrieves FDataType as a TBlobType
- function GetBlobType: TBlobType;
- // Wrapper that calls SetFieldType
- procedure SetBlobType(AValue: TBlobType);
- procedure SetDisplayValue(AValue: TBlobDisplayValue);
- protected
- class procedure CheckTypeSize(AValue: Longint); override;
- function GetBlobSize: Longint; virtual;
- function GetIsNull: Boolean; override;
- procedure GetText(var AText: string; ADisplayText{%H-}: Boolean); override;
- public
- constructor Create(AOwner: TComponent); override;
- procedure Clear; override;
- class function IsBlob: Boolean; override;
- procedure SetFieldType(AValue: TFieldType); override;
- property BlobSize: Longint read GetBlobSize;
- property Modified: Boolean read FModified write FModified;
- property Value: string read GetAsString write SetAsString;
- published
- property DisplayValue: TBlobDisplayValue read FDisplayValue write SetDisplayValue default dvClass;
- 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;
- TDataSetField = class(TField)
- private
- FNestedDataSet: TDataSet;
- procedure AssignNestedDataSet(Value: TDataSet);
- protected
- procedure Bind(Binding: Boolean); override;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- end;
- { TIndexDef }
- TIndexDefs = class;
- TIndexOption = (ixPrimary, ixUnique, ixDescending, ixCaseInsensitive,
- ixExpression, ixNonMaintained);
- TIndexOptions = set of TIndexOption;
- TIndexDef = class(TNamedItem)
- Private
- FCaseinsFields: string;
- FDescFields: string;
- FExpression : String;
- FFields : String;
- FOptions : TIndexOptions;
- FSource : String;
- protected
- function GetExpression: string;
- procedure SetCaseInsFields(const AValue: string); virtual;
- procedure SetDescFields(const AValue: string);
- procedure SetExpression(const AValue: string);
- public
- constructor Create(Owner: TIndexDefs; const AName, TheFields: string;
- TheOptions: TIndexOptions); overload;
- procedure Assign(Source: TPersistent); override;
- published
- property Expression: string read GetExpression write SetExpression;
- property Fields: string read FFields write FFields;
- property CaseInsFields: string read FCaseinsFields write SetCaseInsFields;
- property DescFields: string read FDescFields write SetDescFields;
- property Options: TIndexOptions read FOptions write FOptions;
- property Source: string read FSource write FSource;
- end;
- TIndexDefClass = class of TIndexDef;
- { TIndexDefs }
- TIndexDefs = class(TDefCollection)
- Private
- Function GetItem(Index: Integer): TIndexDef; reintroduce;
- Procedure SetItem(Index: Integer; Value: TIndexDef); reintroduce;
- public
- constructor Create(ADataSet: TDataSet); virtual; overload;
- procedure Add(const Name, Fields: string; Options: TIndexOptions); reintroduce;
- Function AddIndexDef: TIndexDef;
- function Find(const IndexName: string): TIndexDef; reintroduce;
- function FindIndexForFields(const Fields{%H-}: string): TIndexDef;
- function GetIndexForFields(const Fields: string;
- CaseInsensitive: Boolean): TIndexDef;
- procedure Update; overload; virtual;
- Property Items[Index: Integer] : TIndexDef read GetItem write SetItem; default;
- end;
- { TCheckConstraint }
- TCheckConstraint = class(TCollectionItem)
- Private
- FCustomConstraint : String;
- FErrorMessage : String;
- FFromDictionary : Boolean;
- FImportedConstraint : String;
- public
- procedure Assign(Source{%H-}: TPersistent); override;
- // function GetDisplayName: string; override;
- published
- property CustomConstraint: string read FCustomConstraint write FCustomConstraint;
- property ErrorMessage: string read FErrorMessage write FErrorMessage;
- property FromDictionary: Boolean read FFromDictionary write FFromDictionary;
- property ImportedConstraint: string read FImportedConstraint write FImportedConstraint;
- end;
- { TCheckConstraints }
- TCheckConstraints = class(TCollection)
- Private
- Function GetItem(Index{%H-} : Longint) : TCheckConstraint; reintroduce;
- Procedure SetItem(index{%H-} : Longint; Value{%H-} : TCheckConstraint); reintroduce;
- protected
- function GetOwner: TPersistent; override;
- public
- constructor Create(AOwner{%H-}: TPersistent); reintroduce;
- function Add: TCheckConstraint; reintroduce;
- property Items[Index: Longint]: TCheckConstraint read GetItem write SetItem; default;
- end;
- { TFieldsEnumerator }
- TFieldsEnumerator = class
- private
- FPosition: Integer;
- FFields: TFields;
- function GetCurrent: TField;
- public
- constructor Create(AFields: TFields); reintroduce;
- function MoveNext: Boolean;
- property Current: TField read GetCurrent;
- end;
- { TFields }
- TFields = Class(TObject)
- Private
- FDataset : TDataset;
- FFieldList : TFpList;
- FOnChange : TNotifyEvent;
- FValidFieldKinds : TFieldKinds;
- Protected
- Procedure ClearFieldDefs;
- Procedure Changed;
- Procedure CheckfieldKind(Fieldkind : TFieldKind; Field : TField);
- Function GetCount : Longint;
- Function GetField (Index : Integer) : TField;
- Procedure SetField(Index: Integer; Value: TField);
- Procedure SetFieldIndex (Field : TField;Value : Integer);
- Property OnChange : TNotifyEvent Read FOnChange Write FOnChange;
- Property ValidFieldKinds : TFieldKinds Read FValidFieldKinds;
- Public
- Constructor Create(ADataset : TDataset); reintroduce;
- Destructor Destroy;override;
- Procedure Add(Field : TField);
- Procedure CheckFieldName (Const Value : String);
- Procedure CheckFieldNames (Const Value : String);
- Procedure Clear;
- Function FindField (Const Value : String) : TField;
- Function FieldByName (Const Value : String) : TField;
- Function FieldByNumber(FieldNo : Integer) : TField;
- Function GetEnumerator: TFieldsEnumerator;
- Procedure GetFieldNames (Values : TStrings);
- Function IndexOf(Field : TField) : Longint;
- procedure Remove(Value : TField);
- Property Count : Integer Read GetCount;
- Property Dataset : TDataset Read FDataset;
- Property Fields [Index : Integer] : TField Read GetField Write SetField; default;
- end;
- TFieldsClass = Class of TFields;
- { TParam }
- TBlobData = TBytes; // Delphi defines it as alias to TBytes
- TParamBinding = array of integer;
- TParamType = (ptUnknown, ptInput, ptOutput, ptInputOutput, ptResult);
- TParamTypes = set of TParamType;
- TParamStyle = (psInterbase,psPostgreSQL,psSimulated);
- TParams = class;
- TParam = class(TCollectionItem)
- private
- FValue: JSValue;
- FPrecision: Integer;
- FNumericScale: Integer;
- FName: string;
- FDataType: TFieldType;
- FBound: Boolean;
- FParamType: TParamType;
- FSize: Integer;
- Function GetDataSet: TDataSet;
- Function IsParamStored: Boolean;
- protected
- Procedure AssignParam(Param: TParam);
- Procedure AssignTo(Dest: TPersistent); override;
- Function GetAsBoolean: Boolean;
- Function GetAsBytes: TBytes;
- Function GetAsDateTime: TDateTime;
- Function GetAsFloat: Double;
- Function GetAsInteger: Longint;
- Function GetAsLargeInt: NativeInt;
- Function GetAsMemo: string;
- Function GetAsString: string;
- Function GetAsJSValue: JSValue;
- Function GetDisplayName: string; override;
- Function GetIsNull: Boolean;
- Function IsEqual(AValue: TParam): Boolean;
- Procedure SetAsBlob(const AValue: TBlobData);
- Procedure SetAsBoolean(AValue: Boolean);
- Procedure SetAsBytes(const AValue{%H-}: TBytes);
- Procedure SetAsDate(const AValue: TDateTime);
- Procedure SetAsDateTime(const AValue: TDateTime);
- Procedure SetAsFloat(const AValue: Double);
- Procedure SetAsInteger(AValue: Longint);
- Procedure SetAsLargeInt(AValue: NativeInt);
- Procedure SetAsMemo(const AValue: string);
- Procedure SetAsString(const AValue: string);
- Procedure SetAsTime(const AValue: TDateTime);
- Procedure SetAsJSValue(const AValue: JSValue);
- Procedure SetDataType(AValue: TFieldType);
- Procedure SetText(const AValue: string);
- public
- constructor Create(ACollection: TCollection); overload; override;
- constructor Create(AParams: TParams; AParamType: TParamType); reintroduce; overload;
- Procedure Assign(Source: TPersistent); override;
- Procedure AssignField(Field: TField);
- Procedure AssignToField(Field: TField);
- Procedure AssignFieldValue(Field: TField; const AValue: JSValue);
- Procedure AssignFromField(Field : TField);
- Procedure Clear;
- Property AsBlob : TBlobData read GetAsBytes write SetAsBytes;
- Property AsBoolean : Boolean read GetAsBoolean write SetAsBoolean;
- Property AsBytes : TBytes read GetAsBytes write SetAsBytes;
- Property AsDate : TDateTime read GetAsDateTime write SetAsDate;
- Property AsDateTime : TDateTime read GetAsDateTime write SetAsDateTime;
- Property AsFloat : Double read GetAsFloat write SetAsFloat;
- Property AsInteger : LongInt read GetAsInteger write SetAsInteger;
- Property AsLargeInt : NativeInt read GetAsLargeInt write SetAsLargeInt;
- Property AsMemo : string read GetAsMemo write SetAsMemo;
- Property AsSmallInt : LongInt read GetAsInteger write SetAsInteger;
- Property AsString : string read GetAsString write SetAsString;
- Property AsTime : TDateTime read GetAsDateTime write SetAsTime;
- Property Bound : Boolean read FBound write FBound;
- Property Dataset : TDataset Read GetDataset;
- Property IsNull : Boolean read GetIsNull;
- Property Text : string read GetAsString write SetText;
- published
- Property DataType : TFieldType read FDataType write SetDataType;
- Property Name : string read FName write FName;
- Property NumericScale : Integer read FNumericScale write FNumericScale default 0;
- Property ParamType : TParamType read FParamType write FParamType;
- Property Precision : Integer read FPrecision write FPrecision default 0;
- Property Size : Integer read FSize write FSize default 0;
- Property Value : JSValue read GetAsJSValue write SetAsJSValue stored IsParamStored;
- end;
- TParamClass = Class of TParam;
- { TParams }
- TParams = class(TCollection)
- private
- FOwner: TPersistent;
- Function GetItem(Index: Integer): TParam; reintroduce;
- Function GetParamValue(const ParamName: string): JSValue;
- Procedure SetItem(Index: Integer; Value: TParam); reintroduce;
- Procedure SetParamValue(const ParamName: string; const Value: JSValue);
- protected
- Procedure AssignTo(Dest: TPersistent); override;
- Function GetDataSet: TDataSet;
- Function GetOwner: TPersistent; override;
- Class Function ParamClass : TParamClass; virtual;
- public
- Constructor Create(AOwner: TPersistent; AItemClass : TCollectionItemClass); overload;
- Constructor Create(AOwner: TPersistent); overload;
- Constructor Create; overload; reintroduce;
- Procedure AddParam(Value: TParam);
- Procedure AssignValues(Value: TParams);
- Function CreateParam(FldType: TFieldType; const ParamName: string; ParamType: TParamType): TParam;
- Function FindParam(const Value: string): TParam;
- Procedure GetParamList(List: TList; const ParamNames: string);
- Function IsEqual(Value: TParams): Boolean;
- Function ParamByName(const Value: string): TParam;
- Function ParseSQL(SQL: String; DoCreate: Boolean): String; overload;
- Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle): String; overload;
- Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding): String; overload;
- Function ParseSQL(SQL: String; DoCreate, EscapeSlash, EscapeRepeat : Boolean; ParameterStyle : TParamStyle; out ParamBinding: TParambinding; out ReplaceString : string): String; overload;
- Procedure RemoveParam(Value: TParam);
- Procedure CopyParamValuesFromDataset(ADataset : TDataset; CopyBound : Boolean);
- Property Dataset : TDataset Read GetDataset;
- Property Items[Index: Integer] : TParam read GetItem write SetItem; default;
- Property ParamValues[const ParamName: string] : JSValue read GetParamValue write SetParamValue;
- end;
- { TDataSet }
- TBookmarkFlag = (bfCurrent, bfBOF, bfEOF, bfInserted);
- TBookmark = record
- Data : JSValue;
- Flag : TBookmarkFlag;
- end; // Bookmark is always the index in the data array.
- TBookmarkStr = string; // JSON encoded version of the above
- TGetMode = (gmCurrent, gmNext, gmPrior);
- TGetResult = (grOK, grBOF, grEOF, grError);
- TResyncMode = set of (rmExact, rmCenter);
- TDataAction = (daFail, daAbort, daRetry);
- TUpdateAction = (uaFail, uaAbort, uaSkip, uaRetry, uaApplied);
- TUpdateKind = (ukModify, ukInsert, ukDelete);
- TLocateOption = (loCaseInsensitive, loPartialKey, loFromCurrent);
- 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,loCancelPending);
- 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;
- ResolveStatus : TResolveStatus;
- 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;
- TNestedDataSetsList = TFPList;
- {------------------------------------------------------------------------------}
- TDataSet = class(TComponent)
- Private
- FAfterApplyUpdates: TApplyUpdatesEvent;
- FAfterLoad: TDatasetNotifyEvent;
- FBeforeApplyUpdates: TDatasetNotifyEvent;
- FBeforeLoad: TDatasetNotifyEvent;
- FBlockReadSize: Integer;
- FCalcBuffer: TDataRecord;
- FCalcFieldsCount: Longint;
- FOnLoadFail: TDatasetLoadFailEvent;
- FOnRecordResolved: TOnRecordResolveEvent;
- FOpenAfterRead : boolean;
- FActiveRecord: Longint;
- FAfterCancel: TDataSetNotifyEvent;
- FAfterClose: TDataSetNotifyEvent;
- FAfterDelete: TDataSetNotifyEvent;
- FAfterEdit: TDataSetNotifyEvent;
- FAfterInsert: TDataSetNotifyEvent;
- FAfterOpen: TDataSetNotifyEvent;
- FAfterPost: TDataSetNotifyEvent;
- FAfterRefresh: TDataSetNotifyEvent;
- FAfterScroll: TDataSetNotifyEvent;
- FAutoCalcFields: Boolean;
- FBOF: Boolean;
- FBeforeCancel: TDataSetNotifyEvent;
- FBeforeClose: TDataSetNotifyEvent;
- FBeforeDelete: TDataSetNotifyEvent;
- FBeforeEdit: TDataSetNotifyEvent;
- FBeforeInsert: TDataSetNotifyEvent;
- FBeforeOpen: TDataSetNotifyEvent;
- FBeforePost: TDataSetNotifyEvent;
- FBeforeRefresh: TDataSetNotifyEvent;
- FBeforeScroll: TDataSetNotifyEvent;
- FBlobFieldCount: Longint;
- FBuffers : TBuffers;
- // The actual length of FBuffers is FBufferCount+1
- FBufferCount: Longint;
- FConstraints: TCheckConstraints;
- FDisableControlsCount : Integer;
- FDisableControlsState : TDatasetState;
- FCurrentRecord: Longint;
- FDataSources : TFPList;
- FDefaultFields: Boolean;
- FEOF: Boolean;
- FEnableControlsEvent : TDataEvent;
- FFieldList : TFields;
- FFieldDefs: TFieldDefs;
- FFilterOptions: TFilterOptions;
- FFilterText: string;
- FFiltered: Boolean;
- FFound: Boolean;
- FInternalCalcFields: Boolean;
- FModified: Boolean;
- FOnCalcFields: TDataSetNotifyEvent;
- FOnDeleteError: TDataSetErrorEvent;
- FOnEditError: TDataSetErrorEvent;
- FOnFilterRecord: TFilterRecordEvent;
- FOnNewRecord: TDataSetNotifyEvent;
- FOnPostError: TDataSetErrorEvent;
- FRecordCount: Longint;
- FIsUniDirectional: Boolean;
- FState : TDataSetState;
- FInternalOpenComplete: Boolean;
- FDataProxy : TDataProxy;
- FDataRequestID : Integer;
- FUpdateBatchID : Integer;
- FChangeList : TFPList;
- FBatchList : TFPList;
- FInApplyupdates : Boolean;
- FLoadCount : Integer;
- FMinLoadID : Integer;
- FDataSetField: TDataSetField;
- FNestedDataSets: TNestedDataSetsList;
- FNestedDataSetClass: TDataSetClass;
- Procedure DoInsertAppend(DoAppend : Boolean);
- Procedure DoInternalOpen;
- Function GetBuffer (Index : longint) : TDataRecord;
- function GetDataProxy: TDataProxy;
- function GetIsLoading: Boolean;
- 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);
- function GetNestedDataSets: TNestedDataSetsList;
- 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;
- procedure ResetUpdateDescriptors;
- Function IndexInChangeList(aBookmark: TBookmark): Integer; virtual;
- Function AddToChangeList(aChange : TUpdateStatus) : TRecordUpdateDescriptor ; virtual;
- Procedure RemoveFromChangeList(R : TRecordUpdateDescriptor); virtual;
- Procedure DoApplyUpdates;
- procedure RecalcBufListSize;
- procedure ActivateBuffers; virtual;
- procedure BindFields(Binding: Boolean);
- procedure BlockReadNext; virtual;
- function BookmarkAvailable: Boolean;
- procedure CalculateFields(Var Buffer: TDataRecord); virtual;
- procedure CheckActive; virtual;
- procedure CheckInactive; virtual;
- procedure CheckBiDirectional;
- procedure Loaded; override;
- procedure ClearBuffers; virtual;
- procedure ClearCalcFields(var Buffer{%H-}: TDataRecord); virtual;
- procedure CloseBlob(Field{%H-}: TField); virtual;
- procedure CloseCursor; virtual;
- procedure CreateFields; virtual;
- procedure DataEvent(Event: TDataEvent; Info: JSValue); virtual;
- procedure DestroyFields; virtual;
- procedure DoAfterCancel; virtual;
- procedure DoAfterClose; virtual;
- procedure DoAfterDelete; virtual;
- procedure DoAfterEdit; virtual;
- procedure DoAfterInsert; virtual;
- procedure DoAfterOpen; virtual;
- procedure DoAfterPost; virtual;
- procedure DoAfterScroll; virtual;
- procedure DoAfterRefresh; virtual;
- procedure DoBeforeCancel; virtual;
- procedure DoBeforeClose; virtual;
- procedure DoBeforeDelete; virtual;
- procedure DoBeforeEdit; virtual;
- procedure DoBeforeInsert; virtual;
- procedure DoBeforeOpen; virtual;
- procedure DoBeforePost; virtual;
- procedure DoBeforeScroll; virtual;
- procedure DoBeforeRefresh; virtual;
- procedure DoOnCalcFields; virtual;
- procedure DoOnNewRecord; virtual;
- procedure DoBeforeLoad; virtual;
- procedure DoAfterLoad; virtual;
- procedure DoBeforeApplyUpdates; virtual;
- procedure DoAfterApplyUpdates(const ResolveInfo: TResolveResults); virtual;
- function FieldByNumber(FieldNo: Longint): TField;
- function FindRecord(Restart{%H-}, GoForward{%H-}: Boolean): Boolean; virtual;
- function GetBookmarkStr: TBookmarkStr; virtual;
- procedure GetCalcFields(Var Buffer: TDataRecord); virtual;
- function GetCanModify: Boolean; virtual;
- procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
- function GetFieldClass(FieldType: TFieldType): TFieldClass; virtual;
- Function GetfieldCount : Integer;
- function GetFieldValues(const FieldName : string) : JSValue; virtual;
- function GetIsIndexField(Field{%H-}: TField): Boolean; virtual;
- function GetIndexDefs(IndexDefs : TIndexDefs; IndexTypes : TIndexOptions) : TIndexDefs;
- function GetNextRecords: Longint; virtual;
- function GetNextRecord: Boolean; virtual;
- function GetPriorRecords: Longint; virtual;
- function GetPriorRecord: Boolean; virtual;
- function GetRecordCount: Longint; virtual;
- function GetRecNo: Longint; virtual;
- procedure InitFieldDefs; virtual;
- procedure InitFieldDefsFromfields;
- procedure InitRecord(var Buffer: TDataRecord); virtual;
- procedure InternalCancel; virtual;
- procedure InternalEdit; virtual;
- procedure InternalInsert; virtual;
- procedure InternalRefresh; virtual;
- procedure OpenCursor(InfoQuery: Boolean); virtual;
- procedure OpenCursorcomplete; virtual;
- procedure RefreshInternalCalcFields(Var Buffer{%H-}: TDataRecord); virtual;
- procedure RestoreState(const Value: TDataSetState);
- Procedure SetActive (Value : Boolean); virtual;
- procedure SetBookmarkStr(const Value: TBookmarkStr); virtual;
- procedure SetBufListSize(Value: Longint); virtual;
- procedure SetChildOrder(Child: TComponent; Order: Longint); override;
- procedure SetCurrentRecord(Index: Longint); virtual;
- procedure SetDefaultFields(const Value: Boolean);
- procedure SetFiltered(Value: Boolean); virtual;
- procedure SetFilterOptions(Value: TFilterOptions); virtual;
- procedure SetFilterText(const Value: string); virtual;
- procedure SetFieldValues(const FieldName: string; Value: JSValue); virtual;
- procedure SetFound(const Value: Boolean); virtual;
- procedure SetModified(Value: Boolean);
- procedure SetName(const NewName: TComponentName); override;
- procedure SetOnFilterRecord(const Value: TFilterRecordEvent); virtual;
- procedure SetRecNo(Value{%H-}: Longint); virtual;
- procedure SetState(Value: TDataSetState);
- function SetTempState(const Value: TDataSetState): TDataSetState;
- Function TempBuffer: TDataRecord;
- procedure UpdateIndexDefs; virtual;
- property ActiveRecord: Longint read FActiveRecord;
- property CurrentRecord: Longint read FCurrentRecord;
- property BlobFieldCount: Longint read FBlobFieldCount;
- property Buffers[Index: Longint]: TDataRecord read GetBuffer;
- property BufferCount: Longint read FBufferCount;
- property CalcBuffer: TDataRecord read FCalcBuffer;
- property CalcFieldsCount: Longint read FCalcFieldsCount;
- property InternalCalcFields: Boolean read FInternalCalcFields;
- property Constraints: TCheckConstraints read FConstraints write SetConstraints;
- function AllocRecordBuffer: TDataRecord; virtual;
- procedure FreeRecordBuffer(var Buffer{%H-}: TDataRecord); virtual;
- procedure GetBookmarkData(Buffer{%H-}: TDataRecord; var Data{%H-}: TBookmark); virtual;
- function GetBookmarkFlag(Buffer{%H-}: TDataRecord): TBookmarkFlag; virtual;
- function GetDataSource: TDataSource; virtual;
- function GetRecordSize: Word; virtual;
- procedure InternalAddRecord(Buffer{%H-}: Pointer; AAppend{%H-}: Boolean); virtual;
- procedure InternalDelete; virtual;
- procedure InternalFirst; virtual;
- procedure InternalGotoBookmark(ABookmark{%H-}: TBookmark); virtual;
- procedure InternalHandleException(E: Exception); virtual;
- procedure InternalInitRecord(var Buffer{%H-}: TDataRecord); virtual;
- procedure InternalLast; virtual;
- procedure InternalPost; virtual;
- procedure InternalSetToRecord(Buffer{%H-}: TDataRecord); virtual;
- procedure SetBookmarkFlag(Var Buffer{%H-}: TDataRecord; Value{%H-}: TBookmarkFlag); virtual;
- procedure SetBookmarkData(Var Buffer{%H-}: TDataRecord; Data{%H-}: TBookmark); virtual;
- procedure SetUniDirectional(const Value: Boolean);
- procedure Notification(AComponent: TComponent; Operation: TOperation); override;
- procedure SetDataSetField(const Value: TDataSetField); virtual;
- // 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;
- property NestedDataSets: TNestedDataSetsList read GetNestedDataSets;
- 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;
- Property LoadCount : Integer Read FLoadCount;
- 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(aField : TField; aValue : JSValue; ARaiseException : Boolean) : TDateTime; virtual;
- function ConvertDateTimeToNative(aField : TField; aValue : TDateTime) : JSValue; virtual;
- Class function DefaultConvertToDateTime(aField : TField; aValue : JSValue; ARaiseException{%H-} : Boolean) : TDateTime; virtual;
- Class function DefaultConvertDateTimeToNative(aField : TField; aValue : TDateTime) : JSValue; virtual;
- Function BlobDataToBytes(aValue : JSValue) : TBytes; virtual;
- Class Function DefaultBlobDataToBytes(aValue : JSValue) : TBytes; virtual;
- Function BytesToBlobData(aValue : TBytes) : JSValue ; virtual;
- Class Function DefaultBytesToBlobData(aValue : TBytes) : JSValue; virtual;
- procedure Cancel; virtual;
- procedure CheckBrowseMode;
- procedure ClearFields;
- procedure Close;
- Procedure ApplyUpdates;
- function ControlsDisabled: Boolean;
- function CompareBookmarks(Bookmark1{%H-}, Bookmark2{%H-}: TBookmark): Longint; virtual;
- procedure CursorPosChanged;
- procedure Delete; virtual;
- procedure DisableControls;
- procedure Edit;
- procedure EnableControls;
- function FieldByName(const FieldName: string): TField;
- function FindField(const FieldName: string): TField;
- function FindFirst: Boolean; virtual;
- function FindLast: Boolean; virtual;
- function FindNext: Boolean; virtual;
- function FindPrior: Boolean; virtual;
- procedure First;
- procedure FreeBookmark(ABookmark{%H-}: TBookmark); virtual;
- function GetBookmark: TBookmark; virtual;
- function GetCurrentRecord(Buffer{%H-}: TDataRecord): Boolean; virtual;
- procedure GetFieldList(List: TList; const FieldNames: string); overload;
- procedure GetFieldList(List: TFPList; const FieldNames: string); overload;
- procedure GetFieldNames(List: TStrings);
- procedure GotoBookmark(const ABookmark: TBookmark);
- procedure Insert; reintroduce;
- procedure InsertRecord(const Values: array of JSValue);
- function IsEmpty: Boolean;
- function IsLinkedTo(ADataSource: TDataSource): Boolean;
- function IsSequenced: Boolean; virtual;
- procedure Last;
- Function Load(aOptions : TLoadOptions; aAfterLoad : TDatasetLoadEvent) : Boolean;
- function Locate(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; Options{%H-}: TLocateOptions) : boolean; virtual;
- function Lookup(const KeyFields{%H-}: string; const KeyValues{%H-}: JSValue; const ResultFields{%H-}: string): JSValue; virtual;
- function MoveBy(Distance: Longint): Longint;
- procedure Next;
- procedure Open;
- procedure Post; virtual;
- procedure Prior;
- procedure Refresh;
- procedure Resync(Mode: TResyncMode); virtual;
- Procedure CancelLoading;
- procedure SetFields(const Values: array of JSValue);
- procedure UpdateCursorPos;
- procedure UpdateRecord;
- Function GetPendingUpdates : TResolveInfoArray;
- property DataSetField: TDataSetField read FDataSetField write SetDataSetField;
- Property Loading : Boolean Read GetIsLoading;
- 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[const 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;
- FResolveStatus: TResolveStatus;
- FResolveError: String;
- FServerData: JSValue;
- FStatus: TUpdateStatus;
- Protected
- Procedure SetResolveStatus(aValue : TResolveStatus); 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 FStatus; deprecated;
- Property Status : TUpdateStatus Read FStatus;
- Property ResolveStatus : TResolveStatus Read FResolveStatus;
- 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 Const); overload;
- Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const; 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 Const);
- begin
- Raise EDatabaseError.CreateFmt(Fmt,Args);
- end;
- Procedure DatabaseErrorFmt (Const Fmt : String; Const Args : Array Of Const;
- 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.SetResolveStatus(aValue: TResolveStatus);
- begin
- FResolveStatus:=AValue;
- end;
- procedure TRecordUpdateDescriptor.Reset;
- begin
- FResolveStatus:=rsUnresolved;
- 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;
- FProxy:=aProxy;
- end;
- procedure TRecordUpdateDescriptor.Resolve(aData: JSValue);
- begin
- SetResolveStatus(rsResolved);
- FServerData:=AData;
- end;
- procedure TRecordUpdateDescriptor.ResolveFailed(aError: String);
- begin
- SetResolveStatus(rsResolveFailed);
- FResolveError:=AError;
- end;
- { TDataRequest }
- procedure TDataRequest.DoAfterRequest;
- begin
- if Assigned(FAfterRequest) then
- FAfterRequest(Self);
- end;
- constructor TDataRequest.Create(aDataProxy : TDataProxy; aOptions: TLoadOptions; aAfterRequest: TDataRequestEvent; aAfterLoad: TDatasetLoadEvent);
- begin
- FDataProxy:=aDataProxy;
- FLoadOptions:=aOptions;
- FEvent:=aAfterLoad;
- FAfterRequest:=aAfterRequest;
- end;
- { TDataProxy }
- function TDataProxy.GetDataRequestClass: TDataRequestClass;
- begin
- Result:=TDataRequest;
- end;
- function TDataProxy.GetUpdateDescriptorClass: TRecordUpdateDescriptorClass;
- begin
- Result:=TRecordUpdateDescriptor;
- end;
- function TDataProxy.GetUpdateBatchClass: TRecordUpdateBatchClass;
- begin
- Result:=TRecordUpdateBatch;
- end;
- procedure TDataProxy.ResolveBatch(aBatch: TRecordUpdateBatch);
- begin
- try
- If Assigned(ABatch.FOnResolve) then
- ABatch.FOnResolve(Self,ABatch);
- finally
- aBatch.Free;
- end;
- end;
- function TDataProxy.GetDataRequest(aOptions: TLoadOptions; aAfterRequest : TDataRequestEvent; aAfterLoad: TDatasetLoadEvent): TDataRequest;
- begin
- Result:=GetDataRequestClass.Create(Self,aOptions,aAfterRequest,aAfterLoad);
- end;
- function TDataProxy.GetUpdateDescriptor(aDataset : TDataset; aBookmark: TBookMark; AData: JSValue; AStatus: TUpdateStatus): TRecordUpdateDescriptor;
- begin
- Result:=GetUpdateDescriptorClass.Create(Self,aDataset, aBookmark,AData,AStatus);
- end;
- function TDataProxy.GetRecordUpdateBatch(aBatchID: Integer; AList: TRecordUpdateDescriptorList; AOwnsList : Boolean = True): TRecordUpdateBatch;
- begin
- Result:=GetUpdateBatchClass.Create(aBatchID,AList,AOwnsList);
- end;
- { EUpdateError }
- constructor EUpdateError.Create(NativeError, Context : String;
- ErrCode, PrevError : integer; E: Exception);
- begin
- Inherited CreateFmt(NativeError,[Context]);
- FContext := Context;
- FErrorCode := ErrCode;
- FPreviousError := PrevError;
- FOriginalException := E;
- end;
- Destructor EUpdateError.Destroy;
- begin
- FOriginalException.Free;
- Inherited;
- end;
- { TNamedItem }
- function TNamedItem.GetDisplayName: string;
- begin
- Result := FName;
- end;
- procedure TNamedItem.SetDisplayName(const Value: string);
- Var TmpInd : Integer;
- begin
- if FName=Value then exit;
- if (Value <> '') and (Collection is TFieldDefs ) then
- begin
- TmpInd := (TDefCollection(Collection).IndexOf(Value));
- if (TmpInd >= 0) and (TmpInd <> Index) then
- DatabaseErrorFmt(SDuplicateName, [Value, Collection.ClassName]);
- end;
- FName:=Value;
- inherited SetDisplayName(Value);
- end;
- { TDefCollection }
- procedure TDefCollection.SetItemName(Item: TCollectionItem);
- Var
- N : TNamedItem;
- TN : String;
- begin
- N:=Item as TNamedItem;
- if N.Name = '' then
- begin
- TN:=Copy(ClassName, 2, 5) + IntToStr(N.ID+1);
- if assigned(Dataset) then
- TN:=Dataset.Name+TN;
- N.Name:=TN;
- end
- else
- inherited SetItemName(Item);
- end;
- constructor TDefCollection.create(ADataset: TDataset; AOwner: TPersistent;
- AClass: TCollectionItemClass);
- begin
- inherited Create(AOwner,AClass);
- FDataset := ADataset;
- end;
- function TDefCollection.Find(const AName: string): TNamedItem;
- var i: integer;
- begin
- Result := Nil;
- for i := 0 to Count - 1 do
- if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
- begin
- Result := TNamedItem(Items[i]);
- Break;
- end;
- end;
- procedure TDefCollection.GetItemNames(List: TStrings);
- var i: LongInt;
- begin
- for i := 0 to Count - 1 do
- List.Add(TNamedItem(Items[i]).Name);
- end;
- function TDefCollection.IndexOf(const AName: string): Longint;
- var i: LongInt;
- begin
- Result := -1;
- for i := 0 to Count - 1 do
- if AnsiSameText(TNamedItem(Items[i]).Name, AName) then
- begin
- Result := i;
- Break;
- end;
- end;
- { TIndexDef }
- procedure TIndexDef.SetDescFields(const AValue: string);
- begin
- if FDescFields=AValue then exit;
- if AValue <> '' then FOptions:=FOptions + [ixDescending];
- FDescFields:=AValue;
- end;
- procedure TIndexDef.Assign(Source: TPersistent);
- var idef : TIndexDef;
- begin
- idef := nil;
- if Source is TIndexDef then
- idef := Source as TIndexDef;
- if Assigned(idef) then
- begin
- FName := idef.Name;
- FFields := idef.Fields;
- FOptions := idef.Options;
- FCaseinsFields := idef.CaseInsFields;
- FDescFields := idef.DescFields;
- FSource := idef.Source;
- FExpression := idef.Expression;
- end
- else
- inherited Assign(Source);
- end;
- function TIndexDef.GetExpression: string;
- begin
- Result := FExpression;
- end;
- procedure TIndexDef.SetExpression(const AValue: string);
- begin
- FExpression := AValue;
- end;
- procedure TIndexDef.SetCaseInsFields(const AValue: string);
- begin
- if FCaseinsFields=AValue then exit;
- if AValue <> '' then FOptions:=FOptions + [ixCaseInsensitive];
- FCaseinsFields:=AValue;
- end;
- constructor TIndexDef.Create(Owner: TIndexDefs; const AName, TheFields: string;
- TheOptions: TIndexOptions);
- begin
- FName := aname;
- inherited create(Owner);
- FFields := TheFields;
- FOptions := TheOptions;
- end;
- { TIndexDefs }
- Function TIndexDefs.GetItem (Index : integer) : TIndexDef;
- begin
- Result:=(Inherited GetItem(Index)) as TIndexDef;
- end;
- Procedure TIndexDefs.SetItem(Index: Integer; Value: TIndexDef);
- begin
- Inherited SetItem(Index,Value);
- end;
- constructor TIndexDefs.Create(ADataSet: TDataSet);
- begin
- inherited create(ADataset, Owner, TIndexDef);
- end;
- Function TIndexDefs.AddIndexDef: TIndexDef;
- begin
- // Result := inherited add as TIndexDef;
- Result:=TIndexDefClass(Self.ItemClass).Create(Self,'','',[]);
- end;
- procedure TIndexDefs.Add(const Name, Fields: string; Options: TIndexOptions);
- begin
- TIndexDefClass(Self.ItemClass).Create(Self,Name,Fields,Options);
- end;
- function TIndexDefs.Find(const IndexName: string): TIndexDef;
- begin
- Result := (inherited Find(IndexName)) as TIndexDef;
- if (Result=Nil) Then
- DatabaseErrorFmt(SIndexNotFound, [IndexName], FDataSet);
- end;
- function TIndexDefs.FindIndexForFields(const Fields: string): TIndexDef;
- begin
- //!! To be implemented
- Result:=nil;
- end;
- function TIndexDefs.GetIndexForFields(const Fields: string;
- CaseInsensitive: Boolean): TIndexDef;
- var
- i, FieldsLen: integer;
- Last: TIndexDef;
- begin
- Last := nil;
- FieldsLen := Length(Fields);
- for i := 0 to Count - 1 do
- begin
- Result := Items[I];
- if (Result.Options * [ixDescending, ixExpression] = []) and
- (not CaseInsensitive or (ixCaseInsensitive in Result.Options)) and
- AnsiSameText(Fields, Result.Fields) then
- begin
- Exit;
- end else
- if AnsiSameText(Fields, Copy(Result.Fields, 1, FieldsLen)) and
- ((Length(Result.Fields) = FieldsLen) or
- (Result.Fields[FieldsLen + 1] = ';')) then
- begin
- if (Last = nil) or
- ((Last <> nil) And (Length(Last.Fields) > Length(Result.Fields))) then
- Last := Result;
- end;
- end;
- Result := Last;
- end;
- procedure TIndexDefs.Update;
- begin
- if (not updated) and assigned(Dataset) then
- begin
- Dataset.UpdateIndexDefs;
- updated := True;
- end;
- end;
- { TCheckConstraint }
- procedure TCheckConstraint.Assign(Source: TPersistent);
- begin
- //!! To be implemented
- end;
- { TCheckConstraints }
- Function TCheckConstraints.GetItem(Index : Longint) : TCheckConstraint;
- begin
- //!! To be implemented
- Result := nil;
- end;
- Procedure TCheckConstraints.SetItem(index : Longint; Value : TCheckConstraint);
- begin
- //!! To be implemented
- end;
- function TCheckConstraints.GetOwner: TPersistent;
- begin
- //!! To be implemented
- Result := nil;
- end;
- constructor TCheckConstraints.Create(AOwner: TPersistent);
- begin
- //!! To be implemented
- inherited Create(TCheckConstraint);
- end;
- function TCheckConstraints.Add: TCheckConstraint;
- begin
- //!! To be implemented
- Result := nil;
- end;
- { TLookupList }
- constructor TLookupList.Create;
- begin
- FList := TFPList.Create;
- end;
- destructor TLookupList.Destroy;
- begin
- Clear;
- FList.Destroy;
- inherited Destroy;
- end;
- procedure TLookupList.Add(const AKey, AValue: JSValue);
- var LookupRec: TJSObject;
- begin
- LookupRec:=New(['Key',AKey,'Value',AValue]);
- FList.Add(LookupRec);
- end;
- procedure TLookupList.Clear;
- begin
- FList.Clear;
- end;
- function TLookupList.FirstKeyByValue(const AValue: JSValue): JSValue;
- var
- i: Integer;
- begin
- for i := 0 to FList.Count - 1 do
- with TJSObject(FList[i]) do
- if Properties['Value'] = AValue then
- begin
- Result := Properties['Key'];
- exit;
- end;
- Result := Null;
- end;
- function TLookupList.ValueOfKey(const AKey: JSValue): JSValue;
- Function VarArraySameValues(VarArray1,VarArray2 : TJSValueDynArray) : Boolean;
- // This only works for one-dimensional vararrays with a lower bound of 0
- // and equal higher bounds wich only contains JSValues.
- // The vararrays returned by GetFieldValues do apply.
- var i : integer;
- begin
- Result := True;
- if (Length(VarArray1)<>Length(VarArray2)) then
- exit;
- for i := 0 to Length(VarArray1) do
- begin
- if VarArray1[i]<>VarArray2[i] then
- begin
- Result := false;
- Exit;
- end;
- end;
- end;
- var I: Integer;
- begin
- Result := Null;
- if IsNull(AKey) then Exit;
- i := FList.Count - 1;
- if IsArray(AKey) then
- while (i >= 0) And not VarArraySameValues(TJSValueDynArray(TJSOBject(FList.Items[I]).Properties['Key']),TJSValueDynArray(AKey)) do Dec(i)
- else
- while (i >= 0) And (TJSObject(FList[I]).Properties['Key'] <> AKey) do Dec(i);
- if i >= 0 then Result := TJSObject(FList[I]).Properties['Value'];
- end;
- procedure TLookupList.ValuesToStrings(AStrings: TStrings);
- var
- i: Integer;
- p: TJSObject;
- begin
- AStrings.Clear;
- for i := 0 to FList.Count - 1 do
- begin
- p := TJSObject(FList[i]);
- AStrings.AddObject(String(p.properties['Value']), TObject(p));
- end;
- end;
- { ---------------------------------------------------------------------
- TDataSet
- ---------------------------------------------------------------------}
- Const
- DefaultBufferCount = 10;
- constructor TDataSet.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- FFieldDefs:=FieldDefsClass.Create(Self);
- FFieldList:=FieldsClass.Create(Self);
- FDataSources:=TFPList.Create;
- FConstraints:=TCheckConstraints.Create(Self);
- SetLength(FBuffers,1);
- FActiveRecord := 0;
- FEOF := True;
- FBOF := True;
- FIsUniDirectional := False;
- FAutoCalcFields := True;
- FDataRequestID:=0;
- FNestedDataSetClass := TDataSetClass(Self.ClassType);
- end;
- destructor TDataSet.Destroy;
- var
- i: Integer;
- begin
- Active:=False;
- SetDataSetField(nil);
- FFieldDefs.Free;
- FFieldList.Free;
- FNestedDataSets.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;
- begin
- FCalcBuffer := Buffer;
- if FState <> dsInternalCalc then
- begin
- ClearCalcFields(FCalcBuffer);
- if not IsUniDirectional then
- for i := 0 to FFieldList.Count - 1 do
- if FFieldList[i].FieldKind = fkLookup then
- FFieldList[i].CalcLookupValue;
- end;
- DoOnCalcFields;
- 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;
- var
- A: Integer;
- NestedDataSet: TDataSet;
- begin
- if State <> dsInsert then
- UpdateCursorPos;
- if Assigned(FNestedDataSets) then
- for A := 0 to Pred(NestedDataSets.Count) do
- begin
- NestedDataSet := TDataSet(NestedDataSets[A]);
- if NestedDataSet.Active then
- NestedDataSet.DataEvent(deParentScroll, 0);
- end;
- end;
- var
- i: Integer;
- begin
- case Event of
- deFieldChange : HandleFieldChange(TField(Info));
- deDataSetChange,
- deDataSetScroll : HandleScrollOrChange;
- deLayoutChange : FEnableControlsEvent:=deLayoutChange;
- end;
- if not ControlsDisabled and (FState <> dsBlockRead) then begin
- for i := 0 to FDataSources.Count - 1 do
- TDataSource(FDataSources[i]).ProcessEvent(Event, Info);
- end;
- end;
- procedure TDataSet.DestroyFields;
- begin
- FFieldList.Clear;
- end;
- procedure TDataSet.DoAfterCancel;
- begin
- If assigned(FAfterCancel) then
- FAfterCancel(Self);
- end;
- procedure TDataSet.DoAfterClose;
- begin
- If assigned(FAfterClose) and not (csDestroying in ComponentState) then
- FAfterClose(Self);
- end;
- procedure TDataSet.DoAfterDelete;
- begin
- If assigned(FAfterDelete) then
- FAfterDelete(Self);
- end;
- procedure TDataSet.DoAfterEdit;
- begin
- If assigned(FAfterEdit) then
- FAfterEdit(Self);
- end;
- procedure TDataSet.DoAfterInsert;
- begin
- If assigned(FAfterInsert) then
- FAfterInsert(Self);
- end;
- procedure TDataSet.DoAfterOpen;
- begin
- If assigned(FAfterOpen) then
- FAfterOpen(Self);
- end;
- procedure TDataSet.DoAfterPost;
- begin
- If assigned(FAfterPost) then
- FAfterPost(Self);
- end;
- procedure TDataSet.DoAfterScroll;
- begin
- If assigned(FAfterScroll) then
- FAfterScroll(Self);
- end;
- procedure TDataSet.DoAfterRefresh;
- begin
- If assigned(FAfterRefresh) then
- FAfterRefresh(Self);
- end;
- procedure TDataSet.DoBeforeCancel;
- begin
- If assigned(FBeforeCancel) then
- FBeforeCancel(Self);
- end;
- procedure TDataSet.DoBeforeClose;
- begin
- If assigned(FBeforeClose) and not (csDestroying in ComponentState) then
- FBeforeClose(Self);
- end;
- procedure TDataSet.DoBeforeDelete;
- begin
- If assigned(FBeforeDelete) then
- FBeforeDelete(Self);
- end;
- procedure TDataSet.DoBeforeEdit;
- begin
- If assigned(FBeforeEdit) then
- FBeforeEdit(Self);
- end;
- procedure TDataSet.DoBeforeInsert;
- begin
- If assigned(FBeforeInsert) then
- FBeforeInsert(Self);
- end;
- procedure TDataSet.DoBeforeOpen;
- begin
- If assigned(FBeforeOpen) then
- FBeforeOpen(Self);
- end;
- procedure TDataSet.DoBeforePost;
- begin
- If assigned(FBeforePost) then
- FBeforePost(Self);
- end;
- procedure TDataSet.DoBeforeScroll;
- begin
- If assigned(FBeforeScroll) then
- FBeforeScroll(Self);
- end;
- procedure TDataSet.DoBeforeRefresh;
- begin
- If assigned(FBeforeRefresh) then
- FBeforeRefresh(Self);
- end;
- procedure TDataSet.DoInternalOpen;
- begin
- InternalOpen;
- FInternalOpenComplete := True;
- {$ifdef dsdebug}
- Writeln ('Calling internal open');
- {$endif}
- {$ifdef dsdebug}
- Writeln ('Calling RecalcBufListSize');
- {$endif}
- FRecordCount := 0;
- RecalcBufListSize;
- FBOF := True;
- FEOF := (FRecordCount = 0);
- if Assigned(DataProxy) then
- InitChangeList;
- end;
- procedure TDataSet.DoOnCalcFields;
- begin
- If Assigned(FOnCalcfields) then
- FOnCalcFields(Self);
- end;
- procedure TDataSet.DoOnNewRecord;
- begin
- If assigned(FOnNewRecord) then
- FOnNewRecord(Self);
- end;
- procedure TDataSet.DoBeforeLoad;
- begin
- If Assigned(FBeforeLoad) then
- FBeforeLoad(Self);
- end;
- procedure TDataSet.DoAfterLoad;
- begin
- if Assigned(FAfterLoad) then
- FAfterLoad(Self);
- end;
- procedure TDataSet.DoBeforeApplyUpdates;
- begin
- If Assigned(FBeforeApplyUpdates) then
- FBeforeApplyUpdates(Self);
- end;
- procedure TDataSet.DoAfterApplyUpdates(const ResolveInfo: TResolveResults);
- begin
- If Assigned(FAfterApplyUpdates) then
- FAfterApplyUpdates(Self,ResolveInfo);
- end;
- function TDataSet.FieldByNumber(FieldNo: Longint): TField;
- begin
- Result:=FFieldList.FieldByNumber(FieldNo);
- end;
- function TDataSet.FindRecord(Restart, GoForward: Boolean): Boolean;
- begin
- //!! To be implemented
- Result:=false;
- end;
- function TDataSet.GetBookmarkStr: TBookmarkStr;
- Var
- B : TBookMark;
- begin
- Result:='';
- If BookMarkAvailable then
- begin
- GetBookMarkData(ActiveBuffer,B);
- Result:=TJSJSON.stringify(B);
- end
- end;
- function TDataSet.GetBuffer(Index: longint): TDataRecord;
- begin
- Result:=FBuffers[Index];
- end;
- function TDataSet.DoGetDataProxy: TDataProxy;
- begin
- Result:=nil;
- end;
- procedure TDataSet.InitChangeList;
- begin
- DoneChangeList;
- FChangeList:=TFPList.Create;
- end;
- procedure TDataSet.ClearChangeList;
- Var
- I : integer;
- begin
- If not Assigned(FChangeList) then
- exit;
- For I:=0 to FChangeList.Count-1 do
- begin
- TObject(FChangeList[i]).Destroy;
- FChangeList[i]:=Nil;
- end;
- end;
- procedure TDataSet.ResetUpdateDescriptors;
- Var
- I : Integer;
- begin
- For I:=0 to FChangeList.Count-1 do
- TRecordUpdateDescriptor(FChangeList[i]).Reset;
- 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
- if TRecordUpdateDescriptor(FChangeList[i]).ResolveStatus=rsUnResolved then
- 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.SetResolveStatus(rsResolveFailed);
- 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.ResolveStatus:=anUpdate.ResolveStatus;
- 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.ResolveStatus=rsResolved) then
- DoRemove:=ResolveRecordUpdate(RUD)
- else
- // What if not resolvable.. ?
- DoRemove:=(RUD.ResolveStatus=rsResolved);
- 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 FInApplyupdates then
- exit;
- try
- FInApplyupdates:=True;
- if Not (Assigned(FChangeList) and (FChangeList.Count>0)) then
- Exit;
- L:=TRecordUpdateDescriptorList.Create;
- try
- I:=GetRecordUpdates(L);
- except
- L.Free;
- Raise;
- end;
- Inc(FUpdateBatchID);
- For I:=0 to L.Count-1 do
- TRecordUpdateDescriptor(L[i]).SetResolveStatus(rsResolving);
- 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);
- Finally
- FInApplyupdates:=False;
- end;
- 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.GetIsLoading: Boolean;
- begin
- // Writeln(Name,' GetIsLoading Loadcount : ',LoadCount);
- Result:=(FLoadCount>0);
- 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;
- // Writeln(Name,' Check request response: ',ARequest.FRequestID,', min: ',FMinLoadID,' Loadcount:',FLoadCount);
- if ARequest.FRequestID<=FMinLoadID then
- begin
- ARequest.Destroy;
- Exit;
- end;
- Dec(FloadCount);
- // Writeln(Name,' Handle request response: ',ARequest.FRequestID,', min: ',FMinLoadID,' Loadcount:',FLoadCount);
- 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);
- var
- i: Integer;
- OldState: TDatasetState;
- begin
- if (FCalcFieldsCount > 0) or FInternalCalcFields then
- begin
- OldState := FState;
- FState := dsCalcFields;
- try
- CalculateFields(Buffer);
- finally
- FState := OldState;
- end;
- end;
- 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;
- procedure TDataSet.SetDataSetField(const Value: TDataSetField);
- begin
- if Value = FDataSetField then
- exit;
- if (Value <> nil) and ((Value.DataSet = Self) or
- ((Value.DataSet.GetDataSource <> nil) and
- (Value.DataSet.GetDataSource.DataSet = Self))) then
- DatabaseError(SCircularDataLink, Self);
- if Assigned(Value) and not InheritsFrom(Value.DataSet.FNestedDataSetClass) then
- DatabaseErrorFmt(SNestedDataSetClass, [Value.DataSet.FNestedDataSetClass.ClassName], Self);
- if Active then
- Close;
- if Assigned(FDataSetField) then
- FDataSetField.AssignNestedDataSet(nil);
- FDataSetField := Value;
- if Assigned(Value) then
- begin
- Value.AssignNestedDataSet(Self);
- if Value.DataSet.Active then
- Open;
- end;
- end;
- function TDataSet.GetNestedDataSets: TNestedDataSetsList;
- begin
- if not Assigned(FNestedDataSets) then
- FNestedDataSets := TNestedDataSetsList.Create;
- Result := FNestedDataSets;
- end;
- function TDataSet.GetFieldData(Field: TField; Buffer: TDatarecord): JSValue;
- begin
- Result:=TJSObject(buffer.data).Properties[Field.FieldName];
- if isUndefined(Result) then
- Result:=Null;
- 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);
- DoneChangeList;
- CloseCursor;
- DoAfterClose;
- FModified:=False;
- end
- end;
- procedure TDataSet.Loaded;
- begin
- inherited;
- try
- if FOpenAfterRead then SetActive(true);
- except
- on E : Exception do
- if csDesigning in Componentstate then
- InternalHandleException(E);
- else
- raise;
- end;
- end;
- procedure TDataSet.RecalcBufListSize;
- var
- i, j, ABufferCount: Integer;
- DataLink: TDataLink;
- begin
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size - check cursor');
- {$endif}
- If Not IsCursorOpen Then
- Exit;
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size');
- {$endif}
- if IsUniDirectional then
- ABufferCount := 1
- else
- ABufferCount := DefaultBufferCount;
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size, start count: ',ABufferCount);
- {$endif}
- for i := 0 to FDataSources.Count - 1 do
- for j := 0 to TDataSource(FDataSources[i]).DataLinks.Count - 1 do
- begin
- DataLink:=TDataLink(TDataSource(FDataSources[i]).DataLinks[j]);
- if ABufferCount<DataLink.BufferCount then
- ABufferCount:=DataLink.BufferCount;
- end;
- {$ifdef dsdebug}
- Writeln('Recalculating buffer list size, end count: ',ABufferCount);
- {$endif}
- If (FBufferCount=ABufferCount) Then
- exit;
- {$ifdef dsdebug}
- Writeln('Setting buffer list size');
- {$endif}
- SetBufListSize(ABufferCount);
- {$ifdef dsdebug}
- Writeln('Getting next buffers');
- {$endif}
- GetNextRecords;
- if (FRecordCount < FBufferCount) and not IsUniDirectional then
- begin
- FActiveRecord := FActiveRecord + GetPriorRecords;
- CursorPosChanged;
- end;
- {$Ifdef dsDebug}
- WriteLn(
- 'SetBufferCount: FActiveRecord=',FActiveRecord,
- ' FCurrentRecord=',FCurrentRecord,
- ' FBufferCount= ',FBufferCount,
- ' FRecordCount=',FRecordCount);
- {$Endif}
- end;
- procedure TDataSet.SetBookmarkStr(const Value: TBookmarkStr);
- Var
- O: TJSObject;
- B : TBookmark;
- begin
- O:=TJSJSON.parseObject(Value);
- B.Flag:=TBookmarkFlag(O.Properties['flag']);
- B.Data:=O.Properties['Index'];
- GotoBookMark(B)
- end;
- procedure TDataSet.SetBufListSize(Value: Longint);
- Var
- I : Integer;
- begin
- if Value < 0 then Value := 0;
- If Value=FBufferCount Then
- exit;
- // Less buffers, shift buffers.
- if value>FBufferCount then
- begin
- SetLength(FBuffers,Value+1); // FBuffers[FBufferCount] is used as a temp buffer
- For I:=FBufferCount to Value do
- FBuffers[i]:=AllocRecordBuffer;
- end
- else if value<FBufferCount then
- if (value>=0) and (FActiveRecord>Value-1) then
- begin
- for i := 0 to (FActiveRecord-Value) do
- ShiftBuffersBackward;
- FActiveRecord := Value -1;
- end;
- SetLength(FBuffers,Value+1); // FBuffers[FBufferCount] is used as a temp buffer
- FBufferCount:=Value;
- if FRecordCount > FBufferCount then
- FRecordCount := FBufferCount;
- end;
- procedure TDataSet.SetChildOrder(Child: TComponent; Order: Longint);
- var
- Field: TField;
- begin
- Field := Child as TField;
- if Fields.IndexOf(Field) >= 0 then
- Field.Index := Order;
- end;
- procedure TDataSet.SetCurrentRecord(Index: Longint);
- begin
- If FCurrentRecord<>Index then
- begin
- {$ifdef DSdebug}
- Writeln ('Setting current record to: ',index);
- {$endif}
- if not FIsUniDirectional then Case GetBookMarkFlag(FBuffers[Index]) of
- bfCurrent : InternalSetToRecord(FBuffers[Index]);
- bfBOF : InternalFirst;
- bfEOF : InternalLast;
- end;
- FCurrentRecord:=Index;
- end;
- end;
- procedure TDataSet.SetDefaultFields(const Value: Boolean);
- begin
- FDefaultFields := Value;
- end;
- procedure TDataSet.CheckBiDirectional;
- begin
- if FIsUniDirectional then DataBaseError(SUniDirectional,Self);
- end;
- procedure TDataSet.SetFilterOptions(Value: TFilterOptions);
- begin
- CheckBiDirectional;
- FFilterOptions := Value;
- end;
- procedure TDataSet.SetFilterText(const Value: string);
- begin
- FFilterText := value;
- end;
- procedure TDataSet.SetFiltered(Value: Boolean);
- begin
- if Value then CheckBiDirectional;
- FFiltered := value;
- end;
- procedure TDataSet.SetFound(const Value: Boolean);
- begin
- FFound := Value;
- end;
- procedure TDataSet.SetModified(Value: Boolean);
- begin
- FModified := value;
- end;
- procedure TDataSet.SetName(const NewName: TComponentName);
- function CheckName(const FieldName: string): string;
- var i,j: integer;
- begin
- Result := FieldName;
- i := 0;
- j := 0;
- while (i < Fields.Count) do begin
- if Result = Fields[i].FieldName then begin
- inc(j);
- Result := FieldName + IntToStr(j);
- end else Inc(i);
- end;
- end;
- var
- i: integer;
- nm: string;
- old: string;
- begin
- if Self.Name = NewName then Exit;
- old := Self.Name;
- inherited SetName(NewName);
- if (csDesigning in ComponentState) then
- for i := 0 to Fields.Count - 1 do begin
- nm := old + Fields[i].FieldName;
- if Copy(Fields[i].Name, 1, Length(nm)) = nm then
- Fields[i].Name := CheckName(NewName + Fields[i].FieldName);
- end;
- end;
- procedure TDataSet.SetOnFilterRecord(const Value: TFilterRecordEvent);
- begin
- CheckBiDirectional;
- FOnFilterRecord := Value;
- end;
- procedure TDataSet.SetRecNo(Value: Longint);
- begin
- //!! To be implemented
- end;
- procedure TDataSet.SetState(Value: TDataSetState);
- begin
- If Value<>FState then
- begin
- FState:=Value;
- if Value=dsBrowse then
- FModified:=false;
- DataEvent(deUpdateState,0);
- end;
- end;
- function TDataSet.TempBuffer: TDataRecord;
- begin
- Result := FBuffers[FRecordCount];
- end;
- procedure TDataSet.UpdateIndexDefs;
- begin
- // Empty Abstract
- end;
- function TDataSet.AllocRecordBuffer: TDataRecord;
- begin
- Result.data:=Null;
- Result.state:=rsNew;
- // Result := nil;
- end;
- procedure TDataSet.FreeRecordBuffer(var Buffer: TDataRecord);
- begin
- // empty stub
- end;
- procedure TDataSet.GetBookmarkData(Buffer: TDataRecord; var Data: TBookmark);
- begin
- end;
- function TDataSet.GetBookmarkFlag(Buffer: TDataRecord): TBookmarkFlag;
- begin
- Result := bfCurrent;
- end;
- function TDataSet.ControlsDisabled: Boolean;
- begin
- Result := (FDisableControlsCount > 0);
- end;
- function TDataSet.ActiveBuffer: TDataRecord;
- begin
- {$ifdef dsdebug}
- Writeln ('Active buffer requested. Returning record number: ',ActiveRecord);
- {$endif}
- if FactiveRecord<>-1 then
- Result:=FBuffers[FActiveRecord]
- else
- Result:=Default(TDataRecord);
- 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(aField: TField; aValue: JSValue; ARaiseException: Boolean): TDateTime;
- begin
- Result:=DefaultConvertToDateTime(aField,aValue,ARaiseException);
- end;
- class function TDataSet.DefaultConvertToDateTime(aField: TField; 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)
- else if IsDate(aValue) then
- Result:=JSDateToDateTime(TJSDate(aValue));
- end;
- function TDataSet.ConvertDateTimeToNative(aField: TField; aValue : TDateTime) : JSValue;
- begin
- Result:=DefaultConvertDateTimeToNative(aField, aValue);
- end;
- class function TDataSet.DefaultConvertDateTimeToNative(aField: TField; 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)-1 do
- S:=TJSString(S).Concat(IntToHex(aValue[i],2));
- Result:=S;
- end;
- end;
- procedure TDataSet.Cancel;
- begin
- If State in [dsEdit,dsInsert] then
- begin
- DataEvent(deCheckBrowseMode,0);
- DoBeforeCancel;
- UpdateCursorPos;
- InternalCancel;
- if (State = dsInsert) and (FRecordCount = 1) then
- begin
- FEOF := true;
- FBOF := true;
- FRecordCount := 0;
- InitRecord(FBuffers[FActiveRecord]);
- SetState(dsBrowse);
- DataEvent(deDatasetChange,0);
- end
- else
- begin
- SetState(dsBrowse);
- SetCurrentRecord(FActiveRecord);
- resync([]);
- end;
- DoAfterCancel;
- end;
- end;
- procedure TDataSet.CheckBrowseMode;
- begin
- CheckActive;
- DataEvent(deCheckBrowseMode,0);
- Case State of
- dsEdit,dsInsert:
- begin
- UpdateRecord;
- If Modified then
- Post
- else
- Cancel;
- end;
- dsSetKey: Post;
- end;
- end;
- procedure TDataSet.ClearFields;
- begin
- DataEvent(deCheckBrowseMode, 0);
- InternalInitRecord(FBuffers[FActiveRecord]);
- if State <> dsSetKey then
- GetCalcFields(FBuffers[FActiveRecord]);
- DataEvent(deRecordChange, 0);
- end;
- procedure TDataSet.Close;
- begin
- Active:=False;
- end;
- procedure TDataSet.ApplyUpdates;
- begin
- DoBeforeApplyUpdates;
- DoApplyUpdates;
- end;
- function TDataSet.CompareBookmarks(Bookmark1, Bookmark2: TBookmark): Longint;
- begin
- Result:=0;
- end;
- procedure TDataSet.CursorPosChanged;
- begin
- FCurrentRecord:=-1;
- end;
- procedure TDataSet.Delete;
- Var
- R : TRecordUpdateDescriptor;
- begin
- If Not CanModify then
- DatabaseError(SDatasetReadOnly,Self);
- If IsEmpty then
- DatabaseError(SDatasetEmpty,Self);
- if State in [dsInsert] then
- begin
- Cancel;
- end else begin
- DataEvent(deCheckBrowseMode,0);
- {$ifdef dsdebug}
- writeln ('Delete: checking required fields');
- {$endif}
- DoBeforeDelete;
- DoBeforeScroll;
- R:=AddToChangeList(usDeleted);
- If Not TryDoing(@InternalDelete,OnDeleteError) then
- begin
- if Assigned(R) then
- RemoveFromChangeList(R);
- exit;
- end;
- {$ifdef dsdebug}
- writeln ('Delete: Internaldelete succeeded');
- {$endif}
- SetState(dsBrowse);
- {$ifdef dsdebug}
- writeln ('Delete: Browse mode set');
- {$endif}
- SetCurrentRecord(FActiveRecord);
- Resync([]);
- DoAfterDelete;
- DoAfterScroll;
- end;
- end;
- procedure TDataSet.DisableControls;
- begin
- If FDisableControlsCount=0 then
- begin
- { Save current state,
- needed to detect change of state when enabling controls.
- }
- FDisableControlsState:=FState;
- FEnableControlsEvent:=deDatasetChange;
- end;
- Inc(FDisableControlsCount);
- end;
- procedure TDataSet.DoInsertAppend(DoAppend: Boolean);
- procedure DoInsert(DoAppend : Boolean);
- Var
- BookBeforeInsert : TBookmark;
- TempBuf : TDataRecord;
- I : integer;
- begin
- // need to scroll up al buffers after current one,
- // but copy current bookmark to insert buffer.
- If FRecordCount > 0 then
- BookBeforeInsert:=Bookmark;
- if not DoAppend then
- begin
- if FRecordCount > 0 then
- begin
- TempBuf := FBuffers[FBufferCount];
- for I:=FBufferCount downto FActiveRecord+1 do
- FBuffers[I]:=FBuffers[I-1];
- FBuffers[FActiveRecord]:=TempBuf;
- end;
- end
- else if FRecordCount=FBufferCount then
- ShiftBuffersBackward
- else
- begin
- if FRecordCount>0 then
- inc(FActiveRecord);
- end;
- // Active buffer is now edit buffer. Initialize.
- InitRecord(FBuffers[FActiveRecord]);
- CursorPosChanged;
- // Put bookmark in edit buffer.
- if FRecordCount=0 then
- SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF)
- else
- begin
- fBOF := false;
- // 29:01:05, JvdS: Why is this here?!? It can result in records with the same bookmark-data?
- // I would say that the 'internalinsert' should do this. But I don't know how Tdbf handles it
- // 1-apr-06, JvdS: It just sets the bookmark of the newly inserted record to the place
- // where the record should be inserted. So it is ok.
- if FRecordCount > 0 then
- begin
- SetBookMarkData(FBuffers[FActiveRecord],BookBeforeInsert);
- FreeBookmark(BookBeforeInsert);
- end;
- end;
- InternalInsert;
- // update buffer count.
- If FRecordCount<FBufferCount then
- Inc(FRecordCount);
- end;
- begin
- CheckBrowseMode;
- If Not CanModify then
- DatabaseError(SDatasetReadOnly,Self);
- DoBeforeInsert;
- DoBeforeScroll;
- If Not DoAppend then
- begin
- {$ifdef dsdebug}
- Writeln ('going to insert mode');
- {$endif}
- DoInsert(false);
- end
- else
- begin
- {$ifdef dsdebug}
- Writeln ('going to append mode');
- {$endif}
- ClearBuffers;
- InternalLast;
- GetPriorRecords;
- if FRecordCount>0 then
- FActiveRecord:=FRecordCount-1;
- DoInsert(True);
- SetBookmarkFlag(FBuffers[FActiveRecord],bfEOF);
- FBOF :=False;
- FEOF := true;
- end;
- SetState(dsInsert);
- try
- DoOnNewRecord;
- except
- SetCurrentRecord(FActiveRecord);
- resync([]);
- raise;
- end;
- // mark as not modified.
- FModified:=False;
- // Final events.
- DataEvent(deDatasetChange,0);
- DoAfterInsert;
- DoAfterScroll;
- {$ifdef dsdebug}
- Writeln ('Done with append');
- {$endif}
- end;
- procedure TDataSet.Edit;
- begin
- If State in [dsEdit,dsInsert] then exit;
- CheckBrowseMode;
- If Not CanModify then
- DatabaseError(SDatasetReadOnly,Self);
- If FRecordCount = 0 then
- begin
- Append;
- Exit;
- end;
- DoBeforeEdit;
- If Not TryDoing(@InternalEdit,OnEditError) then exit;
- GetCalcFields(FBuffers[FActiveRecord]);
- SetState(dsEdit);
- DataEvent(deRecordChange,0);
- DoAfterEdit;
- end;
- procedure TDataSet.EnableControls;
- begin
- if FDisableControlsCount > 0 then
- Dec(FDisableControlsCount);
- if FDisableControlsCount = 0 then begin
- if FState <> FDisableControlsState then
- DataEvent(deUpdateState, 0);
- if (FState <> dsInactive) and (FDisableControlsState <> dsInactive) then
- DataEvent(FEnableControlsEvent, 0);
- end;
- end;
- function TDataSet.FieldByName(const FieldName: string): TField;
- begin
- Result:=FindField(FieldName);
- If Result=Nil then
- DatabaseErrorFmt(SFieldNotFound,[FieldName],Self);
- end;
- function TDataSet.FindField(const FieldName: string): TField;
- begin
- Result:=FFieldList.FindField(FieldName);
- end;
- function TDataSet.FindFirst: Boolean;
- begin
- Result:=False;
- end;
- function TDataSet.FindLast: Boolean;
- begin
- Result:=False;
- end;
- function TDataSet.FindNext: Boolean;
- begin
- Result:=False;
- end;
- function TDataSet.FindPrior: Boolean;
- begin
- Result:=False;
- end;
- procedure TDataSet.First;
- begin
- CheckBrowseMode;
- DoBeforeScroll;
- if not FIsUniDirectional then
- ClearBuffers
- else if not FBof then
- begin
- Active := False;
- Active := True;
- end;
- try
- InternalFirst;
- if not FIsUniDirectional then GetNextRecords;
- finally
- FBOF:=True;
- DataEvent(deDatasetChange,0);
- DoAfterScroll;
- end;
- end;
- procedure TDataSet.FreeBookmark(ABookmark: TBookmark);
- begin
- {$ifdef noautomatedbookmark}
- FreeMem(ABookMark,FBookMarkSize);
- {$endif}
- end;
- function TDataSet.GetBookmark: TBookmark;
- begin
- if BookmarkAvailable then
- GetBookMarkdata(ActiveBuffer,Result)
- else
- Result.Data:=Null;
- end;
- function TDataSet.GetCurrentRecord(Buffer: TDataRecord): Boolean;
- begin
- Result:=False;
- end;
- procedure TDataSet.GetFieldList(List: TList; const FieldNames: string);
- var
- F: TField;
- N: String;
- StrPos: Integer;
- begin
- if (FieldNames = '') or (List = nil) then
- Exit;
- StrPos := 1;
- repeat
- N := ExtractFieldName(FieldNames, StrPos);
- F := FieldByName(N);
- List.Add(F);
- until StrPos > Length(FieldNames);
- end;
- procedure TDataSet.GetFieldList(List: TFPList; const FieldNames: string);
- var
- F: TField;
- N: String;
- StrPos: Integer;
- begin
- if (FieldNames = '') or (List = nil) then
- Exit;
- StrPos := 1;
- repeat
- N := ExtractFieldName(FieldNames, StrPos);
- F := FieldByName(N);
- List.Add(F);
- until StrPos > Length(FieldNames);
- end;
- procedure TDataSet.GetFieldNames(List: TStrings);
- begin
- FFieldList.GetFieldNames(List);
- end;
- procedure TDataSet.GotoBookmark(const ABookmark: TBookmark);
- begin
- If Not IsNull(ABookMark.Data) 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
- // Writeln(Name,' Load called. LoadCount ',LoadCount);
- 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;
- if DataProxy.DoGetData(Request) then
- Inc(FLoadCount)
- else
- Request.Free;
- // Writeln(Name,' End of Load call. Count: ',LoadCount);
- end;
- function TDataSet.Load(aOptions: TLoadOptions; aAfterLoad: TDatasetLoadEvent): Boolean;
- begin
- if loAtEOF in aOptions then
- DatabaseError(SatEOFInternalOnly,Self);
- if loCancelPending in aOptions then
- CancelLoading;
- 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.CancelLoading;
- begin
- FMinLoadID:=FDataRequestID;
- FloadCount:=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:=;
- end;
- *)
- procedure TDataSet.SetConstraints(Value: TCheckConstraints);
- begin
- FConstraints.Assign(Value);
- end;
- procedure TDataSet.SetDataProxy(AValue: TDataProxy);
- begin
- If AValue=FDataProxy then
- exit;
- if Assigned(FDataProxy) then
- FDataProxy.RemoveFreeNotification(Self);
- FDataProxy:=AValue;
- if Assigned(FDataProxy) then
- FDataProxy.FreeNotification(Self)
- end;
- function TDataSet.GetfieldCount: Integer;
- begin
- Result:=FFieldList.Count;
- end;
- procedure TDataSet.ShiftBuffersBackward;
- var
- TempBuf : TDataRecord;
- I : Integer;
- begin
- TempBuf := FBuffers[0];
- For I:=1 to FBufferCount do
- FBuffers[I-1]:=FBuffers[i];
- FBuffers[FBufferCount]:=TempBuf;
- end;
- procedure TDataSet.ShiftBuffersForward;
- var
- TempBuf : TDataRecord;
- I : Integer;
- begin
- TempBuf := FBuffers[FBufferCount];
- For I:=FBufferCount downto 1 do
- FBuffers[I]:=FBuffers[i-1];
- FBuffers[0]:=TempBuf;
- end;
- function TDataSet.GetFieldValues(const FieldName: string): JSValue;
- var
- i: Integer;
- FieldList: TList;
- A : TJSValueDynArray;
- begin
- FieldList := TList.Create;
- try
- GetFieldList(FieldList, FieldName);
- if FieldList.Count>1 then
- begin
- SetLength(A,FieldList.Count);
- for i := 0 to FieldList.Count - 1 do
- A[i] := TField(FieldList[i]).Value;
- Result:=A;
- end
- else
- Result := FieldByName(FieldName).Value;
- finally
- FieldList.Free;
- end;
- end;
- procedure TDataSet.SetFieldValues(const FieldName: string; Value: JSValue);
- var
- i : Integer;
- FieldList: TList;
- A : TJSValueDynArray;
- begin
- if IsArray(Value) then
- begin
- FieldList := TList.Create;
- try
- GetFieldList(FieldList, FieldName);
- A:=TJSValueDynArray(Value);
- if (FieldList.Count = 1) and (Length(A)>0) then
- // Allow for a field type that can deal with an array
- FieldByName(FieldName).Value := Value
- else
- for i := 0 to FieldList.Count - 1 do
- TField(FieldList[i]).Value := A[i];
- finally
- FieldList.Free;
- end;
- end
- else
- FieldByName(FieldName).Value := Value;
- end;
- function TDataSet.Locate(const KeyFields: string; const KeyValues: JSValue;
- Options: TLocateOptions): boolean;
- begin
- CheckBiDirectional;
- Result := False;
- end;
- function TDataSet.Lookup(const KeyFields: string; const KeyValues: JSValue;
- const ResultFields: string): JSValue;
- begin
- CheckBiDirectional;
- Result := Null;
- end;
- procedure TDataSet.UnRegisterDataSource(ADataSource: TDataSource);
- begin
- FDataSources.Remove(ADataSource);
- end;
- { ---------------------------------------------------------------------
- TFieldDef
- ---------------------------------------------------------------------}
- constructor TFieldDef.Create(ACollection: TCollection);
- begin
- Inherited Create(ACollection);
- FFieldNo:=Index+1;
- end;
- constructor TFieldDef.Create(AOwner: TFieldDefs; const AName: string; ADataType: TFieldType; ASize: Integer; ARequired: Boolean;
- AFieldNo: Longint);
- begin
- {$ifdef dsdebug }
- Writeln('TFieldDef.Create : ',Aname,'(',AFieldNo,')');
- {$endif}
- Inherited Create(AOwner);
- Name:=Aname;
- FDatatype:=ADatatype;
- FSize:=ASize;
- FRequired:=ARequired;
- FPrecision:=-1;
- FFieldNo:=AFieldNo;
- end;
- destructor TFieldDef.Destroy;
- begin
- Inherited destroy;
- end;
- procedure TFieldDef.Assign(Source: TPersistent);
- var fd: TFieldDef;
- begin
- fd := nil;
- if Source is TFieldDef then
- fd := Source as TFieldDef;
- if Assigned(fd) then begin
- Collection.BeginUpdate;
- try
- Name := fd.Name;
- DataType := fd.DataType;
- Size := fd.Size;
- Precision := fd.Precision;
- FRequired := fd.Required;
- finally
- Collection.EndUpdate;
- end;
- end
- else
- inherited Assign(Source);
- end;
- function TFieldDef.CreateField(AOwner: TComponent): TField;
- var TheField : TFieldClass;
- begin
- {$ifdef dsdebug}
- Writeln ('Creating field '+FNAME);
- {$endif dsdebug}
- TheField:=GetFieldClass;
- if TheField=Nil then
- DatabaseErrorFmt(SUnknownFieldType,[FName]);
- Result:=TheField.Create(AOwner);
- Try
- Result.FFieldDef:=Self;
- Result.Size:=FSize;
- Result.Required:=FRequired;
- Result.FFieldName:=FName;
- Result.FDisplayLabel:=DisplayName;
- Result.FFieldNo:=Self.FieldNo;
- Result.SetFieldType(DataType);
- Result.FReadOnly:=(faReadOnly in Attributes);
- {$ifdef dsdebug}
- Writeln ('TFieldDef.CreateField : Result Fieldno : ',Result.FieldNo,'; Self : ',FieldNo);
- Writeln ('TFieldDef.CreateField : Trying to set dataset');
- {$endif dsdebug}
- Result.Dataset:=TFieldDefs(Collection).Dataset;
- if (Result is TFloatField) then
- TFloatField(Result).Precision := FPrecision;
- except
- Result.Free;
- Raise;
- end;
- end;
- procedure TFieldDef.SetAttributes(AValue: TFieldAttributes);
- begin
- FAttributes := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetDataType(AValue: TFieldType);
- begin
- FDataType := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetPrecision(const AValue: Longint);
- begin
- FPrecision := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetSize(const AValue: Integer);
- begin
- FSize := AValue;
- Changed(False);
- end;
- procedure TFieldDef.SetRequired(const AValue: Boolean);
- begin
- FRequired := AValue;
- Changed(False);
- end;
- function TFieldDef.GetFieldClass: TFieldClass;
- begin
- //!! Should be owner as tdataset but that doesn't work ??
- If Assigned(Collection) And
- (Collection is TFieldDefs) And
- Assigned(TFieldDefs(Collection).Dataset) then
- Result:=TFieldDefs(Collection).Dataset.GetFieldClass(FDataType)
- else
- Result:=Nil;
- end;
- { ---------------------------------------------------------------------
- TFieldDefs
- ---------------------------------------------------------------------}
- {
- destructor TFieldDefs.Destroy;
- begin
- FItems.Free;
- // This will destroy all fielddefs since we own them...
- Inherited Destroy;
- end;
- }
- procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType);
- begin
- Add(AName,ADatatype,0,False);
- end;
- procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize : Word);
- begin
- Add(AName,ADatatype,ASize,False);
- end;
- procedure TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word;
- ARequired: Boolean);
- begin
- If Length(AName)=0 Then
- DatabaseError(SNeedFieldName,Dataset);
- // the fielddef will register itself here as an owned component.
- // fieldno is 1 based !
- BeginUpdate;
- try
- Add(AName,ADataType,ASize,ARequired,Count+1);
- finally
- EndUpdate;
- end;
- end;
- function TFieldDefs.GetItem(Index: Longint): TFieldDef;
- begin
- Result := TFieldDef(inherited Items[Index]);
- end;
- procedure TFieldDefs.SetItem(Index: Longint; const AValue: TFieldDef);
- begin
- inherited Items[Index] := AValue;
- end;
- class function TFieldDefs.FieldDefClass: TFieldDefClass;
- begin
- Result:=TFieldDef;
- end;
- constructor TFieldDefs.Create(ADataSet: TDataSet);
- begin
- Inherited Create(ADataset, Owner, FieldDefClass);
- end;
- function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize, APrecision: Integer;
- ARequired, AReadOnly: Boolean; AFieldNo: Integer): TFieldDef;
- begin
- Result:=FieldDefClass.Create(Self, MakeNameUnique(AName), ADataType, ASize, ARequired, AFieldNo);
- if AReadOnly then
- Result.Attributes := Result.Attributes + [faReadOnly];
- end;
- function TFieldDefs.Add(const AName: string; ADataType: TFieldType; ASize: Word; ARequired: Boolean; AFieldNo: Integer): TFieldDef;
- begin
- Result:=FieldDefClass.Create(Self,AName,ADataType,ASize,ARequired,AFieldNo);
- end;
- procedure TFieldDefs.Assign(FieldDefs: TFieldDefs);
- var I : longint;
- begin
- Clear;
- For i:=0 to FieldDefs.Count-1 do
- With FieldDefs[i] do
- Add(Name,DataType,Size,Required);
- end;
- function TFieldDefs.Find(const AName: string): TFieldDef;
- begin
- Result := (Inherited Find(AName)) as TFieldDef;
- if Result=nil then DatabaseErrorFmt(SFieldNotFound,[AName],FDataset);
- end;
- {
- procedure TFieldDefs.Clear;
- var I : longint;
- begin
- For I:=FItems.Count-1 downto 0 do
- TFieldDef(Fitems[i]).Free;
- FItems.Clear;
- end;
- }
- procedure TFieldDefs.Update;
- begin
- if not Updated then
- begin
- If Assigned(Dataset) then
- DataSet.InitFieldDefs;
- Updated := True;
- end;
- end;
- function TFieldDefs.MakeNameUnique(const AName: String): string;
- var DblFieldCount : integer;
- begin
- DblFieldCount := 0;
- Result := AName;
- while assigned(inherited Find(Result)) do
- begin
- inc(DblFieldCount);
- Result := AName + '_' + IntToStr(DblFieldCount);
- end;
- end;
- function TFieldDefs.AddFieldDef: TFieldDef;
- begin
- Result:=FieldDefClass.Create(Self,'',ftUnknown,0,False,Count+1);
- end;
- { ---------------------------------------------------------------------
- TField
- ---------------------------------------------------------------------}
- Const
- // SBCD = 'BCD';
- SBoolean = 'Boolean';
- SDateTime = 'TDateTime';
- SFloat = 'Float';
- SInteger = 'Integer';
- SLargeInt = 'NativeInt';
- SJSValue = 'JSValue';
- SString = 'String';
- SBytes = 'Bytes';
- constructor TField.Create(AOwner: TComponent);
- //Var
- // I : Integer;
- begin
- Inherited Create(AOwner);
- FVisible:=True;
- SetLength(FValidChars,255);
- // For I:=0 to 255 do
- // FValidChars[i]:=Char(i);
- FProviderFlags := [pfInUpdate,pfInWhere];
- end;
- destructor TField.Destroy;
- begin
- IF Assigned(FDataSet) then
- begin
- FDataSet.Active:=False;
- if Assigned(FFields) then
- FFields.Remove(Self);
- end;
- FLookupList.Free;
- Inherited Destroy;
- end;
- Procedure TField.RaiseAccessError(const TypeName: string);
- Var
- E : EDatabaseError;
- begin
- E:=AccessError(TypeName);
- Raise E;
- end;
- function TField.AccessError(const TypeName: string): EDatabaseError;
- begin
- Result:=EDatabaseError.CreateFmt(SinvalidTypeConversion,[TypeName,FFieldName]);
- end;
- procedure TField.DefineProperties(Filer: TFiler);
- procedure IgnoreReadString(Reader: TReader);
- begin
- Reader.ReadString;
- end;
-
- procedure IgnoreReadBoolean(Reader: TReader);
- begin
- Reader.ReadBoolean;
- end;
- procedure IgnoreWrite(Writer: TWriter);
- begin
- end;
- begin
- Filer.DefineProperty('AttributeSet', @IgnoreReadString, @IgnoreWrite, False);
- Filer.DefineProperty('Calculated', @IgnoreReadBoolean, @IgnoreWrite, False);
- Filer.DefineProperty('Lookup', @IgnoreReadBoolean, @IgnoreWrite, False);
- 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
- begin
- Result:=FDataset.GetFieldData(Self);
- If IsUndefined(Result) then
- Result:=Null;
- end;
- end;
- function TField.GetDataSize: Integer;
- begin
- Result:=0;
- end;
- function TField.GetDefaultWidth: Longint;
- begin
- Result:=10;
- end;
- function TField.GetDisplayName : String;
- begin
- If FDisplayLabel<>'' then
- result:=FDisplayLabel
- else
- Result:=FFieldName;
- end;
- function TField.IsDisplayLabelStored: Boolean;
- begin
- Result:=(DisplayLabel<>FieldName);
- end;
- function TField.IsDisplayWidthStored: Boolean;
- begin
- Result:=(FDisplayWidth<>0);
- end;
- function TField.GetLookupList: TLookupList;
- begin
- if not Assigned(FLookupList) then
- FLookupList := TLookupList.Create;
- Result := FLookupList;
- end;
- procedure TField.CalcLookupValue;
- begin
- // MVC: TODO
- // if FLookupCache then
- // Value := LookupList.ValueOfKey(FDataSet.FieldValues[FKeyFields])
- // else if
- if Assigned(FLookupDataSet) and FLookupDataSet.Active then
- Value := FLookupDataSet.Lookup(FLookupKeyfields, FDataSet.FieldValues[FKeyFields], FLookupresultField)
- else
- Value:=Null;
- end;
- function TField.GetIndex: longint;
- begin
- If Assigned(FDataset) then
- Result:=FDataset.FFieldList.IndexOf(Self)
- else
- Result:=-1;
- end;
- function TField.GetLookup: Boolean;
- begin
- Result := FieldKind = fkLookup;
- end;
- procedure TField.SetAlignment(const AValue: TAlignMent);
- begin
- if FAlignment <> AValue then
- begin
- FAlignment := AValue;
- PropertyChanged(false);
- end;
- end;
- procedure TField.SetIndex(const AValue: Longint);
- begin
- if FFields <> nil then FFields.SetFieldIndex(Self, AValue)
- end;
- function TField.GetIsNull: Boolean;
- begin
- Result:=js.IsNull(GetData);
- end;
- function TField.GetParentComponent: TComponent;
- begin
- Result := DataSet;
- end;
- procedure TField.GetText(var AText: string; ADisplayText: Boolean);
- begin
- AText:=GetAsString;
- end;
- function TField.HasParent: Boolean;
- begin
- HasParent:=True;
- end;
- function TField.IsValidChar(InputChar: Char): Boolean;
- begin
- // FValidChars must be set in Create.
- Result:=CharInset(InputChar,FValidChars);
- end;
- procedure TField.RefreshLookupList;
- var
- tmpActive: Boolean;
- begin
- if not Assigned(FLookupDataSet) or (Length(FLookupKeyfields) = 0)
- or (Length(FLookupresultField) = 0) or (Length(FKeyFields) = 0) then
- Exit;
- tmpActive := FLookupDataSet.Active;
- try
- FLookupDataSet.Active := True;
- FFields.CheckFieldNames(FKeyFields);
- FLookupDataSet.Fields.CheckFieldNames(FLookupKeyFields);
- FLookupDataset.FieldByName(FLookupResultField); // I presume that if it doesn't exist it throws exception, and that a field with null value is still valid
- LookupList.Clear; // have to be F-less because we might be creating it here with getter!
- FLookupDataSet.DisableControls;
- try
- FLookupDataSet.First;
- while not FLookupDataSet.Eof do
- begin
- // FLookupList.Add(FLookupDataSet.FieldValues[FLookupKeyfields], FLookupDataSet.FieldValues[FLookupResultField]);
- FLookupDataSet.Next;
- end;
- finally
- FLookupDataSet.EnableControls;
- end;
- finally
- FLookupDataSet.Active := tmpActive;
- end;
- end;
- procedure TField.Notification(AComponent: TComponent; Operation: TOperation);
- begin
- Inherited Notification(AComponent,Operation);
- if (Operation = opRemove) and (AComponent = FLookupDataSet) then
- FLookupDataSet := nil;
- end;
- procedure TField.PropertyChanged(LayoutAffected: Boolean);
- begin
- If (FDataset<>Nil) and (FDataset.Active) then
- If LayoutAffected then
- FDataset.DataEvent(deLayoutChange,0)
- else
- FDataset.DataEvent(deDatasetchange,0);
- end;
- procedure TField.SetAsBytes(const AValue: TBytes);
- begin
- RaiseAccessError(SBytes);
- end;
- procedure TField.SetAsBoolean(AValue: Boolean);
- begin
- RaiseAccessError(SBoolean);
- end;
- procedure TField.SetAsDateTime(AValue: TDateTime);
- begin
- RaiseAccessError(SDateTime);
- end;
- procedure TField.SetAsFloat(AValue: Double);
- begin
- RaiseAccessError(SFloat);
- end;
- procedure TField.SetAsJSValue(const AValue: JSValue);
- begin
- if js.IsNull(AValue) then
- Clear
- else
- try
- SetVarValue(AValue);
- except
- on EVariantError do
- DatabaseErrorFmt(SFieldValueError, [DisplayName]);
- end;
- end;
- procedure TField.SetAsLongint(AValue: Longint);
- begin
- SetAsInteger(AValue);
- end;
- procedure TField.SetAsInteger(AValue: Longint);
- begin
- RaiseAccessError(SInteger);
- end;
- procedure TField.SetAsLargeInt(AValue: NativeInt);
- begin
- RaiseAccessError(SLargeInt);
- end;
- procedure TField.SetAsString(const AValue: string);
- begin
- RaiseAccessError(SString);
- end;
- procedure TField.SetData(Buffer: JSValue);
- begin
- If Not Assigned(FDataset) then
- DatabaseErrorFmt(SNoDataset,[FieldName]);
- FDataSet.SetFieldData(Self,Buffer);
- end;
- procedure TField.SetDataset(AValue: TDataset);
- begin
- {$ifdef dsdebug}
- Writeln ('Setting dataset');
- {$endif}
- If AValue=FDataset then exit;
- If Assigned(FDataset) Then
- begin
- FDataset.CheckInactive;
- FDataset.FFieldList.Remove(Self);
- end;
- If Assigned(AValue) then
- begin
- AValue.CheckInactive;
- AValue.FFieldList.Add(Self);
- end;
- FDataset:=AValue;
- end;
- procedure TField.SetDataType(AValue: TFieldType);
- begin
- FDataType := AValue;
- end;
- procedure TField.SetFieldType(AValue: TFieldType);
- begin
- { empty }
- end;
- procedure TField.SetParentComponent(Value: TComponent);
- begin
- // if not (csLoading in ComponentState) then
- DataSet := Value as TDataSet;
- end;
- procedure TField.SetSize(AValue: Integer);
- begin
- CheckInactive;
- CheckTypeSize(AValue);
- FSize:=AValue;
- end;
- procedure TField.SetText(const AValue: string);
- begin
- SetAsString(AValue);
- end;
- procedure TField.SetVarValue(const AValue: JSValue);
- begin
- RaiseAccessError(SJSValue);
- end;
- procedure TField.Validate(Buffer: Pointer);
- begin
- If assigned(OnValidate) Then
- begin
- FValueBuffer:=Buffer;
- FValidating:=True;
- Try
- OnValidate(Self);
- finally
- FValidating:=False;
- end;
- end;
- end;
- class function TField.IsBlob: Boolean;
- begin
- Result:=False;
- end;
- class procedure TField.CheckTypeSize(AValue: Longint);
- begin
- If (AValue<>0) and Not IsBlob Then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
- end;
- // TField private methods
- procedure TField.SetEditText(const AValue: string);
- begin
- if Assigned(OnSetText) then
- OnSetText(Self, AValue)
- else
- SetText(AValue);
- end;
- function TField.GetEditText: String;
- begin
- SetLength(Result, 0);
- if Assigned(OnGetText) then
- OnGetText(Self, Result, False)
- else
- GetText(Result, False);
- end;
- function TField.GetDisplayText: String;
- begin
- SetLength(Result, 0);
- if Assigned(OnGetText) then
- OnGetText(Self, Result, True)
- else
- GetText(Result, True);
- end;
- procedure TField.SetDisplayLabel(const AValue: string);
- begin
- if FDisplayLabel<>AValue then
- begin
- FDisplayLabel:=AValue;
- PropertyChanged(true);
- end;
- end;
- procedure TField.SetDisplayWidth(const AValue: Longint);
- begin
- if FDisplayWidth<>AValue then
- begin
- FDisplayWidth:=AValue;
- PropertyChanged(True);
- end;
- end;
- function TField.GetDisplayWidth: integer;
- begin
- if FDisplayWidth=0 then
- result:=GetDefaultWidth
- else
- result:=FDisplayWidth;
- end;
- procedure TField.SetLookup(const AValue: Boolean);
- const
- ValueToLookupMap: array[Boolean] of TFieldKind = (fkData, fkLookup);
- begin
- FieldKind := ValueToLookupMap[AValue];
- end;
- procedure TField.SetReadOnly(const AValue: Boolean);
- begin
- if (FReadOnly<>AValue) then
- begin
- FReadOnly:=AValue;
- PropertyChanged(True);
- end;
- end;
- procedure TField.SetVisible(const AValue: Boolean);
- begin
- if FVisible<>AValue then
- begin
- FVisible:=AValue;
- PropertyChanged(True);
- end;
- end;
- { ---------------------------------------------------------------------
- TStringField
- ---------------------------------------------------------------------}
- constructor TStringField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftString);
- FFixedChar := False;
- FTransliterate := False;
- FSize := 20;
- end;
- procedure TStringField.SetFieldType(AValue: TFieldType);
- begin
- if AValue in [ftString, ftFixedChar] then
- SetDataType(AValue);
- end;
- class procedure TStringField.CheckTypeSize(AValue: Longint);
- begin
- // A size of 0 is allowed, since for example Firebird allows
- // a query like: 'select '' as fieldname from table' which
- // results in a string with size 0.
- If (AValue<0) Then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue])
- end;
- function TStringField.GetAsBoolean: Boolean;
- var S : String;
- begin
- S:=GetAsString;
- result := (Length(S)>0) and (Upcase(S[1]) in ['T',YesNoChars[True]]);
- end;
- function TStringField.GetAsDateTime: TDateTime;
- begin
- Result:=StrToDateTime(GetAsString);
- end;
- function TStringField.GetAsFloat: Double;
- begin
- Result:=StrToFloat(GetAsString);
- end;
- function TStringField.GetAsInteger: Longint;
- begin
- Result:=StrToInt(GetAsString);
- end;
- function TStringField.GetAsLargeInt: NativeInt;
- begin
- Result:=StrToInt64(GetAsString);
- end;
- function TStringField.GetAsString: String;
- Var
- V : JSValue;
- begin
- V:=GetData;
- if isString(V) then
- Result := String(V)
- else
- Result:='';
- end;
- function TStringField.GetAsJSValue: JSValue;
- begin
- Result:=GetData
- end;
- function TStringField.GetDefaultWidth: Longint;
- begin
- result:=Size;
- end;
- procedure TStringField.GetText(var AText: string; ADisplayText: Boolean);
- begin
- AText:=GetAsString;
- end;
- procedure TStringField.SetAsBoolean(AValue: Boolean);
- begin
- If AValue Then
- SetAsString('T')
- else
- SetAsString('F');
- end;
- procedure TStringField.SetAsDateTime(AValue: TDateTime);
- begin
- SetAsString(DateTimeToStr(AValue));
- end;
- procedure TStringField.SetAsFloat(AValue: Double);
- begin
- SetAsString(FloatToStr(AValue));
- end;
- procedure TStringField.SetAsInteger(AValue: Longint);
- begin
- SetAsString(IntToStr(AValue));
- end;
- procedure TStringField.SetAsLargeInt(AValue: NativeInt);
- begin
- SetAsString(IntToStr(AValue));
- end;
- procedure TStringField.SetAsString(const AValue: String);
- begin
- SetData(AValue);
- end;
- procedure TStringField.SetVarValue(const AValue: JSValue);
- begin
- if isString(AVAlue) then
- SetAsString(String(AValue))
- else
- RaiseAccessError(SFieldValueError);
- end;
- { ---------------------------------------------------------------------
- TNumericField
- ---------------------------------------------------------------------}
- constructor TNumericField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- AlignMent:=taRightJustify;
- end;
- class procedure TNumericField.CheckTypeSize(AValue: Longint);
- begin
- // This procedure is only added because some TDataset descendents have the
- // but that they set the Size property as if it is the DataSize property.
- // To avoid problems with those descendents, allow values <= 16.
- If (AValue>16) Then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
- end;
- procedure TNumericField.RangeError(AValue, Min, Max: Double);
- begin
- DatabaseErrorFmt(SRangeError,[AValue,Min,Max,FieldName]);
- end;
- procedure TNumericField.SetDisplayFormat(const AValue: string);
- begin
- If FDisplayFormat<>AValue then
- begin
- FDisplayFormat:=AValue;
- PropertyChanged(True);
- end;
- end;
- procedure TNumericField.SetEditFormat(const AValue: string);
- begin
- If FEditFormat<>AValue then
- begin
- FEditFormat:=AValue;
- PropertyChanged(True);
- end;
- end;
- function TNumericField.GetAsBoolean: Boolean;
- begin
- Result:=GetAsInteger<>0;
- end;
- procedure TNumericField.SetAsBoolean(AValue: Boolean);
- begin
- SetAsInteger(ord(AValue));
- end;
- { ---------------------------------------------------------------------
- TIntegerField
- ---------------------------------------------------------------------}
- constructor TIntegerField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftInteger);
- FMinRange:=Low(LongInt);
- FMaxRange:=High(LongInt);
- // MVC : Todo
- // FValidchars:=['+','-','0'..'9'];
- end;
- function TIntegerField.GetAsFloat: Double;
- begin
- Result:=GetAsInteger;
- end;
- function TIntegerField.GetAsLargeInt: NativeInt;
- begin
- Result:=GetAsInteger;
- end;
- function TIntegerField.GetAsInteger: Longint;
- begin
- If Not GetValue(Result) then
- Result:=0;
- end;
- function TIntegerField.GetAsJSValue: JSValue;
- var L : Longint;
- begin
- If GetValue(L) then
- Result:=L
- else
- Result:=Null;
- end;
- function TIntegerField.GetAsString: string;
- var L : Longint;
- begin
- If GetValue(L) then
- Result:=IntTostr(L)
- else
- Result:='';
- end;
- procedure TIntegerField.GetText(var AText: string; ADisplayText: Boolean);
- var l : longint;
- fmt : string;
- begin
- Atext:='';
- If Not GetValue(l) then exit;
- If ADisplayText or (FEditFormat='') then
- fmt:=FDisplayFormat
- else
- fmt:=FEditFormat;
- If length(fmt)<>0 then
- AText:=FormatFloat(fmt,L)
- else
- Str(L,AText);
- end;
- function TIntegerField.GetValue(var AValue: Longint): Boolean;
- var
- V : JSValue;
- begin
- V:=GetData;
- Result:=isInteger(V);
- if Result then
- AValue:=Longint(V);
- end;
- procedure TIntegerField.SetAsLargeInt(AValue: NativeInt);
- begin
- if (AValue>=FMinRange) and (AValue<=FMaxRange) then
- SetAsInteger(AValue)
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- procedure TIntegerField.SetAsFloat(AValue: Double);
- begin
- SetAsInteger(Round(AValue));
- end;
- procedure TIntegerField.SetAsInteger(AValue: Longint);
- begin
- If CheckRange(AValue) then
- SetData(AValue)
- else
- if (FMinValue<>0) or (FMaxValue<>0) then
- RangeError(AValue,FMinValue,FMaxValue)
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- procedure TIntegerField.SetVarValue(const AValue: JSValue);
- begin
- if IsInteger(aValue) then
- SetAsInteger(Integer(AValue))
- else
- RaiseAccessError(SInteger);
- end;
- procedure TIntegerField.SetAsString(const AValue: string);
- var L,Code : longint;
- begin
- If length(AValue)=0 then
- Clear
- else
- begin
- Val(AValue,L,Code);
- If Code=0 then
- SetAsInteger(L)
- else
- DatabaseErrorFmt(SNotAnInteger,[AValue]);
- end;
- end;
- Function TIntegerField.CheckRange(AValue : longint) : Boolean;
- begin
- if (FMinValue<>0) or (FMaxValue<>0) then
- Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
- else
- Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
- end;
- Procedure TIntegerField.SetMaxValue (AValue : longint);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMaxValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- Procedure TIntegerField.SetMinValue (AValue : longint);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMinValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- { ---------------------------------------------------------------------
- TLargeintField
- ---------------------------------------------------------------------}
- constructor TLargeintField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftLargeint);
- FMinRange:=Low(NativeInt);
- FMaxRange:=High(NativeInt);
- // MVC : Todo
- // FValidchars:=['+','-','0'..'9'];
- end;
- function TLargeintField.GetAsFloat: Double;
- begin
- Result:=GetAsLargeInt;
- end;
- function TLargeintField.GetAsLargeInt: NativeInt;
- begin
- If Not GetValue(Result) then
- Result:=0;
- end;
- function TLargeIntField.GetAsJSValue: JSValue;
- var L : NativeInt;
- begin
- If GetValue(L) then
- Result:=L
- else
- Result:=Null;
- end;
- function TLargeintField.GetAsInteger: Longint;
- begin
- Result:=GetAsLargeInt;
- end;
- function TLargeintField.GetAsString: string;
- var L : NativeInt;
- begin
- If GetValue(L) then
- Result:=IntTostr(L)
- else
- Result:='';
- end;
- procedure TLargeintField.GetText(var AText: string; ADisplayText: Boolean);
- var l : NativeInt;
- fmt : string;
- begin
- Atext:='';
- If Not GetValue(l) then exit;
- If ADisplayText or (FEditFormat='') then
- fmt:=FDisplayFormat
- else
- fmt:=FEditFormat;
- If length(fmt)<>0 then
- AText:=FormatFloat(fmt,L)
- else
- Str(L,AText);
- end;
- function TLargeintField.GetValue(var AValue: NativeInt): Boolean;
- var
- P : JSValue;
- begin
- P:=GetData;
- Result:=isInteger(P);
- if Result then
- AValue:=NativeInt(P);
- end;
- procedure TLargeintField.SetAsFloat(AValue: Double);
- begin
- SetAsLargeInt(Round(AValue));
- end;
- procedure TLargeintField.SetAsLargeInt(AValue: NativeInt);
- begin
- If CheckRange(AValue) then
- SetData(AValue)
- else
- RangeError(AValue,FMinValue,FMaxValue);
- end;
- procedure TLargeintField.SetAsInteger(AValue: Longint);
- begin
- SetAsLargeInt(AValue);
- end;
- procedure TLargeintField.SetAsString(const AValue: string);
- var L : NativeInt;
- code : Longint;
- begin
- If length(AValue)=0 then
- Clear
- else
- begin
- Val(AValue,L,Code);
- If Code=0 then
- SetAsLargeInt(L)
- else
- DatabaseErrorFmt(SNotAnInteger,[AValue]);
- end;
- end;
- procedure TLargeintField.SetVarValue(const AValue: JSValue);
- begin
- if IsInteger(Avalue) then
- SetAsLargeInt(NativeInt(AValue))
- else
- RaiseAccessError(SLargeInt);
- end;
- Function TLargeintField.CheckRange(AValue : NativeInt) : Boolean;
- begin
- if (FMinValue<>0) or (FMaxValue<>0) then
- Result := (AValue>=FMinValue) and (AValue<=FMaxValue)
- else
- Result := (AValue>=FMinRange) and (AValue<=FMaxRange);
- end;
- Procedure TLargeintField.SetMaxValue (AValue : NativeInt);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMaxValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- Procedure TLargeintField.SetMinValue (AValue : NativeInt);
- begin
- If (AValue>=FMinRange) and (AValue<=FMaxRange) then
- FMinValue:=AValue
- else
- RangeError(AValue,FMinRange,FMaxRange);
- end;
- { TAutoIncField }
- constructor TAutoIncField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOWner);
- SetDataType(ftAutoInc);
- end;
- Procedure TAutoIncField.SetAsInteger(AValue: Longint);
- begin
- // Some databases allows insertion of explicit values into identity columns
- // (some of them also allows (some not) updating identity columns)
- // So allow it at client side and leave check for server side
- //if not(FDataSet.State in [dsFilter,dsSetKey,dsInsert]) then
- // DataBaseError(SCantSetAutoIncFields);
- inherited;
- end;
- { TFloatField }
- procedure TFloatField.SetCurrency(const AValue: Boolean);
- begin
- if FCurrency=AValue then exit;
- FCurrency:=AValue;
- end;
- procedure TFloatField.SetPrecision(const AValue: Longint);
- begin
- if (AValue = -1) or (AValue > 1) then
- FPrecision := AValue
- else
- FPrecision := 2;
- end;
- function TFloatField.GetAsFloat: Double;
- Var
- P : JSValue;
- begin
- P:=GetData;
- If IsNumber(P) then
- Result:=Double(P)
- else
- Result:=0.0;
- end;
- function TFloatField.GetAsJSValue: JSValue;
- var
- P : JSValue;
- begin
- P:=GetData;
- if IsNumber(P) then
- Result:=P
- else
- Result:=Null;
- end;
- function TFloatField.GetAsLargeInt: NativeInt;
- begin
- Result:=Round(GetAsFloat);
- end;
- function TFloatField.GetAsInteger: Longint;
- begin
- Result:=Round(GetAsFloat);
- end;
- function TFloatField.GetAsString: string;
- var
- P : JSValue;
- begin
- P:=GetData;
- if IsNumber(P) then
- Result:=FloatToStr(Double(P))
- else
- Result:='';
- end;
- procedure TFloatField.GetText(var AText: string; ADisplayText: Boolean);
- Var
- fmt : string;
- E : Double;
- Digits : integer;
- ff: TFloatFormat;
- P : JSValue;
- begin
- AText:='';
- P:=GetData;
- if Not IsNumber(P) then
- exit;
- E:=Double(P);
- If ADisplayText or (Length(FEditFormat) = 0) Then
- Fmt:=FDisplayFormat
- else
- Fmt:=FEditFormat;
- Digits := 0;
- if not FCurrency then
- ff := ffGeneral
- else
- begin
- Digits := 2;
- ff := ffFixed;
- end;
- If fmt<>'' then
- AText:=FormatFloat(fmt,E)
- else
- AText:=FloatToStrF(E,ff,FPrecision,Digits);
- end;
- procedure TFloatField.SetAsFloat(AValue: Double);
- begin
- If CheckRange(AValue) then
- SetData(AValue)
- else
- RangeError(AValue,FMinValue,FMaxValue);
- end;
- procedure TFloatField.SetAsLargeInt(AValue: NativeInt);
- begin
- SetAsFloat(AValue);
- end;
- procedure TFloatField.SetAsInteger(AValue: Longint);
- begin
- SetAsFloat(AValue);
- end;
- procedure TFloatField.SetAsString(const AValue: string);
- var f : Double;
- begin
- If (AValue='') then
- Clear
- else
- begin
- If not TryStrToFloat(AValue,F) then
- DatabaseErrorFmt(SNotAFloat, [AValue]);
- SetAsFloat(f);
- end;
- end;
- procedure TFloatField.SetVarValue(const AValue: JSValue);
- begin
- if IsNumber(aValue) then
- SetAsFloat(Double(AValue))
- else
- RaiseAccessError('Float');
- end;
- constructor TFloatField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftFloat);
- FPrecision:=15;
- // MVC
- // FValidChars := [DecimalSeparator, '+', '-', '0'..'9', 'E', 'e'];
- end;
- Function TFloatField.CheckRange(AValue : Double) : Boolean;
- begin
- If (FMinValue<>0) or (FMaxValue<>0) then
- Result:=(AValue>=FMinValue) and (AValue<=FMaxValue)
- else
- Result:=True;
- end;
- { TBooleanField }
- function TBooleanField.GetAsBoolean: Boolean;
- var
- P : JSValue;
- begin
- P:=GetData;
- if isBoolean(P) then
- Result:=Boolean(P)
- else
- Result:=False;
- end;
- function TBooleanField.GetAsJSValue: JSValue;
- var
- P : JSValue;
- begin
- P:=GetData;
- if isBoolean(P) then
- Result:=Boolean(P)
- else
- Result:=Null;
- end;
- function TBooleanField.GetAsString: string;
- var
- P : JSValue;
- begin
- P:=GetData;
- if isBoolean(P) then
- Result:=FDisplays[False,Boolean(P)]
- else
- result:='';
- end;
- function TBooleanField.GetDefaultWidth: Longint;
- begin
- Result:=Length(FDisplays[false,false]);
- If Result<Length(FDisplays[false,True]) then
- Result:=Length(FDisplays[false,True]);
- end;
- function TBooleanField.GetAsInteger: Longint;
- begin
- Result := ord(GetAsBoolean);
- end;
- procedure TBooleanField.SetAsInteger(AValue: Longint);
- begin
- SetAsBoolean(AValue<>0);
- end;
- procedure TBooleanField.SetAsBoolean(AValue: Boolean);
- begin
- SetData(AValue);
- end;
- procedure TBooleanField.SetAsString(const AValue: string);
- var Temp : string;
- begin
- Temp:=UpperCase(AValue);
- if Temp='' then
- Clear
- else if pos(Temp, FDisplays[True,True])=1 then
- SetAsBoolean(True)
- else if pos(Temp, FDisplays[True,False])=1 then
- SetAsBoolean(False)
- else
- DatabaseErrorFmt(SNotABoolean,[AValue]);
- end;
- procedure TBooleanField.SetVarValue(const AValue: JSValue);
- begin
- if isBoolean(aValue) then
- SetAsBoolean(Boolean(AValue))
- else if isNumber(aValue) then
- SetAsBoolean(Double(AValue)<>0)
- end;
- constructor TBooleanField.Create(AOwner: TComponent);
- begin
- Inherited Create(AOwner);
- SetDataType(ftBoolean);
- DisplayValues:='True;False';
- end;
- Procedure TBooleanField.SetDisplayValues(const AValue : String);
- var I : longint;
- begin
- If FDisplayValues<>AValue then
- begin
- I:=Pos(';',AValue);
- If (I<2) or (I=Length(AValue)) then
- DatabaseErrorFmt(SInvalidDisplayValues,[AValue]);
- FdisplayValues:=AValue;
- // Store display values and their uppercase equivalents;
- FDisplays[False,True]:=Copy(AValue,1,I-1);
- FDisplays[True,True]:=UpperCase(FDisplays[False,True]);
- FDisplays[False,False]:=Copy(AValue,I+1,Length(AValue)-i);
- FDisplays[True,False]:=UpperCase(FDisplays[False,False]);
- PropertyChanged(True);
- end;
- end;
- { TDateTimeField }
- procedure TDateTimeField.SetDisplayFormat(const AValue: string);
- begin
- if FDisplayFormat<>AValue then begin
- FDisplayFormat:=AValue;
- PropertyChanged(True);
- end;
- end;
- function TDateTimeField.ConvertToDateTime(aValue: JSValue; aRaiseError: Boolean): TDateTime;
- begin
- if JS.isNull(aValue) then
- Result:=0
- else if Assigned(Dataset) then
- Result:=Dataset.ConvertToDateTime(Self,aValue,aRaiseError)
- else
- Result:=TDataset.DefaultConvertToDateTime(Self,aValue,aRaiseError);
- end;
- function TDateTimeField.DateTimeToNativeDateTime(aValue: TDateTime): JSValue;
- begin
- if Assigned(Dataset) then
- Result:=Dataset.ConvertDateTimeToNative(Self,aValue)
- else
- Result:=TDataset.DefaultConvertDateTimeToNative(Self,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) and not IsObject(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
- if (DataType=ftMemo) then
- Result:=String(V)
- else
- begin
- S:=BlobToBytes(V);
- For I:=0 to Length(S)-1 do
- Result:=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
- if DataType=ftMemo then
- SetData(aValue)
- else
- begin
- SetLength(B, Length(aValue));
- For I:=1 to Length(aValue) do
- B[i-1]:=Ord(aValue[i]);
- SetAsBytes(B);
- end;
- 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;
- function TBinaryField.GetAsBytes: TBytes;
- Var
- V : JSValue;
- begin
- V:=GetData;
- if Assigned(V) then
- Result:=BlobToBytes(V)
- else
- SetLength(Result,0);
- end;
- procedure TBinaryField.SetAsBytes(const aValue: TBytes);
- begin
- SetData(BytesToBlob(aValue))
- 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.GetBlobType: TBlobType;
- begin
- Result:=ftBlob;
- end;
- procedure TBlobField.SetBlobType(AValue: TBlobType);
- begin
- SetFieldType(aValue);
- end;
- procedure TBlobField.SetDisplayValue(AValue: TBlobDisplayValue);
- begin
- if FDisplayValue=AValue then Exit;
- FDisplayValue:=AValue;
- PropertyChanged(False);
- end;
- class procedure TBlobField.CheckTypeSize(AValue: Longint);
- begin
- If AValue<0 then
- DatabaseErrorFmt(SInvalidFieldSize,[AValue]);
- end;
- function TBlobField.GetBlobSize: Longint;
- var
- B : TBytes;
- begin
- B:=GetAsBytes;
- Result:=Length(B);
- end;
- function TBlobField.GetIsNull: Boolean;
- begin
- if Not Modified then
- Result:= inherited GetIsNull
- else
- Result:=GetBlobSize=0;
- end;
- procedure TBlobField.GetText(var AText: string; ADisplayText: Boolean);
- begin
- Case FDisplayValue of
- dvClass:
- aText:=GetClassDesc;
- dvFull:
- aText:=GetAsString;
- dvClip:
- begin
- aText:=GetAsString;
- if aDisplayText and (Length(aText)>DisplayWidth) then
- aText:=Copy(Text,1,DisplayWidth) + '...';
- end;
- dvFit:
- begin
- aText:=GetAsString;
- if aDisplayText and (Length(aText)>DisplayWidth) then
- aText:=GetClassDesc;
- end;
- end;
- 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(Self,V,True)
- else
- Result:=TDataset.DefaultConvertToDateTime(Self,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]);
- SetActive(B);
- 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
- if Event = deUpdateState then
- CheckActiveAndEditing
- else if Active then
- 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;
- 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;
- ProcessEvent(deUpdateState,0);
- 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) and enabled 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;
- { TDataSetField }
- constructor TDataSetField.Create(AOwner: TComponent);
- begin
- inherited;
- SetDataType(ftDataSet);
- end;
- procedure TDataSetField.Bind(Binding: Boolean);
- begin
- inherited;
- if Assigned(FNestedDataSet) then
- if Binding then
- begin
- if FNestedDataSet.State = dsInActive then
- FNestedDataSet.Open;
- end
- else
- FNestedDataSet.Close;
- end;
- procedure TDataSetField.AssignNestedDataSet(Value: TDataSet);
- begin
- if Assigned(FNestedDataSet) then
- begin
- FNestedDataSet.Close;
- FNestedDataSet.FDataSetField := nil;
- if Assigned(DataSet) then
- DataSet.NestedDataSets.Remove(FNestedDataSet);
- end;
- if Assigned(Value) then
- DataSet.NestedDataSets.Add(Value);
- FNestedDataSet := Value;
- end;
- destructor TDataSetField.Destroy;
- begin
- AssignNestedDataSet(nil);
- inherited;
- end;
- end.
|