db.pas 220 KB

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