1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980818283848586878889909192939495969798991001011021031041051061071081091101111121131141151161171181191201211221231241251261271281291301311321331341351361371381391401411421431441451461471481491501511521531541551561571581591601611621631641651661671681691701711721731741751761771781791801811821831841851861871881891901911921931941951961971981992002012022032042052062072082092102112122132142152162172182192202212222232242252262272282292302312322332342352362372382392402412422432442452462472482492502512522532542552562572582592602612622632642652662672682692702712722732742752762772782792802812822832842852862872882892902912922932942952962972982993003013023033043053063073083093103113123133143153163173183193203213223233243253263273283293303313323333343353363373383393403413423433443453463473483493503513523533543553563573583593603613623633643653663673683693703713723733743753763773783793803813823833843853863873883893903913923933943953963973983994004014024034044054064074084094104114124134144154164174184194204214224234244254264274284294304314324334344354364374384394404414424434444454464474484494504514524534544554564574584594604614624634644654664674684694704714724734744754764774784794804814824834844854864874884894904914924934944954964974984995005015025035045055065075085095105115125135145155165175185195205215225235245255265275285295305315325335345355365375385395405415425435445455465475485495505515525535545555565575585595605615625635645655665675685695705715725735745755765775785795805815825835845855865875885895905915925935945955965975985996006016026036046056066076086096106116126136146156166176186196206216226236246256266276286296306316326336346356366376386396406416426436446456466476486496506516526536546556566576586596606616626636646656666676686696706716726736746756766776786796806816826836846856866876886896906916926936946956966976986997007017027037047057067077087097107117127137147157167177187197207217227237247257267277287297307317327337347357367377387397407417427437447457467477487497507517527537547557567577587597607617627637647657667677687697707717727737747757767777787797807817827837847857867877887897907917927937947957967977987998008018028038048058068078088098108118128138148158168178188198208218228238248258268278288298308318328338348358368378388398408418428438448458468478488498508518528538548558568578588598608618628638648658668678688698708718728738748758768778788798808818828838848858868878888898908918928938948958968978988999009019029039049059069079089099109119129139149159169179189199209219229239249259269279289299309319329339349359369379389399409419429439449459469479489499509519529539549559569579589599609619629639649659669679689699709719729739749759769779789799809819829839849859869879889899909919929939949959969979989991000100110021003100410051006100710081009101010111012101310141015101610171018101910201021102210231024102510261027102810291030103110321033103410351036103710381039104010411042104310441045104610471048104910501051105210531054105510561057105810591060106110621063106410651066106710681069107010711072107310741075107610771078107910801081108210831084108510861087108810891090109110921093109410951096109710981099110011011102110311041105110611071108110911101111111211131114111511161117111811191120112111221123112411251126112711281129113011311132113311341135113611371138113911401141114211431144114511461147114811491150115111521153115411551156115711581159116011611162116311641165116611671168116911701171117211731174117511761177117811791180118111821183118411851186118711881189119011911192119311941195119611971198119912001201120212031204120512061207120812091210121112121213121412151216121712181219122012211222122312241225122612271228122912301231123212331234123512361237123812391240124112421243124412451246124712481249125012511252125312541255125612571258125912601261126212631264126512661267126812691270127112721273127412751276127712781279128012811282128312841285128612871288128912901291129212931294129512961297129812991300130113021303130413051306130713081309131013111312131313141315131613171318131913201321132213231324132513261327132813291330133113321333133413351336133713381339134013411342134313441345134613471348134913501351135213531354135513561357135813591360136113621363136413651366136713681369137013711372137313741375137613771378137913801381138213831384138513861387138813891390139113921393139413951396139713981399140014011402140314041405140614071408140914101411141214131414141514161417141814191420142114221423142414251426142714281429143014311432143314341435143614371438143914401441144214431444144514461447144814491450145114521453145414551456145714581459146014611462146314641465146614671468146914701471147214731474147514761477147814791480148114821483148414851486148714881489149014911492149314941495149614971498149915001501150215031504150515061507150815091510151115121513151415151516151715181519152015211522152315241525152615271528152915301531153215331534153515361537153815391540154115421543154415451546154715481549155015511552155315541555155615571558155915601561156215631564156515661567156815691570157115721573157415751576157715781579158015811582158315841585158615871588158915901591159215931594159515961597159815991600160116021603160416051606160716081609161016111612161316141615161616171618161916201621162216231624162516261627162816291630163116321633163416351636163716381639164016411642164316441645164616471648164916501651165216531654165516561657165816591660166116621663166416651666166716681669167016711672167316741675167616771678167916801681168216831684168516861687168816891690169116921693169416951696169716981699170017011702170317041705170617071708170917101711171217131714171517161717171817191720172117221723172417251726172717281729173017311732173317341735173617371738173917401741174217431744174517461747174817491750175117521753175417551756175717581759176017611762176317641765176617671768176917701771177217731774177517761777177817791780178117821783178417851786178717881789179017911792179317941795179617971798179918001801180218031804180518061807180818091810181118121813181418151816181718181819182018211822182318241825182618271828182918301831183218331834183518361837183818391840184118421843184418451846184718481849185018511852185318541855185618571858185918601861186218631864186518661867186818691870187118721873187418751876187718781879188018811882188318841885188618871888188918901891189218931894189518961897189818991900190119021903190419051906190719081909191019111912191319141915191619171918191919201921192219231924192519261927192819291930193119321933193419351936193719381939194019411942194319441945194619471948194919501951195219531954195519561957195819591960196119621963196419651966196719681969197019711972197319741975197619771978197919801981198219831984198519861987198819891990199119921993199419951996199719981999200020012002200320042005200620072008200920102011201220132014201520162017201820192020202120222023202420252026202720282029203020312032203320342035203620372038203920402041204220432044204520462047204820492050205120522053205420552056205720582059206020612062206320642065206620672068206920702071207220732074207520762077207820792080208120822083208420852086208720882089209020912092209320942095209620972098209921002101210221032104210521062107210821092110211121122113211421152116211721182119212021212122212321242125212621272128212921302131213221332134213521362137213821392140214121422143214421452146214721482149215021512152215321542155215621572158215921602161216221632164216521662167216821692170217121722173217421752176217721782179218021812182218321842185218621872188218921902191219221932194219521962197219821992200220122022203220422052206220722082209221022112212221322142215221622172218221922202221222222232224222522262227222822292230223122322233223422352236223722382239224022412242224322442245224622472248224922502251225222532254225522562257225822592260226122622263226422652266226722682269227022712272227322742275227622772278227922802281228222832284228522862287228822892290229122922293229422952296229722982299230023012302230323042305230623072308230923102311231223132314231523162317231823192320232123222323232423252326232723282329233023312332233323342335233623372338233923402341234223432344234523462347234823492350235123522353235423552356235723582359236023612362236323642365236623672368236923702371237223732374237523762377237823792380238123822383238423852386238723882389239023912392239323942395239623972398239924002401240224032404240524062407240824092410241124122413241424152416241724182419242024212422242324242425242624272428242924302431243224332434243524362437243824392440244124422443244424452446244724482449245024512452245324542455245624572458245924602461246224632464246524662467246824692470247124722473247424752476247724782479248024812482248324842485248624872488248924902491249224932494249524962497249824992500250125022503250425052506250725082509251025112512251325142515251625172518251925202521252225232524252525262527252825292530253125322533253425352536253725382539254025412542254325442545254625472548254925502551255225532554255525562557255825592560256125622563256425652566256725682569257025712572257325742575257625772578257925802581258225832584258525862587258825892590259125922593259425952596259725982599260026012602260326042605260626072608260926102611261226132614261526162617261826192620262126222623262426252626262726282629263026312632263326342635263626372638263926402641264226432644264526462647264826492650265126522653265426552656265726582659266026612662266326642665266626672668266926702671267226732674267526762677267826792680268126822683268426852686268726882689269026912692269326942695269626972698269927002701270227032704270527062707270827092710271127122713271427152716271727182719272027212722272327242725272627272728272927302731273227332734273527362737273827392740274127422743274427452746274727482749275027512752275327542755275627572758275927602761276227632764276527662767276827692770277127722773277427752776277727782779278027812782278327842785278627872788278927902791279227932794279527962797279827992800280128022803280428052806280728082809281028112812281328142815281628172818281928202821282228232824282528262827282828292830283128322833283428352836283728382839284028412842284328442845284628472848284928502851285228532854285528562857285828592860286128622863286428652866286728682869287028712872287328742875287628772878287928802881288228832884288528862887288828892890289128922893289428952896289728982899290029012902290329042905290629072908290929102911291229132914291529162917291829192920292129222923292429252926292729282929293029312932293329342935293629372938293929402941294229432944294529462947294829492950295129522953295429552956295729582959296029612962296329642965296629672968296929702971297229732974297529762977297829792980298129822983298429852986298729882989299029912992299329942995299629972998299930003001300230033004300530063007300830093010301130123013301430153016301730183019302030213022302330243025302630273028302930303031303230333034303530363037303830393040304130423043304430453046304730483049305030513052305330543055305630573058305930603061306230633064306530663067306830693070307130723073307430753076307730783079308030813082308330843085308630873088308930903091309230933094309530963097309830993100310131023103310431053106310731083109311031113112311331143115311631173118311931203121312231233124312531263127312831293130313131323133313431353136313731383139314031413142314331443145314631473148314931503151315231533154315531563157315831593160316131623163316431653166316731683169317031713172317331743175317631773178317931803181318231833184318531863187318831893190319131923193319431953196319731983199320032013202320332043205320632073208320932103211321232133214321532163217321832193220322132223223322432253226322732283229323032313232323332343235323632373238323932403241324232433244324532463247324832493250325132523253325432553256325732583259326032613262326332643265326632673268326932703271327232733274327532763277327832793280328132823283328432853286328732883289329032913292329332943295329632973298329933003301330233033304330533063307330833093310331133123313331433153316331733183319332033213322332333243325332633273328332933303331333233333334333533363337333833393340334133423343334433453346334733483349335033513352335333543355335633573358335933603361336233633364336533663367336833693370337133723373337433753376337733783379338033813382338333843385338633873388338933903391339233933394339533963397339833993400340134023403340434053406340734083409341034113412341334143415341634173418341934203421342234233424342534263427342834293430343134323433343434353436343734383439344034413442344334443445344634473448344934503451345234533454345534563457345834593460346134623463346434653466346734683469347034713472347334743475347634773478347934803481348234833484348534863487348834893490349134923493349434953496349734983499350035013502350335043505350635073508350935103511351235133514351535163517351835193520352135223523352435253526352735283529353035313532353335343535353635373538353935403541354235433544354535463547354835493550355135523553355435553556355735583559356035613562356335643565356635673568356935703571357235733574357535763577357835793580358135823583358435853586358735883589359035913592359335943595359635973598359936003601360236033604360536063607360836093610361136123613361436153616361736183619362036213622362336243625362636273628362936303631363236333634363536363637363836393640364136423643364436453646364736483649365036513652365336543655365636573658365936603661366236633664366536663667366836693670367136723673 |
- {$Mode objfpc}
- {$H+}
- {$define debug}
- unit fpmkunit;
- Interface
- uses SysUtils,Classes,fpmktype;
- Type
- TRunMode = (rmCompile,rmBuild,rmInstall,rmArchive,rmClean,rmManifest,rmListSources);
- { TNamedItem }
- TNamedItem = Class(TCollectionItem)
- private
- FName: String;
- procedure SetName(const AValue: String);virtual;
- Public
- property Name : String Read FName Write SetName;
- end;
- { TNamedCollection }
- TNamedCollection = Class(TCollection)
- private
- FUniqueNames: Boolean;
- Public
- Function IndexOfName(AName : String) : Integer;
- Function ItemByName(AName : String) : TNamedItem;
- Property UniqueNames : Boolean Read FUniqueNames;
- end;
- { TNamedItemList }
- TNamedItemList = Class(TList)
- private
- function GetNamedItem(Index : Integer): TNamedItem;
- procedure SetNamedItem(Index : Integer; const AValue: TNamedItem);
- public
- Function IndexOfName(AName : String) : Integer;
- Function ItemByName(ANAme : String) : TNamedItem;
- Property NamedItems[Index : Integer] : TNamedItem Read GetNamedItem Write SetNamedItem; default;
- end;
- TCommandAt = fpmktype.TCommandAt;
- { TCommand }
- TCommand = Class(TNamedItem)
- private
- FAfterCommand: TNotifyEvent;
- FBeforeCommand: TNotifyEvent;
- FCommand: String;
- FCommandAt: TCommandAt;
- FDestFile: String;
- FIgnoreResult: Boolean;
- FOptions: String;
- FSourceFile: String;
- Public
- Property SourceFile : String Read FSourceFile Write FSourceFile;
- Property DestFile : String Read FDestFile Write FDestFile;
- Property Command : String Read FCommand Write FCommand;
- Property Options : String Read FOptions Write FOptions;
- Property At : TCommandAt Read FCommandAt Write FCommandAt;
- Property IgnoreResult : Boolean Read FIgnoreResult Write FIgnoreResult;
- Property BeforeCommand : TNotifyEvent Read FBeforeCommand Write FBeforeCommand;
- Property AfterCommand : TNotifyEvent Read FAfterCommand Write FAfterCommand;
- end;
- { TCommands }
- TCommands = Class(TNamedCollection)
- private
- FDefaultAt: TCommandAt;
- function GetCommand(Dest : String): TCommand;
- function GetCommandItem(Index : Integer): TCommand;
- procedure SetCommandItem(Index : Integer; const AValue: TCommand);
- Public
- Function AddCommand(Const Cmd : String) : TCommand;
- Function AddCommand(Const Cmd,Options : String) : TCommand;
- Function AddCommand(Const Cmd,Options,Dest,Source : String) : TCommand;
- Function AddCommand(At : TCommandAt; Const Cmd : String) : TCommand;
- Function AddCommand(At : TCommandAt; Const Cmd,Options : String) : TCommand;
- Function AddCommand(At : TCommandAt; Const Cmd,Options, Dest,Source : String) : TCommand;
- Property CommandItems[Index : Integer] : TCommand Read GetCommandItem Write SetCommandItem;
- Property Commands[Dest : String] : TCommand Read GetCommand; default;
- Property DefaultAt : TCommandAt Read FDefaultAt Write FDefaultAt;
- end;
- { TTarget }
- TTarget = Class(TNamedItem)
- private
- FInstall : Boolean;
- FAfterClean: TNotifyEvent;
- FAfterCompile: TNotifyEvent;
- FBeforeClean: TNotifyEvent;
- FBeforeCompile: TNotifyEvent;
- FCPUs: TCPUs;
- FMode: TCompilerMode;
- FResourceStrings: Boolean;
- FObjectPath,
- FUnitPath,
- FIncludePath,
- FDependencies: TStrings;
- FCommands : TCommands;
- FDirectory: String;
- FExtension: String;
- FFileType: TFileType;
- FOptions: String;
- FOSes: TOSes;
- FFPCTarget: String;
- FTargetState: TTargetState;
- FTargetType: TTargetType;
- function GetCommands: TCommands;
- function GetHasCommands: Boolean;
- function GetHasStrings(AIndex: integer): Boolean;
- function GetStrings(AIndex: integer): TStrings;
- procedure SetCommands(const AValue: TCommands);
- procedure SetStrings(AIndex: integer; const AValue: TStrings);
- Protected
- Function GetSourceFileName : String; virtual;
- Function GetUnitFileName : String; virtual;
- Function GetObjectFileName : String; virtual;
- Function GetRSTFileName : String; Virtual;
- Function GetProgramFileName(AnOS : TOS) : String; Virtual;
- Public
- Constructor Create(ACollection : TCollection); override;
- Destructor Destroy; override;
- Function GetOutputFileName (AOs : TOS) : String; Virtual;
- procedure SetName(const AValue: String);override;
- Procedure GetCleanFiles(List : TStrings; APrefix : String; AnOS : TOS); virtual;
- Procedure GetSourceFiles(List : TStrings; APrefix : String; AnOS : TOS); virtual;
- Procedure GetInstallFiles(List : TStrings; APrefix : String; AnOS : TOS); virtual;
- Procedure GetArchiveFiles(List : TStrings; APrefix : String; AnOS : TOS); virtual;
- Property HasUnitPath : Boolean Index 0 Read GetHasStrings;
- Property HasObjectPath : Boolean Index 1 Read GetHasStrings;
- Property HasIncludePath : Boolean Index 2 Read GetHasStrings;
- Property HasDependencies : Boolean Index 3 Read GetHasStrings;
- Property HasCommands : Boolean Read GetHasCommands;
- Property UnitPath : TStrings Index 0 Read GetStrings Write SetStrings;
- Property ObjectPath : TStrings Index 1 Read GetStrings Write SetStrings;
- Property IncludePath : TStrings Index 2 Read GetStrings Write SetStrings;
- Property Dependencies : TStrings Index 3 Read GetStrings Write SetStrings;
- Property Commands : TCommands Read GetCommands Write SetCommands;
- Property State : TTargetState Read FTargetState;
- Property TargetType : TTargetType Read FTargetType Write FTargetType;
- Property OS : TOSes Read FOSes Write FOSes;
- Property Mode : TCompilerMode Read FMode Write FMode;
- Property Options : String Read FOptions Write Foptions;
- Property SourceFileName: String Read GetSourceFileName ;
- Property UnitFileName : String Read GetUnitFileName;
- Property ObjectFileName : String Read GetObjectFileName;
- Property RSTFileName : String Read GetRSTFileName;
- Property CPU : TCPUs Read FCPUs Write FCPUs;
- Property FPCTarget : String Read FFPCTarget Write FFPCTarget;
- Property Extension : String Read FExtension Write FExtension;
- Property FileType : TFileType Read FFileType Write FFileType;
- Property Directory : String Read FDirectory Write FDirectory;
- Property ResourceStrings : Boolean Read FResourceStrings Write FResourceStrings;
- Property Install : Boolean Read FInstall Write FInstall;
- // Events.
- Property BeforeCompile : TNotifyEvent Read FBeforeCompile Write FBeforeCompile;
- Property AfterCompile : TNotifyEvent Read FAfterCompile Write FAfterCompile;
- Property BeforeClean : TNotifyEvent Read FBeforeClean Write FBeforeClean;
- Property AfterClean : TNotifyEvent Read FAfterClean Write FAfterClean;
- end;
- { TTargets }
- TTargets = Class(TNamedCollection)
- private
- FDefaultCPU: TCPUs;
- FDefaultDir : String;
- FDefaultOS: TOSes;
- function GetTargetItem(Index : Integer): TTarget;
- function GetTarget(AName : String): TTarget;
- procedure SetDefaultDir(const AValue: String);
- procedure SetTargetItem(Index : Integer; const AValue: TTarget);
- Procedure ApplyDefaults(ATarget : TTarget);
- Public
- Procedure ResetDefaults;
- Function AddUnit(AUnitName : String) : TTarget;
- Function AddProgram(AProgramName : String) : TTarget;
- Function AddExampleUnit(AUnitName : String) : TTarget;
- Function AddExampleProgram(AProgramName : String) : TTarget;
- Property Targets[AName : String] : TTarget Read GetTarget; default;
- Property TargetItems[Index : Integer] : TTarget Read GetTargetItem Write SetTargetItem;
- Property DefaultDir : String Read FDefaultDir Write SetDefaultDir;
- Property DefaultOS : TOSes Read FDefaultOS Write FDefaultOS;
- Property DefaultCPU : TCPUs Read FDefaultCPU Write FDefaultCPU;
- end;
- { TSource }
- TSource = Class(TNamedItem)
- private
- FSourceType: TSourceType;
- Public
- Constructor Create(ACollection : TCollection); override;
- Destructor Destroy; override;
- procedure GetSourceFiles(List: TStrings);
- Property SourceType : TSourceType Read FSourceType Write FSourceType;
- end;
- { TSources }
- TSources = Class(TNamedCollection)
- private
- function GetSourceItem(Index : Integer): TSource;
- procedure SetSourceItem(Index : Integer; const AValue: TSource);
- public
- Function AddDocFiles(AFiles : String) : TSource;
- Function AddSrcFiles(AFiles : String) : TSource;
- Function AddExampleFiles(AFiles : String) : TSource;
- Function AddTestFiles(AFiles : String) : TSource;
- Property SourceItems[Index : Integer] : TSource Read GetSourceItem Write SetSourceItem;default;
- end;
- { TPackage }
- TPackage = Class(TNamedItem) // Maybe descend from/use TTarget ?
- private
- FAfterArchive: TNotifyEvent;
- FAfterClean: TNotifyEvent;
- FAfterCompile: TNotifyEvent;
- FAfterInstall: TNotifyEvent;
- FAfterManifest: TNotifyEvent;
- FBeforeArchive: TNotifyEvent;
- FBeforeClean: TNotifyEvent;
- FBeforeCompile: TNotifyEvent;
- FBeforeInstall: TNotifyEvent;
- FBeforeManifest: TNotifyEvent;
- FUnitPath,
- FObjectPath,
- FIncludePath,
- FCleanFiles,
- FArchiveFiles,
- FInstallFiles,
- FDependencies: TStrings;
- FCPU: TCPUs;
- FOS: TOses;
- FTargetState: TTargetState;
- FTargets: TTargets;
- FSources: TSources;
- FDirectory: String;
- FOptions: String;
- FFileName: String;
- FAuthor: String;
- FLicense: String;
- FExternalURL: String;
- FVersion: String;
- FEmail : String;
- FCommands : TCommands;
- FDescriptionFile : String;
- FDescription : String;
- Function GetDescription : string;
- Function GetFileName : string;
- function GetCommands: TCommands;
- function GetHasCommands: Boolean;
- function GetHasStrings(AIndex: integer): Boolean;
- function GetStrings(AIndex: integer): TStrings;
- procedure SetCommands(const AValue: TCommands);
- procedure SetStrings(AIndex: integer; const AValue: TStrings);
- Public
- constructor Create(ACollection: TCollection); override;
- destructor destroy; override;
- Function AddTarget(AName : String) : TTarget;
- Procedure AddDependency(AName : String);
- Procedure AddInstallFile(AFileName : String);
- Procedure GetCleanFiles(List : TStrings; Const APrefix : String; AOS : TOS); virtual;
- procedure GetInstallFiles(List: TStrings;Types : TTargetTypes;Const APrefix : String; AOS : TOS);
- Procedure GetArchiveFiles(List : TStrings; Const APrefix : String; AOS : TOS); virtual;
- Procedure GetSourceFiles(List : TStrings); virtual;
- Procedure GetManifest(Manifest : TStrings);
- Property Version : String Read FVersion Write FVersion;
- Property FileName : String Read GetFileName Write FFileName;
- Property ExternalURL : String Read FExternalURL Write FExternalURL;
- Property Email : String Read FEmail Write FEmail;
- Property Author : String Read FAuthor Write FAuthor;
- Property License : String Read FLicense Write FLicense;
- Property Directory : String Read FDirectory Write FDirectory;
- Property Description : String Read GetDescription Write FDescription;
- Property DescriptionFile : String Read FDescriptionFile Write FDescriptionFile;
- // Compiler options.
- Property OS : TOses Read FOS Write FOS;
- Property CPU : TCPUs Read FCPU Write FCPU;
- Property Options: String Read FOptions Write FOptions;
- Property HasUnitPath : Boolean Index 0 Read GetHasStrings;
- Property HasObjectPath : Boolean Index 1 Read GetHasStrings;
- Property HasIncludePath : Boolean Index 2 Read GetHasStrings;
- Property HasDependencies : Boolean Index 3 Read GetHasStrings;
- Property HasInstallFiles: Boolean Index 4 Read GetHasStrings;
- Property HasCleanFiles : Boolean Index 5 Read GetHasStrings;
- Property HasArchiveFiles : Boolean Index 6 Read GetHasStrings;
- Property HasCommands : Boolean Read GetHasCommands;
- Property UnitPath : TStrings Index 0 Read GetStrings Write SetStrings;
- Property ObjectPath : TStrings Index 1 Read GetStrings Write SetStrings;
- Property IncludePath : TStrings Index 2 Read GetStrings Write SetStrings;
- // Targets and dependencies
- Property Dependencies : TStrings Index 3 Read GetStrings Write SetStrings;
- Property InstallFiles : TStrings Index 4 Read GetStrings Write SetStrings;
- Property CleanFiles : TStrings Index 5 Read GetStrings Write SetStrings;
- Property ArchiveFiles : TStrings Index 6 Read GetStrings Write SetStrings;
- Property Commands : TCommands Read GetCommands Write SetCommands;
- Property State : TTargetState Read FTargetState;
- Property Targets : TTargets Read FTargets;
- Property Sources : TSources Read FSources;
- // events
- Property BeforeCompile : TNotifyEvent Read FBeforeCompile Write FBeforeCompile;
- Property AfterCompile : TNotifyEvent Read FAfterCompile Write FAfterCompile;
- Property BeforeInstall : TNotifyEvent Read FBeforeInstall Write FBeforeInstall;
- Property AfterInstall : TNotifyEvent Read FAfterInstall Write FAfterInstall;
- Property BeforeClean : TNotifyEvent Read FBeforeClean Write FBeforeClean;
- Property AfterClean : TNotifyEvent Read FAfterClean Write FAfterClean;
- Property BeforeArchive : TNotifyEvent Read FBeforeArchive Write FBeforeArchive;
- Property AfterArchive : TNotifyEvent Read FAfterArchive Write FAfterArchive;
- Property BeforeManifest : TNotifyEvent Read FBeforeManifest Write FBeforeManifest;
- Property AfterManifest : TNotifyEvent Read FAfterManifest Write FAfterManifest;
- end;
- { TPackages }
- TPackages = Class(TNamedCollection)
- private
- function GetPackage(AName : String): TPackage;
- function GetPackageItem(AIndex : Integer): TPackage;
- procedure SetPackageItem(AIndex : Integer; const AValue: TPackage);
- Public
- Function AddPackage(Const AName : String) : TPackage;
- Property Packages[AName : String] : TPackage Read GetPackage ; Default;
- Property PackageItems[AIndex : Integer] : TPackage Read GetPackageItem Write SetPackageItem;
- end;
- { TDefaults }
- TDefaults = Class(TPersistent)
- Private
- FArchive: String;
- FCompiler: String;
- FCopy: String;
- FMkDir: String;
- FMove: String;
- FOptions: String;
- FCPU: TCPU;
- FOS: TOS;
- FMode : TCompilerMode;
- FCompilerVersion : String;
- FPrefix: String;
- FBaseInstallDir,
- FUnitInstallDir,
- FBinInstallDir,
- FDocInstallDir,
- FExamplesInstallDir : String;
- FRemove: String;
- FTarget: String;
- FUnixPaths: Boolean;
- function GetBaseInstallDir: String;
- function GetBinInstallDir: String;
- function GetCompiler: String;
- function GetDocInstallDir: String;
- function GetExamplesInstallDir: String;
- function GetUnitInstallDir: String;
- procedure SetBaseInstallDir(const AValue: String);
- procedure SetCPU(const AValue: TCPU);
- procedure SetOS(const AValue: TOS);
- procedure SetPrefix(const AValue: String);
- procedure SetTarget(const AValue: String);
- Protected
- procedure RecalcTarget;
- Public
- Constructor Create;
- Procedure InitDefaults;
- Procedure Assign(ASource : TPersistent);override;
- procedure CompilerDefaults;
- Procedure LocalInit(Const AFileName : String);
- Procedure LoadFromFile(Const AFileName : String);
- Procedure SaveToFile(Const AFileName : String);
- procedure SaveToStream(S : TStream);virtual;
- procedure LoadFromStream(S : TStream);virtual;
- // Compile Information
- Property Target : String Read FTarget Write SetTarget;
- Property OS : TOS Read FOS Write SetOS;
- Property CPU : TCPU Read FCPU Write SetCPU;
- Property Mode : TCompilerMode Read FMode Write FMode;
- Property UnixPaths : Boolean Read FUnixPaths Write FUnixPaths;
- Property Options : String Read FOptions Write FOptions; // Default compiler options.
- // paths etc.
- Property Prefix : String Read FPrefix Write SetPrefix;
- Property BaseInstallDir : String Read GetBaseInstallDir Write SetBaseInstallDir;
- Property UnitInstallDir : String Read GetUnitInstallDir Write FUnitInstallDir;
- Property BinInstallDir : String Read GetBinInstallDir Write FBinInstallDir;
- Property DocInstallDir : String Read GetDocInstallDir Write FDocInstallDir;
- Property ExamplesInstallDir : String Read GetExamplesInstallDir Write FExamplesInstallDir;
- // Command tools. If not set, internal commands will be used.
- Property Compiler : String Read GetCompiler Write FCompiler; // Compiler. Defaults to fpc/ppc386
- Property Copy : String Read FCopy Write FCopy; // copy $(FILES) to $(DEST)
- Property Move : String Read FMove Write FMove; // Move $(FILES) to $(DEST)
- Property Remove : String Read FRemove Write FRemove; // Delete $(FILES)
- Property MkDir : String Read FMkDir write FMkDir; // Make $(DIRECTORY)
- Property Archive : String Read FArchive Write FArchive; // zip $(ARCHIVE) $(FILESORDIRS)
- end;
- { TBuildEngine }
- TBuildEngine = Class(TComponent)
- private
- // general variables
- FCompiler : String;
- FStartDir : String;
- FTargetDir : String;
- FDefaults : TDefaults;
- FForceCompile : Boolean;
- FListMode : Boolean;
- // Variables used when compiling a package.
- // Only valid during compilation of the package.
- FCurrentOutputDir : String;
- FCurrentPackage: TPackage;
- // Events
- FOnLog: TLogEvent;
- FAfterArchive: TNotifyEvent;
- FAfterClean: TNotifyEvent;
- FAfterCompile: TNotifyEvent;
- FAfterInstall: TNotifyEvent;
- FAfterManifest: TNotifyEvent;
- FBeforeArchive: TNotifyEvent;
- FBeforeClean: TNotifyEvent;
- FBeforeCompile: TNotifyEvent;
- FBeforeInstall: TNotifyEvent;
- FBeforeManifest: TNotifyEvent;
- procedure SetDefaults(const AValue: TDefaults);
- procedure SetTargetDir(const AValue: String);
- Protected
- Procedure Error(Msg : String);
- Procedure Error(Fmt : String; Args : Array of const);
- // Internal copy/delete/move/archive/mkdir files
- Procedure SysCopyFile(Const Src,Dest : String); virtual;
- Procedure SysMoveFile(Const Src,Dest : String); virtual;
- Procedure SysDeleteFile(Const AFileName : String); virtual;
- Procedure SysArchiveFiles(List : TStrings; Const AFileName : String); virtual;
- Procedure Log(Level : TVerboseLevel; Const Msg : String);
- Procedure Log(Level : TVerboseLevel; Const Fmt : String; Args : Array Of Const);
- Procedure EnterDir(ADir : String);
- Function GetCompiler : String;
- Procedure InstallPackageFiles(APAckage : TPackage; tt : TTargetType; Const Src,Dest : String); virtual;
- Function FileNewer(Src,Dest : String) : Boolean;
- Public
- Constructor Create(AOwner : TComponent); override;
- // Public Copy/delete/Move/Archive/Mkdir Commands.
- Procedure ExecuteCommand(Cmd : String; Args : String; IgnoreError : Boolean = False); virtual;
- Procedure CmdCopyFiles(List : TStrings; Const DestDir : String);
- Procedure CmdCreateDir(DestDir : String);
- Procedure CmdMoveFiles(List : TStrings; Const DestDir : String);
- Procedure CmdDeleteFiles(List : TStrings);
- Procedure CmdArchiveFiles(List : TStrings; Const ArchiveFile : String);
- Procedure ExecuteCommands(Commands : TCommands; At : TCommandAt);
- // Target commands
- Function GetTargetDir(APackage : TPackage; ATarget : TTarget; AbsolutePath : Boolean = False) : String;
- Function GetCompilerCommand(APackage : TPackage; Target : TTarget) : String;
- Function TargetOK(Target : TTarget) : Boolean;
- Function NeedsCompile(Target : TTarget) : Boolean;
- Procedure Compile(Target : TTarget); virtual;
- Procedure FixDependencies(Target: TTarget);
- // Package commands
- Function GetPackageDir(APackage : TPackage; AbsolutePath : Boolean = False) : String;
- Function GetOutputDir(APackage : TPackage; AbsolutePath : Boolean = False) : String;
- Function PackageOK(APackage : TPackage) : Boolean; virtual;
- Procedure DoBeforeCompile(APackage : TPackage);virtual;
- Procedure DoAfterCompile(APackage : TPackage);virtual;
- Procedure DoBeforeInstall(APackage : TPackage);virtual;
- Procedure DoAfterInstall(APackage : TPackage);virtual;
- Procedure DoBeforeArchive(APackage : TPackage);virtual;
- Procedure DoAfterArchive(APackage : TPackage);virtual;
- Procedure DoBeforeClean(APackage : TPackage);virtual;
- Procedure DoAfterClean(APackage : TPackage);virtual;
- Function NeedsCompile(APackage : TPackage) : Boolean; virtual;
- Procedure Compile(APackage : TPackage);
- Procedure Install(APackage : TPackage);
- Procedure Archive(APackage : TPackage);
- Procedure Clean(APackage : TPackage);
- Procedure FixDependencies(APackage : TPackage);
- Procedure GetSourceFiles(APackage : TPackage; List : TStrings);
- Procedure GetManifest(APackage : TPackage; Manifest : TStrings);
- procedure CheckExternalPackage(Const APackageName : String);
- procedure CreateOutputDir(APackage: TPackage);
- // Packages commands
- Procedure Compile(Packages : TPackages);
- Procedure Install(Packages : TPackages);
- Procedure Archive(Packages : TPackages);
- Procedure Clean(Packages : TPackages);
- Procedure GetSourceFiles(Packages : TPackages;List : TStrings);
- Procedure GetManifest(Packages : TPackages; Manifest : TStrings);
- Property ListMode : Boolean Read FListMode Write FListMode;
- Property ForceCompile : Boolean Read FForceCompile Write FForceCompile;
- Property Defaults : TDefaults Read FDefaults Write SetDefaults;
- Property TargetDir : String Read FTargetDir Write SetTargetDir;
- // Events
- Property BeforeCompile : TNotifyEvent Read FBeforeCompile Write FBeforeCompile;
- Property AfterCompile : TNotifyEvent Read FAfterCompile Write FAfterCompile;
- Property BeforeInstall : TNotifyEvent Read FBeforeInstall Write FBeforeInstall;
- Property AfterInstall : TNotifyEvent Read FAfterInstall Write FAfterInstall;
- Property BeforeClean : TNotifyEvent Read FBeforeClean Write FBeforeClean;
- Property AfterClean : TNotifyEvent Read FAfterClean Write FAfterClean;
- Property BeforeArchive : TNotifyEvent Read FBeforeArchive Write FBeforeArchive;
- Property AfterArchive : TNotifyEvent Read FAfterArchive Write FAfterArchive;
- Property BeforeManifest : TNotifyEvent Read FBeforeManifest Write FBeforeManifest;
- Property AfterManifest : TNotifyEvent Read FAfterManifest Write FAfterManifest;
- Property OnLog : TLogEvent Read FOnLog Write FOnlog;
- end;
- { TInstaller }
- TInstaller = Class(TComponent)
- private
- FBuildEngine: TBuildEngine;
- FDefaultPackage: TPackage;
- FDefaults: TDefaults;
- FPackages: TPackages;
- FRunMode: TRunMode;
- FListMode : Boolean;
- FLogLevels : TVerboseLevels;
- Function GetPackageString(Index : Integer) : String;
- Procedure SetPackageString(Index : Integer; AValue : String);
- function GetStrings(AIndex : Integer): TStrings;
- function GetOSes: TOSes;
- function GetTargets: TTargets;
- function GetSources: TSources;
- procedure SetDefaultPackage(const AValue: TPackage);
- procedure SetDefaults(const AValue: TDefaults);
- procedure SetStrings(AIndex : Integer; const AValue: TStrings);
- procedure SetOses(const AValue: TOSes);
- Protected
- Procedure Log(Level : TVerboseLevel; Const Msg : String);
- Procedure CreatePackages; virtual;
- Procedure CheckPackages; virtual;
- Procedure CreateBuildEngine; virtual;
- Procedure CheckDefaultPackage;
- Procedure Error(Msg : String);
- Procedure Error(Fmt : String; Args : Array of const);
- Procedure AnalyzeOptions;
- Procedure Usage(FMT : String; Args : Array of const);
- Procedure Compile(Force : Boolean); virtual;
- Procedure Clean; virtual;
- Procedure Install; virtual;
- Procedure Archive; virtual;
- Procedure Manifest; virtual;
- Procedure GetSourceFiles; virtual;
- Property BuildEngine : TBuildEngine Read FBuildEngine;
- Public
- Constructor Create(AOWner : TComponent); override;
- Destructor destroy; override;
- Function StartPackage(Const AName : String) : TPackage;
- Procedure EndPackage;
- Function Run : Boolean;
- Function AddTarget(AName : String) : TTarget;
- Procedure AddDependency(AName : String);
- Property DefaultPackage : TPackage read FDefaultPackage write SetDefaultPackage;
- Property Packages : TPackages Read FPackages;
- Property Dependencies : TStrings Index 0 Read GetStrings Write SetStrings;
- Property InstallFiles : TStrings Index 1 Read GetStrings Write SetStrings;
- Property CleanFiles : TStrings Index 2 Read GetStrings Write SetStrings;
- Property ArchiveFiles : TStrings Index 3 Read GetStrings Write SetStrings;
- Property Defaults : TDefaults Read FDefaults Write SetDefaults;
- Property RunMode : TRunMode Read FRunMode;
- Property ListMode : Boolean Read FListMode;
- // Default Package redirects.
- Property Targets : TTargets Read GetTargets;
- Property Sources : TSources Read GetSources;
- Property OS: TOSes Read GetOSes Write SetOses;
- Property Author : String Index 0 Read GetPackageString Write SetPackageString;
- Property Directory : String Index 1 Read GetPackageString Write SetPackageString;
- Property License : String Index 2 Read GetPackageString Write SetPackageString;
- Property Options : String Index 3 Read GetPackageString Write SetPackageString;
- Property ExternalURL : String Index 4 Read GetPackageString Write SetPackageString;
- Property Email : String Index 5 Read GetPackageString Write SetPackageString;
- Property Description: String Index 6 Read GetPackageString Write SetPackageString;
- Property DescriptionFileName: String Index 7 Read GetPackageString Write SetPackageString;
- Property Version : String Index 8 Read GetPackageString Write SetPackageString;
- Property FileName : String Index 9 Read GetPackageString Write SetPackageString;
- end;
- TReplaceFunction = Function (Const AName,Args : String) : String of Object;
- { TValueItem }
- TValueItem = Class(TObject)
- FValue : String;
- Constructor Create(AValue : String);
- end;
- { TFunctionItem }
- TFunctionItem = Class(TObject)
- FFunc : TReplaceFunction;
- Constructor Create(AFunc : TReplaceFunction);
- end;
- { TDictionary }
- TDictionary = Class(TComponent)
- FList : TStringList;
- Public
- Constructor Create(AOwner : TComponent); override;
- Destructor Destroy;override;
- Procedure AddVariable(Const AName,Value : String);
- Procedure AddFunction(Const AName : String; FReplacement : TReplaceFunction);
- Procedure RemoveItem(Const AName : String);
- Function GetValue(Const AName : String) : String;
- Function GetValue(Const AName,Args : String) : String; virtual;
- Function ReplaceStrings(Const ASource : String) : String; virtual;
- end;
- ECollectionError = Class(Exception);
- EInstallerError = fpmktype.EInstallerError;
- EDictionaryError = Class(Exception);
- TInstallerClass = Class of TInstaller;
- TDictionaryClass = Class of TDictionary;
- // Constants are in the file as for fpmktype.
- {$i fpmkcnst.inc}
- Type
- TArchiveEvent = Procedure (Const AFileName : String; List : TStrings) of Object;
- TArchiveProc = Procedure (Const AFileName : String; List : TStrings);
- Var
- InstallerClass : TInstallerClass = TInstaller;
- DictionaryClass : TDictionaryClass = TDictionary;
- OnArchiveFiles : TArchiveEvent = Nil;
- ArchiveFilesProc : TArchiveProc = Nil;
- Function CurrentOS : String;
- Function CurrentCPU : String;
- Function Installer : TInstaller;
- Function Defaults : TDefaults; // Set by installer.
- Function Dictionary : TDictionary;
- Function OSToString(OS: TOS) : String;
- Function OSesToString(OSes: TOSes) : String;
- Function CPUToString(CPU: TCPU) : String;
- Function CPUSToString(CPUS: TCPUS) : String;
- Function StringToOS(S : String) : TOS;
- Function OSesToString(S : String) : TOSes;
- Function StringToCPU(S : String) : TCPU;
- Function StringToCPUS(S : String) : TCPUS;
- Function ModeToString(Mode: TCompilerMode) : String;
- Function StringToMode(S : String) : TCompilerMode;
- Function MakeTargetString(CPU : TCPU;OS: TOS) : String;
- Procedure StringToCPUOS(S : String; Var CPU : TCPU; Var OS: TOS);
- Procedure ResolveDependencies(L : TStrings; P : TNamedCollection);
- Function AddStrings(Dest,Src : TStrings) : Integer ;
- function AddStrings(Dest, Src : TStrings; Const APrefix : String) : Integer ;
- Function FileListToString(List : TStrings; Prefix : String) : String;
- Function FixPath (APath : String) : String;
- Procedure ChangeDir(APath : String);
- Function Substitute(Const Source : String; Macros : Array of string) : String;
- Procedure SplitCommand(Const Cmd : String; Var Exe,Options : String);
- Implementation
- uses typinfo;
- ResourceString
- SErrNameExists = 'Name "%s" already exists in the collection.';
- SErrNoSuchName = 'Could not find item with name "%s" in the collection.';
- SErrNoPackage = 'No package available. Add package with StartPackage Call';
- SErrInValidArgument = 'Invalid command-line argument at position %d : %s';
- SErrNeedArgument = 'Option at position %d (%s) needs an argument';
- SErrNoPackagesDefined = 'No action possible: No packages were defined.';
- SErrInstaller = 'The installer encountered the following error:';
- SErrDepUnknownTarget = 'Unknown target in dependencies for %s: %s';
- SErrExternalCommandFailed = 'External command "%s" failed with exit code: %d';
- SErrCreatingDirectory = 'Failed to create directory: %s';
- SErrDeletingFile = 'Failed to delete file: %s';
- SErrMovingFile = 'Failed to move file "%s" to "%s"';
- SErrCopyingFile = 'Failed to copy file "%s" to "%s"';
- SErrChangeDirFailed = 'Failed to enter directory: %s';
- SErrInvalidArgumentToSubstitute = 'Invalid number of arguments to Substitute';
- SErrNoArchiveSupport = 'This binary contains no archive support. Please recompile with archive support';
- SErrNoDictionaryItem = 'No item called "%s" in the dictionary';
- SErrNoDictionaryValue = 'The item "%s" in the dictionary is not a value.';
- SErrNoDictionaryFunc = 'The item "%s" in the dictionary is not a function.';
- SWarnCircularDependency = 'Warning: Circular dependency detected when compiling target %s: %s';
- SWarnFailedToSetTime = 'Warning: Failed to set timestamp on file : %s';
- SWarnFailedToGetTime = 'Warning: Failed to get timestamp from file : %s';
- SWarnFileDoesNotExist = 'Warning: File "%s" does not exist';
- // Log messages
- SLogEnterDir = 'Entering directory: %s';
- SLogCompilingPackage = 'Compiling package : %s';
- SLogCompilingTarget = 'Compiling target : %s';
- SLogExecutingCommand = 'Executing command %s with options: %s';
- SLogCreatingOutputDir = 'Creating output dir : %s';
- SLogOutputDirExists = 'Output dir exists : %s';
- SLogInstallingPackage = 'Installing package : %s';
- SLogArchivingPackage = 'Archiving package : %s';
- SLogCleaningPackage = 'Cleaning package : %s';
- SLogCopyingFile = 'Copying file "%s" to "%s"';
- SLogCompilingFileTimes = 'Comparing file "%s" time "%s" to "%s" time "%s".';
- SLogSourceNewerDest = 'Source file "%s" (%s) is newer than destination "%s" (%s).';
- // Help messages for usage
- SValue = 'Value';
- SHelpUsage = 'Usage: %s command [options]';
- SHelpCommand = 'Where command is one of the following:';
- SHelpCompile = 'Compile all units in the package(s).';
- SHelpBuild = 'Build all units in the package(s).';
- SHelpInstall = 'Install all units in the package(s).';
- SHelpClean = 'Clean (remove) all units in the package(s).';
- SHelpArchive = 'Create archive (zip) with all units in the package(s).';
- SHelpHelp = 'This message.';
- SHelpManifest = 'Create a manifest suitable for import in repository.';
- SHelpCmdOptions = 'Where options is one or more of the following:';
- SHelpCPU = 'Compile for indicated CPU.';
- SHelpOS = 'Compile for indicated OS';
- SHelpTarget = 'Compile for indicated target';
- SHelpList = 'list commands instead of actually executing them.';
- SHelpPrefix = 'Use indicated prefix directory for all commands.';
- SHelpNoDefaults = 'Do not use defaults when compiling.';
- SHelpBaseInstallDir = 'Use indicated directory as base install dir.';
- SHelpCompiler = 'Use indicated binary as compiler';
- SHelpConfig = 'Use indicated config file when compiling.';
- SHelpVerbose = 'Be verbose when working.';
- Const
- // Keys for Defaults file. Do not localize.
- KeyCompiler = 'Compiler';
- KeyArchive = 'Archive';
- KeyCopy = 'Copy';
- KeyMkDir = 'MkDir';
- KeyMove = 'Move';
- KeyRemove = 'Remove';
- KeyOptions = 'Options';
- KeyCPU = 'CPU';
- KeyOS = 'OS';
- KeyMode = 'Mode';
- KeyPrefix = 'Prefix';
- KeyTarget = 'Target';
- KeyBaseInstallDir = 'BaseInstallDir';
- KeyUnitInstallDir = 'UnitInstallDir';
- KeyBinInstallDir = 'BinInstallDir';
- KeyDocInstallDir = 'DocInstallDir';
- KeyExamplesInstallDir = 'ExamplesInstallDir';
- // Callback for Sysutils getapplicationname.
- Function GetFPMakeName : String;
- begin
- Result:='fpmake';
- end;
- Function CurrentOS : String;
- begin
- Result:=OSToString(Defaults.OS);
- end;
- Function CurrentCPU : String;
- begin
- Result:=CPUToString(Defaults.CPU);
- end;
- Function OSToString(OS: TOS) : String;
- begin
- Result:=fpmktype.OsToString(OS);
- end;
- Function OSesToString(OSes: TOSes) : String;
- begin
- Result:=fpmktype.OSesToString(OSes);
- end;
- Function CPUToString(CPU: TCPU) : String;
- begin
- Result:=fpmkType.CPUToString(CPU);
- end;
- Function CPUSToString(CPUS: TCPUS) : String;
- begin
- Result:=fpmktype.CPUSToString(CPUS);
- end;
- Function StringToOS(S : String) : TOS;
- begin
- Result:=fpmktype.StringToOS(S);
- end;
- Function OSesToString(S : String) : TOSes;
- begin
- Result:=fpmktype.OSesToString(S);
- end;
- Function StringToCPU(S : String) : TCPU;
- begin
- Result:=fpmktype.StringToCPU(S);
- end;
- Function StringToCPUS(S : String) : TCPUS;
- begin
- Result:=fpmktype.StringToCPUS(S);
- end;
- Function ModeToString(Mode: TCompilerMode) : String;
- begin
- Result:=fpmktype.ModeToString(Mode);
- end;
- Function StringToMode(S : String) : TCompilerMode;
- begin
- Result:=fpmktype.StringToMode(S);
- end;
- Function MakeTargetString(CPU : TCPU;OS: TOS) : String;
- begin
- Result:=fpmktype.MakeTargetString(CPU,OS);
- end;
- Procedure StringToCPUOS(S : String; Var CPU : TCPU; Var OS: TOS);
- begin
- fpmktype.StringToCPUOS(S,CPU,OS);
- end;
- Procedure ResolveDependencies(L : TStrings; P : TNamedCollection);
- Var
- I,J : Integer;
- begin
- If Assigned(L) then
- For I:=0 to L.Count-1 do
- begin
- J:=P.IndexOfName(L[i]);
- If J<>-1 then
- L.Objects[I]:=P.Items[J];
- end;
- end;
- Function AddStrings(Dest,Src : TStrings) : Integer ;
- begin
- Result:=AddStrings(Dest,Src,'');
- end;
- Procedure AddStrings(Var S : String; L : TStrings; Prefix : String);
- Var
- I : Integer;
- begin
- For I:=0 to L.Count-1 do
- begin
- if (S<>'') then
- S:=S+' ';
- S:=S+Prefix+L[i];
- end;
- end;
- function AddStrings(Dest, Src : TStrings; Const APrefix : String) : Integer ;
- begin
- Result:=0;
- While (Result<Src.Count) do
- begin
- If (APrefix<>'') then
- Dest.Add(APrefix+Src[Result]) // Not sure whether '' is optimized away.
- else
- Dest.Add(Src[Result]);
- Inc(Result);
- end;
- end;
- function FileListToString(List : TStrings; Prefix : String) : String;
- Var
- I : integer;
- S : String;
- begin
- Result:='';
- For I:=0 to List.Count-1 do
- begin
- If (I>0) then
- Result:=Result+' ';
- S:=Prefix+List[i];
- If (Pos(' ',S)<>0) then
- S:='"'+S+'"';
- Result:=Result+S;
- end;
- end;
- function FixPath (APath : String) : String;
- Var
- P : PChar;
- begin
- Result:=APath;
- If (result<>'') then
- begin
- P:=PChar(Result);
- While (P^<>#0) do
- begin
- If P^ in ['/','\',':'] then // do not use drive letters.
- P^:=PathDelim;
- Inc(P);
- end;
- end;
- end;
- procedure ChangeDir(APath : String);
- begin
- if Not SetCurrentDir(APath) then
- Raise EInstallerError.CreateFmt(SErrChangeDirFailed,[APath]);
- end;
- procedure SplitCommand(const Cmd : String; var Exe, Options : String);
- Const
- WhiteSpace = [#9,#10,#13,' '];
- QuoteChars = ['''','"'];
- Var
- I : Integer;
- InQuote : Boolean;
- LastQuote : Char;
- S : String;
- begin
- S:=Trim(Cmd);
- InQuote:=False;
- LastQuote:=#0;
- I:=1;
- While (I<=Length(S)) and (Inquote or not (S[I] in whiteSpace)) do
- begin
- If S[i] in QuoteChars then
- begin
- InQuote:=Not (S[i]=LastQuote);
- If InQuote then
- LastQuote:=S[i]
- else
- LastQuote:=#0;
- end;
- Inc(I);
- end;
- Exe:=Copy(S,1,I-1);
- Delete(S,1,I);
- Options:=Trim(S);
- end;
- { TNamedItem }
- procedure TNamedItem.SetName(const AValue: String);
- begin
- if FName=AValue then exit;
- With TNamedCollection(Collection) do
- If UniqueNames then
- If (IndexOfName(AVAlue)<>-1) then
- Raise ECollectionError.CreateFmt(SErrNameExists,[AValue]);
- FName:=AValue;
- end;
- { TNamedCollection }
- function TNamedCollection.IndexOfName(AName: String): Integer;
- begin
- Result:=Count-1;
- While (Result>=0) and (CompareText(TNamedItem(Items[Result]).FName,AName)<>0) do
- Dec(Result);
- end;
- function TNamedCollection.ItemByName(AName: String): TNamedItem;
- Var
- I : Integer;
- begin
- I:=IndexOfName(AName);
- If (I=-1) Then
- Raise ECollectionError.CreateFmt(SErrNoSuchName,[AName]);
- Result:=TNamedItem(Items[i]);
- end;
- { TTargets }
- function TTargets.GetTargetItem(Index : Integer): TTarget;
- begin
- Result:=TTarget(Items[Index]);
- end;
- function TTargets.GetTarget(AName : String): TTarget;
- begin
- Result:=TTarget(ItemByName(AName));
- end;
- procedure TTargets.SetDefaultDir(const AValue: String);
- begin
- If (AValue<>'') then
- FDefaultDir:=IncludeTrailingPathDelimiter(AValue)
- else
- FDefaultDir:='';
- end;
- procedure TTargets.SetTargetItem(Index : Integer; const AValue: TTarget);
- begin
- Items[Index]:=AValue;
- end;
- procedure TTargets.ApplyDefaults(ATarget: TTarget);
- begin
- If (ATarget.Directory='') then
- ATarget.Directory:=FDefaultDir;
- ATarget.OS:=FDefaultOS;
- ATarget.CPU:=FDefaultCPU;
- end;
- procedure TTargets.ResetDefaults;
- begin
- FDefaultDir:='';
- FDefaultOS:=[];
- FDefaultCPU:=[];
- end;
- Function TTargets.AddUnit(AUnitName: String) : TTarget;
- begin
- Result:=Add as TTarget;
- Result.Name:=AUnitName;
- Result.TargetType:=TTUnit;
- ApplyDefaults(Result);
- end;
- Function TTargets.AddProgram(AProgramName: String) : TTarget;
- begin
- Result:=Add as TTarget;
- Result.Name:=AProgramName;
- Result.TargetType:=ttProgram;
- ApplyDefaults(Result);
- end;
- Function TTargets.AddExampleUnit(AUnitName: String): TTarget;
- begin
- Result:=Add as TTarget;
- Result.Name:=AUnitName;
- Result.TargetType:=ttExampleUnit;
- ApplyDefaults(Result);
- end;
- Function TTargets.AddExampleProgram(AProgramName: String): TTarget;
- begin
- Result:=Add as TTarget;
- Result.Name:=AProgramName;
- Result.TargetType:=ttExampleProgram;
- ApplyDefaults(Result);
- end;
- { TSources }
- function TSources.GetSourceItem(Index : Integer): TSource;
- begin
- Result:=TSource(Items[Index]);
- end;
- procedure TSources.SetSourceItem(Index : Integer; const AValue: TSource);
- begin
- Items[Index]:=AValue;
- end;
- function TSources.AddDocFiles(AFiles : String) : TSource;
- begin
- Result:=Add as TSource;
- Result.Name:=AFiles;
- Result.SourceType:=stDoc;
- end;
- function TSources.AddSrcFiles(AFiles : String) : TSource;
- begin
- Result:=Add as TSource;
- Result.Name:=AFiles;
- Result.SourceType:=stSrc;
- end;
- function TSources.AddExampleFiles(AFiles : String) : TSource;
- begin
- Result:=Add as TSource;
- Result.Name:=AFiles;
- Result.SourceType:=stExample;
- end;
- function TSources.AddTestFiles(AFiles : String) : TSource;
- begin
- Result:=Add as TSource;
- Result.Name:=AFiles;
- Result.SourceType:=stTest;
- end;
- { TNamedItemList }
- function TNamedItemList.GetNamedItem(Index : Integer): TNamedItem;
- begin
- Result:=TNamedItem(Items[Index]);
- end;
- procedure TNamedItemList.SetNamedItem(Index : Integer; const AValue: TNamedItem);
- begin
- Items[Index]:=AValue;
- end;
- function TNamedItemList.IndexOfName(AName: String): Integer;
- begin
- Result:=Count-1;
- While (Result>=0) and (CompareText(GetNamedItem(Result).Name,AName)<>0) do
- Dec(Result);
- end;
- function TNamedItemList.ItemByName(ANAme: String): TNamedItem;
- Var
- I : Integer;
- begin
- I:=IndexOfName(AName);
- If (I=-1) Then
- Raise ECollectionError.CreateFmt(SErrNoSuchName,[AName]);
- Result:=TNamedItem(Items[i]);
- end;
- { TDefaults }
- procedure TDefaults.SetCPU(const AValue: TCPU);
- begin
- FCPU:=AValue;
- RecalcTarget;
- end;
- function TDefaults.GetBaseInstallDir: String;
- begin
- If (FBaseInstallDir<>'') then
- Result:=FBaseInstallDir
- else
- if UnixPaths then
- Result:=Prefix+PathDelim+'lib'+PathDelim+'fpc'
- else
- Result:=Prefix;
- end;
- function TDefaults.GetBinInstallDir: String;
- begin
- If (FBinInstallDir<>'') then
- Result:=FBinInstallDir
- else
- If UnixPaths then
- Result:=BaseInstallDir+PathDelim+'bin'
- else
- Result:=BaseInstallDir+PathDelim+'bin';
- end;
- function TDefaults.GetCompiler: String;
- begin
- If (FCompiler<>'') then
- Result:=FCompiler
- else
- Result:='fpc';
- end;
- function TDefaults.GetDocInstallDir: String;
- begin
- If (FBinInstallDir<>'') then
- Result:=FBinInstallDir
- else
- If UnixPaths then
- Result:=Prefix+PathDelim+'share'+PathDelim+'docs'
- else
- Result:=BaseInstallDir+PathDelim+'docs';
- end;
- function TDefaults.GetExamplesInstallDir: String;
- begin
- If (FExamplesInstallDir<>'') then
- Result:=FExamplesInstallDir
- else
- If UnixPaths then
- Result:=Prefix+PathDelim+'share'+PathDelim+'docs'+PathDelim+'examples'
- else
- Result:=BaseInstallDir+PathDelim+'examples';
- end;
- function TDefaults.GetUnitInstallDir: String;
- begin
- If (FUnitInstallDir<>'') then
- Result:=FUnitInstallDir
- else
- If UnixPaths then
- Result:=BaseInstallDir+PathDelim+'units'+PathDelim+Target
- else
- Result:=BaseInstallDir+PathDelim+'units'+PathDelim+Target;
- end;
- procedure TDefaults.SetBaseInstallDir(const AValue: String);
- begin
- FBaseInstallDir:=AValue;
- UnitInstallDir:='';
- BinInstallDir:='';
- ExamplesInstallDir:='';
- end;
- procedure TDefaults.SetOS(const AValue: TOS);
- begin
- FOS:=AValue;
- Recalctarget;
- end;
- procedure TDefaults.SetPrefix(const AValue: String);
- begin
- if FPrefix=AValue then exit;
- FPrefix:=AValue;
- BaseInstallDir:='';
- end;
- procedure TDefaults.SetTarget(const AValue: String);
- Var
- P : Integer;
- begin
- if FTarget<>AValue then
- begin
- P:=Pos('-',AValue);
- If (P<>0) then
- begin
- FOS:=StringToOS(System.Copy(Avalue,P+1,Length(AValue)-P));
- FCPU:=StringToCPU(System.Copy(Avalue,1,P-1));
- end
- else
- FOS:=StringToOS(AValue);
- FTarget:=AValue;
- end;
- end;
- procedure TDefaults.RecalcTarget;
- begin
- Ftarget:=CPUToString(FCPU)+'-'+OStoString(FOS);
- end;
- constructor TDefaults.Create;
- begin
- InitDefaults;
- end;
- procedure TDefaults.InitDefaults;
- begin
- {$ifdef unix}
- UnixPaths:=True;
- {$else}
- UnixPaths:=False;
- {$endif}
- end;
- procedure TDefaults.Assign(ASource: TPersistent);
- Var
- d : TDefaults;
- begin
- If ASource is TDefaults then
- begin
- D:=ASource as TDefaults;
- FArchive:=D.Farchive;
- FCompiler:=D.Compiler;
- FCopy:=D.FCopy;
- FCPU:=D.FCPU;
- FMode:=D.FMode;
- FMkDir:=D.FMkDir;
- FMove:=D.FMove;
- FOptions:=D.FOptions;
- FOS:=D.FOS;
- FPrefix:=D.FPrefix;
- FBaseInstallDir:=D.FBaseInstallDir;
- FUnitInstallDir:=D.FUnitInstallDir;
- FBinInstallDir:=D.FBinInstallDir;
- FDocInstallDir:=D.FDocInstallDir;
- FExamplesInstallDir:=D.FExamplesInstallDir;
- FRemove:=D.FRemove;
- FTarget:=D.FTarget;
- FUnixPaths:=D.FUnixPaths;
- end;
- end;
- procedure TDefaults.LocalInit(Const AFileName : String);
- Var
- FN : String;
- begin
- FN:=AFileName;
- If (FN='') then
- begin
- // Environment variable.
- FN:=GetEnvironmentVariable('FPMAKECFG');
- If (FN<>'') then
- If not FileExists(FN) then
- FN:='';
- // User config file fpmake.cfg
- If (FN='') then
- begin
- FN:=GetAppConfigFile(False);
- If Not FileExists(FN) then
- FN:='';
- end;
- // Global config file fpmake.cfg
- If (FN='') then
- begin
- FN:=GetAppConfigFile(True);
- If Not FileExists(FN) then
- FN:='';
- end;
- end;
- If (FN<>'') and FileExists(FN) then
- LoadFromFile(FN);
- end;
- procedure TDefaults.CompilerDefaults;
- begin
- if Compiler<>'' then
- Compiler:='fpc';
- if CPU=cpuNone then
- CPU:=StringToCPU({$I %FPCTARGETCPU%});
- if OS=osNone then
- OS:=StringToOS({$I %FPCTARGETOS%});
- if FCompilerVersion='' then
- FCompilerVersion:='2.0.4';
- if (FBaseInstallDir='') and (FPrefix='') then
- begin
- // Use the same algorithm as the compiler, see options.pas
- {$ifdef Unix}
- FBaseInstallDir:=FixPath(GetEnvironmentVariable('FPCDIR'));
- if FBaseInstallDir='' then
- begin
- FBaseInstallDir:='/usr/local/lib/fpc/'+FCompilerVersion;
- if not DirectoryExists(FBaseInstallDir) and
- DirectoryExists('/usr/lib/fpc/'+FCompilerVersion) then
- FBaseInstallDir:='/usr/lib/fpc/'+FCompilerVersion;
- end;
- {$else unix}
- FBaseInstallDir:=FixPath(GetEnvironmentVariable('FPCDIR'));
- if FBaseInstallDir='' then
- begin
- FBaseInstallDir:=ExtractFilePath(FCompiler)+'..';
- if not(DirectoryExists(FBaseInstallDir+'/units')) and
- not(DirectoryExists(FBaseInstallDir+'/rtl')) then
- FBaseInstallDir:=FBaseInstallDir+'..';
- end;
- {$endif unix}
- end;
- end;
- procedure TDefaults.LoadFromFile(Const AFileName: String);
- Var
- F : TFileStream;
- begin
- F:=TFileStream.Create(AFileName,fmOpenRead);
- Try
- LoadFromStream(F);
- Finally
- F.Free;
- end;
- end;
- procedure TDefaults.SaveToFile(Const AFileName: String);
- Var
- F : TFileStream;
- begin
- F:=TFileStream.Create(AFileName,fmCreate);
- Try
- SaveToStream(F);
- Finally
- F.Free;
- end;
- end;
- procedure TDefaults.SaveToStream(S : TStream);
- Var
- L : TStringList;
- begin
- L:=TStringList.Create;
- try
- With L do
- begin
- Values[KeyArchive]:=FArchive;
- Values[KeyCompiler]:=FCompiler;
- Values[KeyCopy]:=FCopy;
- Values[KeyMkDir]:=FMkDir;
- Values[KeyMove]:=FMove;
- Values[KeyOptions]:=FOptions;
- Values[KeyCPU]:=CPUToString(FCPU);
- Values[KeyOS]:=OSToString(FOS);
- Values[KeyMode]:=ModeToString(FMode);
- Values[KeyPrefix]:=FPrefix;
- Values[KeyBaseInstallDir]:=FBaseInstallDir;
- Values[KeyUnitInstallDir]:=FUnitInstallDir;
- Values[KeyBinInstallDir]:=FBinInstallDir;
- Values[KeyDocInstallDir]:=FDocInstallDir;
- Values[KeyExamplesInstallDir]:=FExamplesInstallDir;
- Values[KeyRemove]:=FRemove;
- Values[KeyTarget]:=FTarget;
- end;
- L.SaveToStream(S);
- Finally
- L.Free;
- end;
- end;
- procedure TDefaults.LoadFromStream(S: TStream);
- Var
- L : TStrings;
- Line : String;
- I,P,PC : Integer;
- begin
- L:=TStringList.Create;
- Try
- L.LoadFromStream(S);
- // Fix lines.
- For I:=L.Count-1 downto 0 do
- begin
- Line:=L[I];
- P:=Pos('=',Line);
- PC:=Pos(';',Line); // Comment line.
- If (P=0) or ((PC<>0) and (PC<P)) then
- L.Delete(I)
- else
- L[i]:=Trim(System.Copy(Line,1,P-1)+'='+Trim(System.Copy(Line,P+1,Length(Line)-P)));
- end;
- With L do
- begin
- FArchive:=Values[KeyArchive];
- FCompiler:=Values[KeyCompiler];
- FCopy:=Values[KeyCopy];
- FMkDir:=Values[KeyMkDir];
- FMove:=Values[KeyMove];
- FRemove:=Values[KeyRemove];
- FOptions:=Values[KeyOptions];
- Line:=Values[KeyCPU];
- If (Line<>'') then
- FCPU:=StringToCPU(Line);
- Line:=Values[KeyOS];
- If (Line<>'') then
- FOS:=StringToOS(Line);
- Line:=Values[KeyMode];
- If (Line<>'') then
- FMode:=StringToMode(Line);
- FTarget:=Values[KeyTarget];
- FPrefix:=Values[KeyPrefix];
- FBaseInstallDir:=Values[KeyBaseInstallDir];
- FUnitInstallDir:=Values[KeyUnitInstallDir];
- FBinInstallDir:=Values[KeyBinInstallDir];
- FDocInstallDir:=Values[KeyDocInstallDir];
- FExamplesInstallDir:=Values[KeyExamplesInstallDir];
- end;
- Finally
- L.Free;
- end;
- end;
- { TPackage }
- function TPackage.GetHasStrings(AIndex: integer): Boolean;
- begin
- Result:=False;
- Case AIndex Of
- 0 : Result:=FUnitPath<>Nil;
- 1 : Result:=FObjectPath<>Nil;
- 2 : Result:=FIncludePath<>Nil;
- 3 : Result:=FDependencies<>Nil;
- 4 : Result:=FInstallFiles<>Nil;
- 5 : Result:=FCleanFiles<>Nil;
- 6 : Result:=FArchiveFiles<>Nil;
- end;
- end;
- function TPackage.GetCommands: TCommands;
- begin
- If Not Assigned(FCommands) then
- FCommands:=TCommands.Create(TCommand);
- Result:=FCommands;
- end;
- function TPackage.GetHasCommands: Boolean;
- begin
- Result:=Assigned(FCommands);
- end;
- Procedure SplitVersion(AValue: String; Var Release,Major,Minor : Word; Var Suffix : String);
- Function NextDigit(sep : Char; var V : string) : integer;
- Var
- P : Integer;
- begin
- P:=Pos(Sep,V);
- If (P=0) then
- P:=Length(V)+1;
- Result:=StrToIntDef(Copy(V,1,P-1),-1);
- If Result<>-1 then
- Delete(V,1,P)
- else
- Result:=0;
- end;
- Var
- P : Integer;
- V : String;
- begin
- Release:=0;
- Major:=0;
- Minor:=0;
- Suffix:='';
- V:=AValue;
- Release:=NextDigit('.',V);
- Major:=NextDigit('.',V);
- Minor:=NextDigit('-',V);
- P:=Pos('-',V);
- If (P<>0) then
- Delete(V,1,P);
- Suffix:=V;
- end;
- Function QuoteXML(S : String) : string;
- Procedure W(Var J : Integer; Var R : String; T : String);
- Var
- I: integer;
- begin
- If J+Length(T)>Length(R) then
- SetLength(R,J+Length(T));
- For I:=1 to Length(t) do
- begin
- R[J]:=T[i];
- If I<Length(T) then
- Inc(J);
- end;
- end;
- const
- QuotStr = '"';
- AmpStr = '&';
- ltStr = '<';
- gtStr = '>';
- Var
- I,J : Integer;
- begin
- SetLength(Result,Length(S));
- J:=0;
- For I:=1 to Length(S) do
- begin
- Inc(J);
- case S[i] of
- '"': W(j,Result,QuotStr);
- '&': W(J,Result,AmpStr);
- '<': W(J,Result,ltStr);
- // Escape whitespace using CharRefs to be consistent with W3 spec X 3.3.3
- #9: w(J,Result,'	');
- { #10: wrtStr('
');
- #13: wrtStr('
');}
- else
- Result[J]:=S[i];
- end;
- If (J=Length(Result)) and (I<Length(S)) then
- SetLength(Result,J+Length(S)-I);
- end;
- If J<>Length(Result) then
- SetLength(Result,J);
- end;
- Procedure TPackage.GetManifest(Manifest : TStrings);
- Var
- S : String;
- Release,Minor,Major : Word;
- i : Integer;
- begin
- With Manifest do
- begin
- Add(Format('<package name="%s">',[QuoteXml(Name)]));
- SplitVersion(Version,Release,Minor,Major,S);
- Add(Format('<version release="%d" major="%d" minor="%d" suffix="%s"/>',[Release,Minor,Major,QuoteXMl(S)]));
- Add(Format('<filename>%s</filename>',[QuoteXml(FileName)]));
- Add(Format('<author>%s</author>',[QuoteXml(Author)]));
- if ExternalURL<>'' then
- Add(Format('<externalurl>%s</externalurl>',[QuoteXml(ExternalURL)]));
- Add(Format('<email>%s</email>',[QuoteXMl(Email)]));
- S:=Description;
- If (S<>'') then
- Add(Format('<description>%s</description>',[QuoteXML(S)]));
- if HasDependencies then
- begin
- If (Dependencies.Count>0) then
- begin
- Add('<dependencies>');
- for I:=0 to Dependencies.Count-1 do
- Add(Format('<dependency><package packagename="%s"/></dependency>',[QuoteXML(Dependencies[i])]));
- Add('</dependencies>');
- end;
- end;
- Add('</package>');
- end;
- end;
- function TPackage.GetStrings(AIndex: integer): TStrings;
- Function EnsureStrings(Var S : TStrings) : TStrings;
- begin
- If (S=Nil) then
- S:=TStringList.Create;
- Result:=S;
- end;
- begin
- Result:=Nil;
- Case AIndex Of
- 0 : Result:=EnsureStrings(FUnitPath);
- 1 : Result:=EnsureStrings(FObjectPath);
- 2 : Result:=EnsureStrings(FIncludePath);
- 3 : begin
- Result:=EnsureStrings(FDependencies);
- With TStringList(Result) do
- if (Count=0) then
- begin
- Sorted:=True;
- Duplicates:=dupError;
- end;
- end;
- 4 : Result:=EnsureStrings(FInstallFiles);
- 5 : Result:=EnsureStrings(FCleanFiles);
- 6 : Result:=EnsureStrings(FArchiveFiles);
- end;
- end;
- procedure TPackage.SetCommands(const AValue: TCommands);
- begin
- Commands.Assign(AValue);
- end;
- procedure TPackage.SetStrings(AIndex: integer; const AValue: TStrings);
- begin
- GetStrings(AIndex).Assign(AValue);
- end;
- constructor TPackage.Create(ACollection: TCollection);
- Var
- L : TStringList;
- begin
- inherited Create(ACollection);
- FTargets:=TTargets.Create(TTarget);
- FSources:=TSources.Create(TSource);
- L:=TStringList.Create;
- FDependencies:=L;
- FInstallFiles:=TStringList.Create;
- FCleanFiles:=TStringList.Create;
- FArchiveFiles:=TStringList.Create;
- end;
- destructor TPackage.destroy;
- begin
- FreeAndNil(FDependencies);
- FreeAndNil(FInstallFiles);
- FreeAndNil(FCleanFiles);
- FreeAndNil(FArchiveFiles);
- FreeAndNil(FIncludePath);
- FreeAndNil(FObjectPath);
- FreeAndNil(FUnitPath);
- FreeAndNil(FSources);
- FreeAndNil(FTargets);
- inherited destroy;
- end;
- function TPackage.AddTarget(AName: String): TTarget;
- begin
- Result:=Targets.Add as TTarget;
- Result.Name:=AName;
- end;
- procedure TPackage.AddDependency(AName: String);
- begin
- If FDependencies.IndexOf(AName)=-1 then
- FDependencies.Add(AName);
- end;
- procedure TPackage.AddInstallFile(AFileName: String);
- begin
- FInstallFiles.add(AFileName);
- end;
- procedure TPackage.GetCleanFiles(List: TStrings; Const APrefix : String; AOS : TOS);
- Var
- I : Integer;
- begin
- AddStrings(List,CleanFiles,APrefix);
- For I:=0 to FTargets.Count-1 do
- FTargets.TargetItems[I].GetCleanFiles(List,APrefix,AOS);
- end;
- procedure TPackage.GetSourceFiles(List: TStrings);
- Var
- I : Integer;
- begin
- // AddStrings(List,SourceFiles,APrefix);
- For I:=0 to FSources.Count-1 do
- FSources.SourceItems[I].GetSourceFiles(List);
- end;
- procedure TPackage.GetInstallFiles(List: TStrings;Types : TTargetTypes;Const APrefix : String; AOS : TOS);
- Var
- I : Integer;
- T : TTarget;
- begin
- AddStrings(List,InstallFiles,APrefix);
- For I:=0 to FTargets.Count-1 do
- begin
- T:=FTargets.TargetItems[I];
- if (T.TargetType in Types) then
- T.GetInstallFiles(List,APrefix,AOS);
- end;
- end;
- procedure TPackage.GetArchiveFiles(List: TStrings;Const APrefix : String; AOS : TOS);
- Var
- I : Integer;
- begin
- If (OS=[]) or (AOS in OS) then
- begin
- AddStrings(List,ArchiveFiles,APrefix);
- For I:=0 to FTargets.Count-1 do
- FTargets.TargetItems[I].GetArchiveFiles(List,APrefix,AOS);
- end;
- end;
- Function TPackage.GetDescription : string;
- Var
- FN : String;
- L : TStringList;
- begin
- If (FDescription<>'') then
- Result:=FDescription
- else
- If (FDescriptionFile<>'') then
- begin
- // Always relative to binary name.
- FN:=ExtractFilePath(ParamStr(0));
- FN:=FN+FDescriptionFile;
- If FileExists(FN) then
- begin
- L:=TStringList.Create;
- Try
- L.LoadFromFile(FN);
- Result:=L.Text;
- Finally
- L.Free;
- end;
- end;
- end;
- end;
- Function TPackage.GetFileName : string;
- begin
- If (FFileName<>'') then
- Result:=FFileName
- else
- Result:=Name+'-'+Version+'.zip';
- end;
- { TPackages }
- function TPackages.GetPackage(AName : String): TPackage;
- begin
- Result:=TPackage(ItemByName(AName))
- end;
- function TPackages.GetPackageItem(AIndex : Integer): TPackage;
- begin
- Result:=TPackage(Items[AIndex]);
- end;
- procedure TPackages.SetPackageItem(AIndex : Integer; const AValue: TPackage);
- begin
- Items[AIndex]:=AValue;
- end;
- function TPackages.AddPackage(const AName: String): TPackage;
- begin
- Result:=Add as TPackage;
- Result.Name:=AName;
- end;
- { TInstaller }
- function TInstaller.GetStrings(AIndex : Integer): TStrings;
- begin
- CheckDefaultPackage;
- Case AIndex of
- 0: Result:=DefaultPackage.Dependencies;
- 1: Result:=DefaultPackage.InstallFiles;
- 2: Result:=DefaultPackage.CleanFiles;
- 3: Result:=DefaultPackage.ArchiveFiles;
- end;
- end;
- Function TInstaller.GetPackageString(Index : Integer) : String;
- Var
- P : TPackage;
- begin
- CheckDefaultPackage;
- P:=DefaultPackage;
- Case Index of
- 0 : Result:=P.Author;
- 1 : Result:=P.Directory;
- 2 : Result:=P.License;
- 3 : Result:=P.Options;
- 4 : Result:=P.ExternalURL;
- 5 : Result:=P.Email;
- 6 : Result:=P.Description;
- 7 : Result:=P.DescriptionFile;
- 8 : Result:=P.Version;
- 9 : Result:=P.FileName;
- end;
- end;
- Procedure TInstaller.SetPackageString(Index : Integer; AValue : String);
- Var
- P : TPackage;
- begin
- CheckDefaultPackage;
- P:=DefaultPackage;
- Case Index of
- 0 : P.Author:=AValue;
- 1 : P.Directory:=AValue;
- 2 : P.License:=AValue;
- 3 : P.Options:=AValue;
- 4 : P.ExternalURL:=AValue;
- 5 : P.Email:=AValue;
- 6 : P.Description:=AValue;
- 7 : P.DescriptionFile:=AValue;
- 8 : P.Version:=AValue;
- 9 : P.FileName:=AValue;
- end;
- end;
- function TInstaller.GetOSes: TOSes;
- begin
- CheckDefaultPackage;
- Result:=DefaultPackage.OS;
- end;
- function TInstaller.GetTargets: TTargets;
- begin
- CheckDefaultPackage;
- Result:=DefaultPackage.Targets;
- end;
- function TInstaller.GetSources: TSources;
- begin
- CheckDefaultPackage;
- Result:=DefaultPackage.Sources;
- end;
- procedure TInstaller.SetDefaultPackage(const AValue: TPackage);
- begin
- if FDefaultPackage=AValue then exit;
- FDefaultPackage:=AValue;
- end;
- procedure TInstaller.SetDefaults(const AValue: TDefaults);
- begin
- FDefaults.Assign(AValue);
- end;
- procedure TInstaller.SetStrings(AIndex : Integer; const AValue: TStrings);
- Var
- Res : TStrings;
- begin
- CheckDefaultPackage;
- Case AIndex of
- 0: Res:=DefaultPackage.Dependencies;
- 1: Res:=DefaultPackage.InstallFiles;
- 2: Res:=DefaultPackage.CleanFiles;
- 3: Res:=DefaultPackage.ArchiveFiles;
- end;
- Res.Assign(Avalue);
- end;
- procedure TInstaller.SetOses(const AValue: TOSes);
- begin
- CheckDefaultPackage;
- DefaultPackage.OS:=AValue;
- end;
- procedure TInstaller.Log(Level: TVerboseLevel; const Msg: String);
- begin
- If Level in FLogLevels then
- Writeln(StdErr,Msg);
- end;
- procedure TInstaller.CreatePackages;
- begin
- FPAckages:=TPackages.Create(TPackage);
- end;
- procedure TInstaller.CreateBuildEngine;
- begin
- FBuildEngine:=TBuildEngine.Create(Self);
- FBuildEngine.Defaults:=Defaults;
- FBuildEngine.ListMode:=FListMode;
- FBuildEngine.OnLog:[email protected];
- end;
- procedure TInstaller.CheckDefaultPackage;
- begin
- If (FDefaultPackage=Nil) then
- Raise EInstallerError.Create(SErrNoPackage);
- end;
- procedure TInstaller.Error(Msg: String);
- begin
- Raise EInstallerError.Create(Msg);
- end;
- procedure TInstaller.Error(Fmt: String; Args: array of const);
- begin
- Raise EInstallerError.CreateFmt(Fmt,Args);
- end;
- Function TInstaller.StartPackage(const AName: String) : TPackage;
- begin
- FDefaultPackage:=FPackages.AddPackage(AName);
- Result:=FDefaultPackage;
- end;
- procedure TInstaller.EndPackage;
- begin
- FDefaultPackage:=Nil;
- end;
- procedure TInstaller.AnalyzeOptions;
- Function CheckOption(Index : Integer;Short,Long : String): Boolean;
- var
- O : String;
- begin
- O:=Paramstr(Index);
- Result:=(O='-'+short) or (O='--'+long) or (copy(O,1,Length(Long)+3)=('--'+long+'='));
- end;
- Function CheckCommand(Index : Integer;Short,Long : String): Boolean;
- var
- O : String;
- begin
- O:=Paramstr(Index);
- Result:=(O='-'+short) or (O=long);
- end;
- Function OptionArg(Var Index : Integer) : String;
- Var
- P : Integer;
- begin
- if (Length(ParamStr(Index))>1) and (Paramstr(Index)[2]<>'-') then
- begin
- If Index<ParamCount then
- begin
- Inc(Index);
- Result:=Paramstr(Index);
- end
- else
- Error(SErrNeedArgument,[Index,ParamStr(Index)]);
- end
- else If length(ParamStr(Index))>2 then
- begin
- P:=Pos('=',Paramstr(Index));
- If (P=0) then
- Error(SErrNeedArgument,[Index,ParamStr(Index)])
- else
- begin
- Result:=Paramstr(Index);
- Delete(Result,1,P);
- end;
- end;
- end;
- Var
- I : Integer;
- Nodefaults : Boolean;
- DefaultsFileName : string;
- begin
- I:=0;
- NoDefaults:=False;
- FListMode:=False;
- While (I<ParamCount) do
- begin
- Inc(I);
- if CheckCommand(I,'m','compile') then
- FRunMode:=rmCompile
- else if CheckCommand(I,'b','build') then
- FRunMode:=rmBuild
- else if CheckCommand(I,'i','install') then
- FRunMode:=rmInstall
- else if CheckCommand(I,'c','clean') then
- FRunMode:=rmClean
- else if CheckCommand(I,'a','archive') then
- FRunMode:=rmarchive
- else if CheckCommand(I,'M','manifest') then
- FRunMode:=rmManifest
- else if CheckCommand(I,'M','listsources') then
- FRunMode:=rmListSources
- else if CheckOption(I,'h','help') then
- Usage('',[])
- else if Checkoption(I,'C','CPU') then
- Defaults.CPU:=StringToCPU(OptionArg(I))
- else if Checkoption(I,'O','OS') then
- Defaults.OS:=StringToOS(OptionArg(I))
- else if Checkoption(I,'t','target') then
- Defaults.Target:=OptionArg(I)
- else if CheckOption(I,'l','list-commands') then
- FListMode:=True
- else if Checkoption(I,'P','prefix') then
- Defaults.Prefix:=OptionArg(I)
- else if Checkoption(I,'n','nodefaults') then
- NoDefaults:=true
- else if CheckOption(I,'B','baseinstalldir') then
- Defaults.BaseInstallDir:=OptionArg(I)
- else if CheckOption(I,'r','compiler') then
- Defaults.Compiler:=OptionArg(I)
- else if CheckOption(I,'f','config') then
- DefaultsFileName:=OptionArg(I)
- else if CheckOption(I,'v','verbose') then
- begin
- Try
- FLogLevels:=TVerboseLevels(StringToSet(PtypeInfo(TypeInfo(TVerboseLevels)),OptionArg(I)));
- except
- FLogLevels:=AllMessages;
- end;
- end
- else
- begin
- Usage(SErrInValidArgument,[I,ParamStr(I)]);
- end;
- end;
- If Not NoDefaults then
- Defaults.LocalInit(DefaultsFileName);
- Defaults.CompilerDefaults;
- {$ifdef debug}
- FLogLevels:=AllMessages;
- {$endif}
- end;
- procedure TInstaller.Usage(FMT: String; Args: array of const);
- Procedure WriteCmd(LC : String; Msg : String);
- begin
- Writeln(stderr,Format(' %-12s %s',[LC,MSG]));
- end;
- Procedure WriteOption(C: Char; LC : String; Msg : String);
- begin
- Writeln(stderr,Format(' -%s --%-16s %s',[C,LC,MSG]));
- end;
- Procedure WriteArgOption(C: Char; LC : String; Msg : String);
- begin
- Writeln(stderr,Format(' -%s --%-20s %s',[C,LC+'='+SValue,MSG]));
- end;
- begin
- If (FMT<>'') then
- Writeln(stderr,Format(Fmt,Args));
- Writeln(stderr,Format(SHelpUsage,[Paramstr(0)]));
- Writeln(stderr,SHelpCommand);
- WriteCmd('compile',SHelpCompile);
- WriteCmd('build',SHelpBuild);
- WriteCmd('install',SHelpInstall);
- WriteCmd('clean',SHelpClean);
- WriteCmd('archive',SHelpArchive);
- WriteCmd('manifest',SHelpManifest);
- Writeln(stderr,SHelpCmdOptions);
- WriteOption('h','help',SHelpHelp);
- WriteOption('l','list-commands',SHelpList);
- WriteOption('n','nodefaults',SHelpNoDefaults);
- WriteOption('v','verbose',SHelpVerbose);
- WriteArgOption('C','CPU',SHelpCPU);
- WriteArgOption('O','OS',SHelpOS);
- WriteArgOption('t','target',SHelpTarget);
- WriteArgOption('P','prefix',SHelpPrefix);
- WriteArgOption('B','baseinstalldir',SHelpBaseInstalldir);
- WriteArgOption('r','compiler',SHelpCompiler);
- WriteArgOption('f','config',SHelpConfig);
- Writeln(stderr,'');
- If (FMT<>'') then
- halt(1)
- else
- halt(0);
- end;
- procedure TInstaller.Compile(Force: Boolean);
- begin
- FBuildEngine.ForceCompile:=Force;
- FBuildEngine.Compile(FPackages);
- end;
- procedure TInstaller.Clean;
- begin
- BuildEngine.Clean(FPackages);
- end;
- procedure TInstaller.Install;
- begin
- BuildEngine.Install(FPackages);
- end;
- procedure TInstaller.Archive;
- begin
- FBuildEngine.Archive(FPackages);
- end;
- procedure TInstaller.Manifest;
- Var
- L : TStrings;
- begin
- L:=TStringList.Create;
- Try
- Log(vlCommand,'Generating manifest.xml');
- L.Add('<?xml version="1.0"?>');
- BuildEngine.GetManifest(FPackages,L);
- L.SaveToFile('manifest.xml');
- Finally
- L.Free;
- end;
- end;
- procedure TInstaller.GetSourceFiles;
- Var
- L : TStrings;
- begin
- L:=TStringList.Create;
- Try
- Log(vlCommand,'Generating sources.xml');
- L.Add('<?xml version="1.0"?>');
- BuildEngine.GetSourceFiles(FPackages,L);
- L.SaveToFile('sources.xml');
- Finally
- L.Free;
- end;
- end;
- constructor TInstaller.Create(AOWner: TComponent);
- begin
- inherited Create(AOWner);
- FDefaults:=TDefaults.Create;
- AnalyzeOptions;
- CreatePackages;
- end;
- destructor TInstaller.destroy;
- begin
- FreeAndNil(FDefaults);
- inherited destroy;
- end;
- procedure TInstaller.CheckPackages;
- begin
- If (FPackages.Count=0) then
- Error(SErrNoPackagesDefined);
- // Check for other obvious errors ?
- end;
- Function TInstaller.Run : Boolean;
- begin
- Result:=True;
- try
- CheckPackages;
- CreateBuildEngine;
- Case RunMode of
- rmCompile : Compile(False);
- rmBuild : Compile(True);
- rmInstall : Install;
- rmArchive : Archive;
- rmClean : Clean;
- rmManifest : Manifest;
- rmListSources : GetSourceFiles;
- end;
- except
- On E : Exception do
- begin
- Writeln(StdErr,SErrInstaller);
- Writeln(StdErr,E.Message);
- Result:=False;
- end;
- end;
- end;
- function TInstaller.AddTarget(AName: String): TTarget;
- begin
- CheckDefaultPackage;
- Result:=DefaultPackage.AddTarget(AName);
- end;
- procedure TInstaller.AddDependency(AName: String);
- begin
- CheckDefaultPackage;
- DefaultPackage.AddDependency(AName);
- end;
- { TBuildEngine }
- procedure TBuildEngine.SetDefaults(const AValue: TDefaults);
- begin
- FDefaults.Assign(AValue);
- end;
- procedure TBuildEngine.SetTargetDir(const AValue: String);
- begin
- if FTargetDir=AValue then exit;
- FTargetDir:=AValue;
- end;
- procedure TBuildEngine.Error(Msg: String);
- begin
- Raise EInstallerError.Create(Msg);
- end;
- procedure TBuildEngine.Error(Fmt: String; Args: array of const);
- begin
- Raise EInstallerError.CreateFmt(Fmt,Args);
- end;
- constructor TBuildEngine.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FDefaults:=TDefaults.Create;
- // Maybe this should be the current directory ?
- // Or have it as a command-line option.
- // Would allow to put all 'installers' in one dir and call them
- // With --start-dir=/path/to/sources.
- FStartDir:=includeTrailingPathDelimiter(GetCurrentDir);
- end;
- procedure TBuildEngine.ExecuteCommand(Cmd: String; Args : String; IgnoreError : Boolean = False);
- Var
- E : Integer;
- begin
- Log(vlCommand,SLogExecutingCommand,[Cmd,Args]);
- // We should check cmd for spaces, and move all after first space to args.
- E:=ExecuteProcess(cmd,args);
- If (E<>0) and (not IgnoreError) then
- Error(SErrExternalCommandFailed,[Cmd,E]);
- end;
- procedure TBuildEngine.SysCopyFile(Const Src,Dest : String);
- Var
- D,S : String;
- Fin,FOut : TFileStream;
- Count : Int64;
- A : Integer;
- begin
- Log(vlCommand,SLogCopyingFile,[Src,Dest]);
- FIn:=TFileStream.Create(Src,fmopenRead);
- Try
- D:=IncludeTrailingPathDelimiter(Dest);
- If DirectoryExists(D) then
- S:=D+ExtractFileName(Src)
- else
- S:=Dest;
- FOut:=TFileStream.Create(S,fmCreate);
- Try
- Count:=Fout.CopyFrom(FIn,0);
- If (Count<>Fin.Size) then
- Error(SErrCopyingFile,[Src,S]);
- Finally
- FreeAndNil(Fout);
- end;
- A:=FileGetDate(FIn.Handle);
- If (A=-1) then
- log(vlWarning,SWarnFailedToGetTime,[Src])
- else
- if FileSetDate(S,A)<>0 then
- Log(vlWarning,SWarnFailedToSetTime,[S]);
- finally
- FreeAndNil(Fin);
- end;
- end;
- procedure TBuildEngine.SysMoveFile(Const Src,Dest : String);
- Var
- S : String;
- begin
- If DirectoryExists(IncludeTrailingPathDelimiter(Dest)) then
- S:=IncludeTrailingPathDelimiter(Dest)+ExtractFileName(Src)
- else
- S:=Dest;
- If Not RenameFile(Src,S) then
- begin
- Try
- SysCopyFile(Src,S);
- SysDeleteFile(Src);
- Except
- On E : Exception Do
- Error(SErrMovingFile,[Src,S]);
- end;
- end;
- end;
- procedure TBuildEngine.SysDeleteFile(Const AFileName : String);
- begin
- if not FileExists(AFileName) then
- Log(vlWarning,SWarnFileDoesNotExist,[AFileName])
- else If Not DeleteFile(AFileName) then
- Error(SErrDeletingFile,[AFileName]);
- end;
- procedure TBuildEngine.SysArchiveFiles(List: TStrings;Const AFileName: String);
- begin
- If Not (Assigned(OnArchivefiles) or Assigned(ArchiveFilesProc)) then
- Raise EInstallerError.Create(SErrNoArchiveSupport);
- If Assigned(ArchiveFilesProc) then
- ArchiveFilesProc(AFileName,List)
- else
- OnArchiveFiles(AFileName,List);
- end;
- procedure TBuildEngine.Log(Level: TVerboseLevel; const Msg: String);
- begin
- If Assigned(FOnLog) then
- FOnLog(Level,Msg);
- end;
- procedure TBuildEngine.Log(Level: TVerboseLevel; const Fmt: String;
- Args: array of const);
- begin
- Log(Level,Format(Fmt,Args));
- end;
- procedure TBuildEngine.EnterDir(ADir: String);
- Var
- D : String;
- begin
- D:=FStartDir;
- D:=D+ADir;
- Log(vlInfo,SLogEnterDir,[D]);
- If Not SetCurrentDir(D) then
- Error(SErrChangeDirFailed,[D]);
- end;
- procedure TBuildEngine.CmdCopyFiles(List: TStrings; Const DestDir: String);
- Var
- Args : String;
- I : Integer;
- begin
- CmdCreateDir(DestDir);
- If (Defaults.Copy<>'') then
- begin
- Args:=FileListToString(List,'');
- Args:=Args+' '+DestDir;
- ExecuteCommand(Defaults.Copy,Args);
- end
- else
- For I:=0 to List.Count-1 do
- SysCopyFile(List[i],DestDir);
- end;
- procedure TBuildEngine.CmdCreateDir(DestDir: String);
- begin
- If (Defaults.MkDir<>'') then
- ExecuteCommand(Defaults.MkDir,DestDir)
- else
- If not ForceDirectories(DestDir) then
- Error(SErrCreatingDirectory,[DestDir]);
- end;
- procedure TBuildEngine.CmdMoveFiles(List: TStrings; Const DestDir: String);
- Var
- Args : String;
- I : Integer;
- begin
- CmdCreateDir(DestDir);
- If (Defaults.Move<>'') then
- begin
- Args:=FileListToString(List,'');
- Args:=Args+' '+DestDir;
- ExecuteCommand(Defaults.Move,Args);
- end
- else
- For I:=0 to List.Count-1 do
- SysMoveFile(List[i],DestDir);
- end;
- procedure TBuildEngine.CmdDeleteFiles(List: TStrings);
- Var
- Args : String;
- I : Integer;
- begin
- If (Defaults.Remove<>'') then
- begin
- Args:=FileListToString(List,'');
- ExecuteCommand(Defaults.Remove,Args);
- end
- else
- For I:=0 to List.Count-1 do
- SysDeleteFile(List[i]);
- end;
- procedure TBuildEngine.CmdArchiveFiles(List: TStrings; Const ArchiveFile: String);
- Var
- S,C,O : String;
- begin
- If (Defaults.Archive='') then
- SysArchiveFiles(List,ArchiveFile)
- else
- begin
- S:=FileListToString(List,'');
- SplitCommand(Defaults.Archive,C,O);
- If (O='') then
- O:=ArchiveFile+' '+S
- else
- O:=Substitute(O,['ARCHIVE',ArchiveFile,'FILESORDIRS']);
- ExecuteCommand(C,O);
- end;
- end;
- Function TBuildEngine.FileNewer(Src,Dest : String) : Boolean;
- Var
- DS,DD : Longint;
- D1,D2 : TDateTime;
- begin
- DS:=FileAge(Src);
- DD:=FileAge(Dest);
- D1:=FileDateToDateTime(DS);
- D2:=FileDateToDateTime(DD);
- Log(vlDebug,SLogCompilingFileTimes,[Src,DateTimeToStr(D1),Dest,DateTimeToStr(D2)]);
- Result:=D1>=D2;
- If Result then
- Log(vlCompare,SLogSourceNewerDest,[Src,DateTimeToStr(D1),Dest,DateTimeToStr(D2)]);
- end;
- procedure TBuildEngine.ExecuteCommands(Commands: TCommands; At: TCommandAt);
- Var
- C : TCommand;
- I : Integer;
- Cmd,O : String;
- E : Boolean;
- begin
- For I:=0 to Commands.Count-1 do
- begin
- C:=Commands.CommandItems[i];
- if (C.At=At) then
- begin
- E:=True;
- If (C.SourceFile<>'') and (C.DestFile<>'') then
- E:=FileNewer(C.SourceFile,IncludeTrailingPathDelimiter(Dictionary.GetValue('OUTPUTDIR'))+C.DestFile);
- If E then
- begin
- If Assigned(C.BeforeCommand) then
- C.BeforeCommand(C);
- O:=Substitute(C.Options,['SOURCE',C.SourceFile,'DEST',C.DestFile]);
- Cmd:=C.Command;
- If (ExtractFilePath(Cmd)='') then
- Cmd:=FileSearch(Cmd,GetEnvironmentvariable('PATH'));
- ExecuteCommand(Cmd,O,C.IgnoreResult);
- If Assigned(C.AfterCommand) then
- C.AfterCommand(C);
- end;
- end;
- end;
- end;
- // Relative to startdir.
- Function TBuildEngine.GetTargetDir(APackage : TPackage; ATarget : TTarget; AbsolutePath : Boolean = False) : String;
- begin
- If AbsolutePath then
- Result:=IncludeTrailingPathDelimiter(FStartDir)
- else
- Result:='';
- If (APackage.Directory<>'') then
- Result:=Result+IncludeTrailingPathDelimiter(APackage.Directory);
- If (ATarget.Directory<>'') then
- Result:=IncludeTrailingPathDelimiter(Result+ATarget.Directory);
- end;
- Function TBuildEngine.TargetOK(Target : TTarget) : Boolean;
- begin
- Result:=(Target.TargetType in [ttUnit,ttProgram])
- and
- ((Target.CPU=[]) or (Defaults.CPU in Target.CPU))
- and
- ((Target.OS=[]) or (Defaults.OS in Target.OS));
- If not Result then
- begin
- log(vldebug,'Target is not a unit or program');
- If Not ((Target.CPU=[]) or (Defaults.CPU in Target.CPU)) then
- Log(vldebug,'Target has wrong CPU: '+CPUsToString(Target.CPU));
- if not ((Target.OS=[]) or (Defaults.OS in Target.OS)) then
- Log(vldebug,'Target has wrong OS: '+OSesToString(Target.OS));
- end;
- end;
- Function TBuildEngine.NeedsCompile(Target: TTarget): Boolean;
- Var
- I : Integer;
- T : TTarget;
- OD,SD,SFN,OFN : String;
- begin
- Result:=False;
- OD:=FCurrentOutputDir;
- If (OD<>'') then
- OD:=IncludeTrailingPathDelimiter(OD);
- OFN:=OD+Target.GetOutPutFileName(Defaults.OS);
- SD:=Target.Directory;
- If (SD<>'') then
- SD:=IncludeTrailingPathDelimiter(SD);
- Result:=Not FileExists(OFN);
- // Check dependencies
- If not Result then
- If Target.HasDependencies then
- begin
- ResolveDependencies(Target.Dependencies,Target.Collection as TTargets);
- I:=0;
- While (Not Result) and (I<Target.Dependencies.Count) do
- begin
- T:=TTarget(Target.Dependencies.Objects[i]);
- If (T<>Nil) then
- Result:=NeedsCompile(T)
- else // if it is a filename, check dates.
- if FileExists(Target.Dependencies[i]) then
- Result:=FileNewer(Target.Dependencies[i],OFN)
- else if FileExists(SD+Target.Dependencies[i]) then
- Result:=FileNewer(SD+Target.Dependencies[i],OFN);
- Inc(I)
- end;
- end;
- If not Result then
- begin
- SFN:=SD+Target.SourceFileName;
- If (ExtractFileExt(SFN)='') then
- if FileExists(SFN+'.pp') then
- SFN:=SFN+'.pp'
- else
- SFN:=SFN+'.pas';
- // Writeln('Checking : ',OFN,' against ',SFN);
- Result:=FileNewer(SFN,OFN);
- // here we should check file timestamps.
- end;
- end;
- Function TBuildEngine.GetCompilerCommand(APackage : TPackage; Target : TTarget) : String;
- Var
- PD,TD,OD,RD : String;
- begin
- PD:=IncludeTrailingPathDelimiter(GetPackageDir(APackage,True));
- OD:=IncludeTrailingPathDelimiter(GetOutputDir(APackage,True));
- RD:=ExtractRelativePath(PD,OD);
- If Target.TargetType in ProgramTargets then
- Result:='-FE.' // Make this relative to target directory.
- else
- Result:='-FU'+RD;
- If Target.Mode<>cmFPC then
- Result:=Result+' -M'+ModeToString(Target.Mode)
- else If Defaults.Mode<>cmFPC then
- Result:=Result+' -M'+ModeToString(Defaults.Mode);
- If (Defaults.Options<>'') then
- Result:=Result+' '+Defaults.Options;
- If (APackage.Options<>'') then
- Result:=Result+' '+APackage.Options;
- If APackage.HasUnitPath then
- AddStrings(Result,APackage.UnitPath,'-Fu');
- If APackage.HasIncludePath then
- AddStrings(Result,APackage.IncludePath,'-Fi');
- If APackage.HasObjectPath then
- AddStrings(Result,APackage.ObjectPath,'-Fo');
- If Target.HasUnitPath then
- AddStrings(Result,Target.UnitPath,'-Fu');
- If Target.HasIncludePath then
- AddStrings(Result,Target.IncludePath,'-Fi');
- If Target.HasObjectPath then
- AddStrings(Result,Target.ObjectPath,'-Fo');
- If (Target.Options<>'') then
- Result:=Result+' '+Target.Options;
- TD:=Target.Directory;
- if (TD<>'') then
- TD:=IncludeTrailingPathDelimiter(TD);
- Result:=Result+' '+TD+Target.SourceFileName;
- end;
- Function TBuildEngine.GetCompiler : String;
- Var
- S : String;
- begin
- // Cache in FCompiler for speed.
- If (FCompiler='') then
- begin
- FCompiler:=Defaults.Compiler;
- If (ExtractFilePath(FCompiler)='') then
- begin
- S:=FileSearch(FCompiler,GetEnvironmentVariable('PATH'));
- If (S<>'') then
- FCompiler:=S;
- end;
- end;
- Result:=FCompiler;
- end;
- procedure TBuildEngine.Compile(Target: TTarget);
- Var
- S : String;
- begin
- if Target.State in [tsNeutral,tsCompiling] then
- begin
- Log(vlInfo,SLogCompilingTarget,[Target.Name]);
- If Target.HasCommands then
- ExecuteCommands(Target.Commands,caBeforeCompile);
- If Assigned(Target.BeforeCompile) then
- Target.BeforeCompile(Target);
- S:=GetCompilerCommand(FCurrentPackage,Target);
- ExecuteCommand(GetCompiler,S);
- Target.FTargetState:=tsCompiled;
- If Assigned(Target.AfterCompile) then
- Target.AfterCompile(Target);
- If Target.HasCommands then
- ExecuteCommands(Target.Commands,caAfterCompile);
- end
- else if Target.State<>tsCompiled then
- Log(vlWarning,'Attempting to compile non-neutral target: '+Target.Name);
- end;
- procedure TBuildEngine.FixDependencies(Target: TTarget);
- Var
- I : Integer;
- T : TTarget;
- begin
- Log(vlDebug,'Checking dependencies for target: '+Target.Name);
- ResolveDependencies(Target.Dependencies,Target.Collection as TTargets);
- If Target.HasDependencies then
- For I:=0 to Target.Dependencies.Count-1 do
- begin
- T:=TTarget(Target.Dependencies.Objects[i]);
- If Assigned(T) then
- begin
- If (T.State=tsCompiling) then
- Log(vlWarning,SWarnCircularDependency,[Target.Name,T.Name])
- else
- Compile(T)
- end
- else if Not FileExists(Target.Dependencies[i]) then
- Error(SErrDepUnknownTarget,[Target.Name,Target.Dependencies[i]]);
- end;
- end;
- function TBuildEngine.GetPackageDir(APackage: TPackage; AbsolutePath: Boolean
- ): String;
- begin
- If AbsolutePath then
- Result:= IncludeTrailingPathDelimiter(FStartDir)
- else
- Result:='';
- Result:=Result+APackage.Directory;
- If (Result<>'') then
- Result:= ExcludeTrailingPathDelimiter(Result)
- end;
- Function TBuildEngine.GetOutputDir(APackage : TPackage; AbsolutePath : Boolean = False) : String;
- begin
- If (TargetDir<>'') then
- Result:=TargetDir
- else
- begin
- If AbsolutePath then
- Result:=IncludeTrailingPathDelimiter(FStartDir)
- else
- Result:='';
- If (APackage.Directory<>'') then
- Result:=IncludeTrailingPathDelimiter(Result+APackage.Directory);
- Result:=Result+'units'+PathDelim+Defaults.Target;
- end;
- end;
- procedure TBuildEngine.CreateOutputDir(APackage: TPackage);
- Var
- D : String;
- begin
- D:=GetOutputDir(APackage,True);
- If DirectoryExists(D) then
- Log(vlInfo,SLogOutputDirExists,[D])
- else
- begin
- Log(vlInfo,SLogCreatingOutputDir,[D]);
- CmdCreateDir(D);
- end;
- end;
- Function TBuildEngine.PackageOK(APackage : TPackage) : Boolean;
- begin
- Result:=((APackage.CPU=[]) or (Defaults.CPU in APackage.CPU))
- and
- ((APAckage.OS=[]) or (Defaults.OS in APackage.OS));
- end;
- procedure TBuildEngine.DoBeforeCompile(APackage: TPackage);
- begin
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caBeforeCompile);
- If Assigned(APackage.BeforeCompile) then
- APackage.BeforeCompile(APackage);
- end;
- procedure TBuildEngine.DoAfterCompile(APackage: TPackage);
- begin
- If Assigned(APackage.AfterCompile) then
- APackage.AfterCompile(APackage);
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caAfterCompile);
- end;
- procedure TBuildEngine.Compile(APackage: TPackage);
- Var
- T : TTarget;
- I : Integer;
- begin
- Log(vlInfo,SLogCompilingPackage,[APackage.Name]);
- FCurrentPackage:=APackage;
- FCurrentOutputDir:=GetOutputDir(APackage,True);
- Try
- If (APackage.Directory<>'') then
- EnterDir(APackage.Directory);
- CreateOutputDir(APackage);
- Dictionary.AddVariable('OUTPUTDIR',FCurrentOutputDir);
- DoBeforeCompile(APackage);
- Try
- For I:=0 to APackage.Targets.Count-1 do
- begin
- T:=APackage.Targets.TargetItems[i];
- Log(vlDebug,'Considering target: '+T.Name);
- If TargetOK(T) then
- If (T.State=tsNeutral) then
- begin
- If (FForceCompile or NeedsCompile(T)) then
- begin
- T.FTargetState:=tsCompiling;
- FixDependencies(T);
- Compile(T);
- end;
- T.FTargetState:=tsCompiled;
- end;
- end;
- DoAfterCompile(APackage);
- Finally
- If (APackage.Directory<>'') then
- EnterDir('');
- end;
- Finally
- FCurrentPackage:=Nil;
- FCurrentOutputDir:='';
- end;
- end;
- procedure TBuildEngine.CheckExternalPackage(Const APackageName : String);
- begin
- // A check needs to be implemented here.
- Log(vldebug,'Unresolved external dependency : %s',[APackageName]);
- end;
- procedure TBuildEngine.FixDependencies(APackage: TPackage);
- Var
- I : Integer;
- P : TPackage;
- begin
- if APackage.HasDependencies then
- For I:=0 to APAckage.Dependencies.Count-1 do
- begin
- P:=TPackage(Apackage.Dependencies.Objects[i]);
- If Assigned(P) then
- Compile(P) // If it already was compiled, then State<>tsNeutral, and it won't be compiled again.
- else
- CheckExternalPackage(Apackage.Dependencies[i]);
- end;
- end;
- Procedure TBuildEngine.InstallPackageFiles(APAckage : TPackage; tt : TTargetType; Const Src,Dest : String);
- Var
- List : TStringList;
- begin
- List:=TStringList.Create;
- Try
- APackage.GetInstallFiles(List,[tt],Src,Defaults.OS);
- if (List.Count>0) then
- CmdCopyFiles(List,Dest);
- Finally
- List.Free;
- end;
- end;
- procedure TBuildEngine.DoBeforeInstall(APackage: TPackage);
- begin
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caBeforeInstall);
- If Assigned(APackage.BeforeInstall) then
- APackage.BeforeInstall(APackage);
- end;
- procedure TBuildEngine.DoAfterInstall(APackage: TPackage);
- begin
- If Assigned(APackage.AfterInstall) then
- APackage.AfterInstall(APackage);
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caAfterInstall);
- end;
- procedure TBuildEngine.Install(APackage: TPackage);
- Var
- PD,D,O : String;
- begin
- If (Apackage.State<>tsCompiled) then
- Compile(APackage);
- Log(vlInfo,SLogInstallingPackage,[APackage.Name]);
- DoBeforeInstall(APackage);
- O:=IncludeTrailingPathDelimiter(GetOutputDir(APAckage));
- PD:=IncludeTrailingPathDelimiter(GetPackageDir(APackage));
- // units
- D:=IncludeTrailingPathDelimiter(Defaults.UnitInstallDir)+APackage.Name;
- InstallPackageFiles(APAckage,ttUnit,O,D);
- // Programs
- D:=IncludeTrailingPathDelimiter(Defaults.BinInstallDir);
- InstallPackageFiles(APAckage,ttProgram,PD,D);
- // Done.
- APackage.FTargetState:=tsInstalled;
- DoAfterInstall(APackage);
- end;
- procedure TBuildEngine.DoBeforeArchive(APackage: TPackage);
- begin
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caBeforeArchive);
- If Assigned(APackage.BeforeArchive) then
- APackage.BeforeArchive(APackage);
- end;
- procedure TBuildEngine.DoAfterArchive(APackage: TPackage);
- begin
- If Assigned(APackage.AfterArchive) then
- APackage.AfterArchive(APackage);
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caAfterArchive);
- end;
- procedure TBuildEngine.Archive(APackage: TPackage);
- Var
- L : TStrings;
- A : String;
- begin
- Log(vlInfo,SLogArchivingPackage,[APackage.Name]);
- DoBeforeArchive(Apackage);
- L:=TStringList.Create;
- Try
- APackage.GetInstallFiles(L,[ttUnit],TargetDir,Defaults.OS);
- A:=APackage.Name+ZipExt;
- CmdArchiveFiles(L,A);
- Finally
- L.Free;
- end;
- Writeln('Archiving : ',APackage.Name);
- DoAfterArchive(Apackage);
- end;
- procedure TBuildEngine.DoBeforeClean(APackage: TPackage);
- begin
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caBeforeClean);
- If Assigned(APackage.BeforeClean) then
- APackage.BeforeClean(APackage);
- end;
- procedure TBuildEngine.DoAfterClean(APackage: TPackage);
- begin
- If Assigned(APackage.AfterClean) then
- APackage.AfterClean(APackage);
- If APackage.HasCommands then
- ExecuteCommands(APackage.Commands,caAfterClean);
- end;
- procedure TBuildEngine.Clean(APackage: TPackage);
- Var
- O : String;
- List : TStringList;
- begin
- Log(vlInfo,SLogCleaningPackage,[APackage.Name]);
- DoBeforeClean(Apackage);
- O:=IncludeTrailingPathDelimiter(GetOutputDir(APAckage));
- List:=TStringList.Create;
- try
- APackage.GetCleanFiles(List,O,Defaults.OS);
- if (List.Count>0) then
- CmdDeleteFiles(List);
- Finally
- List.Free;
- end;
- DoAfterClean(Apackage);
- end;
- function TBuildEngine.NeedsCompile(APackage: TPackage): Boolean;
- Var
- I : Integer;
- P : TPackage;
- begin
- ResolveDependencies(APackage.Dependencies,(APackage.Collection as TPackages));
- Result:=False;
- I:=0;
- While (Not Result) and (I<APAckage.Dependencies.Count) do
- begin
- P:=TPackage(APAckage.Dependencies.Objects[i]);
- // I'm not sure whether the target dir is OK here ??
- Result:=Assigned(P) and NeedsCompile(P);
- Inc(I);
- end;
- If Not Result then
- begin
- I:=0;
- While (Not Result) and (I<APackage.Targets.Count) do
- begin
- Result:=NeedsCompile(APackage.Targets.TargetItems[i]);
- Inc(I);
- end;
- end;
- end;
- Procedure TBuildEngine.GetSourceFiles(APackage : TPackage; List : TStrings);
- var
- L : TStrings;
- i : integer;
- begin
- try
- L:=TStringList.Create;
- APackage.GetSourceFiles(L);
- List.Add(Format('<sources packagename=%s>',[APackage.Name]));
- for i:=0 to L.Count-1 do
- List.Add(Format('<source>%s</source>',[L[i]]));
- List.Add('</sources>');
- finally
- L.Free;
- end;
- end;
- Procedure TBuildEngine.GetManifest(APackage : TPackage; Manifest : TStrings);
- begin
- APackage.GetManifest(Manifest);
- end;
- procedure TBuildEngine.Compile(Packages: TPackages);
- Var
- I : Integer;
- P : TPackage;
- begin
- If Assigned(BeforeCompile) then
- BeforeCompile(Self);
- For I:=0 to Packages.Count-1 do
- begin
- P:=Packages.PackageItems[i];
- If PackageOK(P) then
- If (P.State=tsNeutral) then
- begin
- If (FForceCompile or NeedsCompile(P)) then
- begin
- P.FTargetState:=tsCompiling;
- FixDependencies(P);
- Compile(P);
- end;
- P.FTargetState:=tsCompiled;
- end;
- end;
- If Assigned(AfterCompile) then
- AfterCompile(Self);
- end;
- procedure TBuildEngine.Install(Packages: TPackages);
- Var
- I : Integer;
- P : TPackage;
- begin
- If Assigned(BeforeInstall) then
- BeforeInstall(Self);
- For I:=0 to Packages.Count-1 do
- begin
- P:=Packages.PackageItems[i];
- If PackageOK(P) then
- Install(P);
- end;
- If Assigned(AfterInstall) then
- AfterInstall(Self);
- end;
- procedure TBuildEngine.Archive(Packages: TPackages);
- Var
- I : Integer;
- P : TPackage;
- begin
- If Assigned(BeforeArchive) then
- BeforeArchive(Self);
- Log(vlDebug,'Build engine archiving.');
- For I:=0 to Packages.Count-1 do
- begin
- P:=Packages.PackageItems[i];
- If PackageOK(P) then
- Archive(P);
- end;
- If Assigned(AfterArchive) then
- AfterArchive(Self);
- end;
- procedure TBuildEngine.Clean(Packages: TPackages);
- Var
- I : Integer;
- P : TPackage;
- begin
- If Assigned(BeforeClean) then
- BeforeClean(Self);
- Log(vldebug,'Build engine cleaning.');
- For I:=0 to Packages.Count-1 do
- begin
- P:=Packages.PackageItems[i];
- If PackageOK(P) then
- Clean(P);
- end;
- If Assigned(AfterClean) then
- AfterClean(Self);
- end;
- Procedure TBuildEngine.GetManifest(Packages : TPackages; Manifest : TStrings);
- Var
- I : Integer;
- begin
- If Assigned(BeforeManifest) then
- BeforeManifest(Self);
- Manifest.Add('<packages>');
- For I:=0 to Packages.Count-1 do
- GetManifest(Packages.PackageItems[i],Manifest);
- Manifest.Add('</packages>');
- If Assigned(AfterManifest) then
- AfterManifest(Self);
- end;
- Procedure TBuildEngine.GetSourceFiles(Packages : TPackages; List : TStrings);
- Var
- I : Integer;
- begin
- List.Add('<packages>');
- For I:=0 to Packages.Count-1 do
- GetSourceFiles(Packages.PackageItems[i],List);
- List.Add('</packages>');
- end;
- { TTarget }
- function TTarget.GetHasStrings(AIndex: integer): Boolean;
- begin
- Result:=False;
- Case AIndex Of
- 0 : Result:=FUnitPath<>Nil;
- 1 : Result:=FObjectPath<>Nil;
- 2 : Result:=FIncludePath<>Nil;
- 3 : Result:=FDependencies<>Nil;
- end;
- end;
- function TTarget.GetCommands: TCommands;
- begin
- If FCommands=Nil then
- FCommands:=TCommands.Create(TCommand);
- Result:=FCommands;
- end;
- function TTarget.GetHasCommands: Boolean;
- begin
- Result:=(FCommands<>Nil);
- end;
- function TTarget.GetStrings(AIndex: integer): TStrings;
- Function EnsureStrings(Var S : TStrings) : TStrings;
- begin
- If (S=Nil) then
- S:=TStringList.Create;
- Result:=S;
- end;
- begin
- Result:=Nil;
- Case AIndex Of
- 0 : Result:=EnsureStrings(FUnitPath);
- 1 : Result:=EnsureStrings(FObjectPath);
- 2 : Result:=EnsureStrings(FIncludePath);
- 3 : Result:=EnsureStrings(FDependencies);
- end;
- end;
- procedure TTarget.SetCommands(const AValue: TCommands);
- begin
- end;
- procedure TTarget.SetStrings(AIndex: integer; const AValue: TStrings);
- begin
- GetStrings(AIndex).Assign(AValue);
- end;
- function TTarget.GetSourceFileName: String;
- begin
- Result:=Name+FExtension;
- end;
- function TTarget.GetUnitFileName: String;
- begin
- Result:=Name+UnitExt;
- end;
- function TTarget.GetObjectFileName: String;
- begin
- Result:=Name+ObjExt;
- end;
- function TTarget.GetRSTFileName: String;
- begin
- Result:=Name+RSText;
- end;
- function TTarget.GetProgramFileName(AnOS : TOS): String;
- begin
- if AnOS in [Go32v2,Win32,Win64,OS2] then
- Result:=Name+ExeExt
- else
- Result:=Name;
- end;
- constructor TTarget.Create(ACollection: TCollection);
- begin
- inherited Create(ACollection);
- FInstall:=True;
- end;
- destructor TTarget.Destroy;
- begin
- FreeAndNil(FUnitPath);
- FreeAndNil(FObjectPath);
- FreeAndNil(FIncludePath);
- FreeAndNil(FDependencies);
- inherited Destroy;
- end;
- function TTarget.GetOutputFileName(AOs: TOS): String;
- begin
- if TargetType in UnitTargets then
- Result:=GetUnitFileName
- else
- Result:=GetProgramFileName(AOs);
- end;
- procedure TTarget.SetName(const AValue: String);
- Var
- D,N,E : String;
- begin
- N:=FixPath(AValue);
- D:=ExtractFilePath(N);
- E:=ExtractFileExt(N);
- N:=ExtractFileName(N);
- If (E<>'') then
- N:=Copy(N,1,Length(N)-Length(E));
- inherited SetName(N);
- FExtension:=E;
- FDirectory:=D;
- end;
- procedure TTarget.GetCleanFiles(List: TStrings; APrefix : String; AnOS : TOS);
- begin
- If (OS=[]) or (AnOS in OS) then
- begin
- List.Add(APrefix+ObjectFileName);
- If (TargetType in [ttUnit,ttExampleUnit]) then
- List.Add(APrefix+UnitFileName)
- else If (TargetType in [ttProgram,ttExampleProgram]) then
- List.Add(APrefix+GetProgramFileName(AnOS));
- If ResourceStrings then
- List.Add(APrefix+RSTFileName);
- // Maybe add later ? AddStrings(List,CleanFiles);
- end;
- end;
- procedure TTarget.GetSourceFiles(List: TStrings; APrefix : String; AnOS : TOS);
- begin
- If (OS=[]) or (AnOS in OS) then
- begin
- List.Add(APrefix+ObjectFileName);
- If (TargetType in [ttUnit,ttExampleUnit]) then
- List.Add(APrefix+UnitFileName)
- else If (TargetType in [ttProgram,ttExampleProgram]) then
- List.Add(APrefix+GetProgramFileName(AnOS));
- If ResourceStrings then
- List.Add(APrefix+RSTFileName);
- // Maybe add later ? AddStrings(List,CleanFiles);
- end;
- end;
- procedure TTarget.GetInstallFiles(List: TStrings; APrefix : String; AnOS : TOS);
- begin
- If (OS=[]) or (AnOS in OS) then
- begin
- If Not (TargetType in [ttProgram,ttExampleProgram]) then
- List.Add(APrefix+ObjectFileName);
- If (TargetType in [ttUnit,ttExampleUnit]) then
- List.Add(APrefix+UnitFileName)
- else If (TargetType in [ttProgram,ttExampleProgram]) then
- List.Add(APrefix+GetProgramFileName(AnOS));
- If ResourceStrings then
- List.Add(APrefix+RSTFileName);
- // Maybe add later ? AddStrings(List,InstallFiles);
- end;
- end;
- procedure TTarget.GetArchiveFiles(List: TStrings; APrefix : String; AnOS : TOS);
- begin
- If (OS=[]) or (AnOS in OS) then
- begin
- List.Add(APrefix+SourceFileName);
- // Maybe add later ? AddStrings(List,ArchiveFiles);
- end;
- end;
- { TSource }
- constructor TSource.Create(ACollection: TCollection);
- begin
- inherited Create(ACollection);
- end;
- destructor TSource.Destroy;
- begin
- inherited Destroy;
- end;
- procedure TSource.GetSourceFiles(List: TStrings);
- begin
- List.Add(Name);
- end;
- { TCommands }
- function TCommands.GetCommand(Dest : String): TCommand;
- begin
- Result:=TCommand(ItemByName(Dest));
- end;
- function TCommands.GetCommandItem(Index : Integer): TCommand;
- begin
- Result:=TCommand(Items[Index]);
- end;
- procedure TCommands.SetCommandItem(Index : Integer; const AValue: TCommand);
- begin
- Items[Index]:=AValue;
- end;
- Function TCommands.AddCommand(const Cmd: String) : TCommand;
- begin
- Result:=AddCommand(fdefaultAt,Cmd,'','','');
- end;
- function TCommands.AddCommand(const Cmd, Options: String): TCommand;
- begin
- Result:=AddCommand(fdefaultAt,Cmd,Options,'','');
- end;
- function TCommands.AddCommand(const Cmd, Options, Dest, Source: String
- ): TCommand;
- begin
- Result:=AddCommand(fdefaultAt,Cmd,options,Dest,Source);
- end;
- Function TCommands.AddCommand(At: TCommandAt; const Cmd: String) : TCommand;
- begin
- Result:=AddCommand(At,Cmd,'','','');
- end;
- function TCommands.AddCommand(At: TCommandAt; const Cmd, Options: String
- ): TCommand;
- begin
- Result:=AddCommand(At,Cmd,Options,'','');
- end;
- function TCommands.AddCommand(At: TCommandAt; const Cmd, Options, Dest,
- Source: String): TCommand;
- begin
- Result:=Add as TCommand;
- Result.Command:=Cmd;
- Result.Options:=Options;
- Result.At:=At;
- Result.SourceFile:=Source;
- Result.DestFile:=Dest;
- end;
- Var
- DefInstaller : TInstaller = Nil;
- DefDictionary : TDictionary = Nil;
- Function Installer : TInstaller;
- begin
- If Not Assigned(DefInstaller) then
- DefInstaller:=InstallerClass.Create(Nil);
- Result:=DefInstaller;
- end;
- Function Defaults : TDefaults;
- begin
- Result:=Installer.Defaults;
- end;
- function Dictionary : TDictionary;
- begin
- If Not Assigned(DefDictionary) then
- DefDictionary:=DictionaryClass.Create(Nil);
- Result:=DefDictionary;
- end;
- { TValueItem }
- constructor TValueItem.Create(AValue: String);
- begin
- FValue:=AValue;
- end;
- { TFunctionItem }
- constructor TFunctionItem.Create(AFunc: TReplaceFunction);
- begin
- FFunc:=AFunc;
- end;
- { TDictionary }
- constructor TDictionary.Create(AOwner: TComponent);
- begin
- inherited Create(AOwner);
- FList:=TStringList.Create;
- FList.Sorted:=True;
- FList.Duplicates:=dupError;
- end;
- destructor TDictionary.Destroy;
- Var
- I : Integer;
- begin
- For I:=0 to Flist.Count-1 do
- FList.Objects[i].Free;
- FreeAndNil(FList);
- inherited Destroy;
- end;
- procedure TDictionary.AddVariable(const AName, Value: String);
- Var
- I : Integer;
- begin
- I:=Flist.IndexOf(AName);
- If I=-1 then
- I:=FList.Add(Aname)
- else
- Flist.Objects[i].Free;
- Flist.Objects[i]:=TValueItem.Create(Value);
- end;
- procedure TDictionary.AddFunction(const AName: String;
- FReplacement: TReplaceFunction);
- Var
- I : Integer;
- begin
- I:=Flist.IndexOf(AName);
- If I=-1 then
- I:=Flist.Add(AName)
- else
- Flist.Objects[i].Free;
- Flist.Objects[i]:=TFunctionItem.Create(FReplacement);
- end;
- procedure TDictionary.RemoveItem(const AName: String);
- Var
- I : Integer;
- begin
- I:=Flist.IndexOf(AName);
- If (I<>-1) then
- begin
- FList.Objects[i].Free;
- FList.Delete(I);
- end;
- end;
- function TDictionary.GetValue(const AName: String): String;
- begin
- Result:=GetValue(AName,'');
- end;
- function TDictionary.GetValue(const AName,Args: String): String;
- Var
- O : TObject;
- I : Integer;
- begin
- I:=Flist.IndexOf(AName);
- If (I=-1) then
- Raise EDictionaryError.CreateFmt(SErrNoDictionaryItem,[AName]);
- O:=Flist.Objects[I];
- If O is TValueItem then
- Result:=Result+TValueItem(O).FValue
- else
- Result:=Result+TFunctionItem(O).FFunc(AName,Args);
- end;
- function TDictionary.ReplaceStrings(Const ASource: String): String;
- Var
- S,FN,FV : String;
- P: Integer;
- begin
- Result:='';
- S:=ASource;
- P:=Pos('$(',S);
- While (P<>0) do
- begin
- Result:=Result+Copy(S,1,P-1);
- Delete(S,1,P+1);
- P:=Pos(')',S);
- FN:=Copy(S,1,P-1);
- Delete(S,1,P);
- P:=Pos(' ',FN);
- If (P<>0) then // function arguments ?
- begin
- FV:=FN;
- FN:=Copy(FN,1,P);
- System.Delete(FV,1,P);
- end
- else
- FV:='';
- Result:=Result+GetValue(FN,FV);
- P:=Pos('$(',S);
- end;
- Result:=Result+S;
- end;
- Function Substitute(Const Source : String; Macros : Array of string) : String;
- Var
- I : Integer;
- begin
- I:=0;
- While I<High(Macros) do
- begin
- Dictionary.AddVariable(Macros[i],Macros[I+1]);
- Inc(I,2);
- end;
- Result:=Dictionary.ReplaceStrings(Source);
- While I<High(Macros) do
- begin
- Dictionary.RemoveItem(Macros[i]);
- Inc(I,2);
- end;
- end;
- Initialization
- OnGetApplicationName:=@GetFPMakeName;
- Finalization
- FreeAndNil(DefInstaller);
- FreeAndNil(DefDictionary);
- end.
|