db.pas 220 KB

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